18.09.2021, 11:45
Hallo,
im englischsprachigen Raum habe ich folgende Funktion gefunden:
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