Bild mit korrektem Bildseitenverhältnis in Kommentar einfügen

[TxbyFmjy]

Hallo,

im englischsprachigen Raum habe ich folgende Funktion gefunden:

Code:

Public Function ImageInComment(ImageFile As Variant, _
    Optional Target As Range = Nothing, _
    Optional ScaleFactor As Single = 1#, _
    Optional RotateAngle As Integer = 0, _
    Optional NoAuthor As Boolean = False) As String

    Dim sResult As String, sFile As String, sPath As String, sPS As String, rCell As Range, bError As Boolean
    Dim oWIA As Object, oIP As Object
   
    Const PtPerInch As Integer = 72 ' points/inch; WIA metrics are pixels and pixels/inch
   
    sResult = "See image in comment, "
    If TypeName(ImageFile) = "Range" Then sFile = ImageFile.Cells(1).Value Else sFile = ImageFile
    sPath = sFile
    sPS = Application.PathSeparator
    If Target Is Nothing Then
        Set rCell = Application.Caller
        sResult = sResult & "this cell"
    Else
        Set rCell = Target.Cells(1)
        sResult = sResult & "cell " & rCell.Address(False, False)
    End If
    bError = (Dir(sPath) = vbNullString Or sFile = vbNullString)
    If bError And sFile <> vbNullString Then
        If ActiveWorkbook.Path <> vbNullString Then
            sPath = ActiveWorkbook.Path & sPS & sFile
            bError = (Dir(sPath) = vbNullString)
        End If
        If bError Then
            sPath = Application.DefaultFilePath & sPS & sFile
            bError = (Dir(sPath) = vbNullString)
        End If
    End If
    Set oWIA = CreateObject("WIA.ImageFile")
    If Not bError Then bError = oWIA.LoadFile(sPath)
    With rCell
        If .Comment Is Nothing Then .AddComment IIf(NoAuthor, " ", vbNullString)
        With .Comment.Shape
            If bError Then
                .Fill.Solid
                sResult = "Invalid ImageFile"
            Else
                Set oIP = Nothing
                Select Case RotateAngle
                Case 90, 180, 270
                    Set oIP = CreateObject("WIA.ImageProcess")
                    oIP.Filters.Add oIP.FilterInfos("RotateFlip").FilterID
                    oIP.Filters(1).Properties("RotationAngle") = RotateAngle
                    Set oWIA = oIP.Apply(oWIA)
                    sFile = sPath
                    sPath = Environ("TEMP") & sPS & GUID_String() & "." & oWIA.FileExtension
                    bError = oWIA.SaveFile(sPath)
                    If bError Then ' restore origiinal image
                        sPath = sFile
                        bError = oWIA.LoadFile(sPath)
                        Set oIP = Nothing
                    End If
                End Select
                .LockAspectRatio = False
                .Height = oWIA.Height * PtPerInch / oWIA.VerticalResolution
                .Width = oWIA.Width * PtPerInch / oWIA.HorizontalResolution
                .LockAspectRatio = True
                .Height = IIf(ScaleFactor > 100, ScaleFactor, .Height * ScaleFactor)
                .Fill.UserPicture sPath
                If Not (oIP Is Nothing) Then
                    Kill sPath
                    Set oIP = Nothing
                End If
            End If
        End With
    End With
    Set oWIA = Nothing
    ImageInComment = sResult
   
End Function

[steve1da]

Hola,

und jetzt?
Gruß,
steve1da

[TxbyFmjy]

Entschuldigung



Bild zum Ausprobieren:    


Datei zum Üben:
  Function ImageInComment.xlsx (Größe: 9,82 KB / Downloads: 3)

[maninweb]

Hallo,

also ich habe ja eher den Eindruck, dass Du den Code gar nicht vollständig ausprobiert hast. Sonst hättest Du z.B. GUID_String() bemerkt.
Und um ein Bild in einen Kommentar einzufügen, von mir aus auch gedreht, da gibt's ja nun einiges an Code hier und dort.
Na denn, wie auch immer.

Gruß