AW: Bilder als Kommentar per Makro einfügen
18.02.2013 09:05:38
Franz
Hallo Lemmi,
das gibt's nen schönen Code von Hans, den ich auch nicht im Detail verstehe, aber für mich abwandeln konnte, vielleicht hilft's Dir weiter:
Option Explicit
Option Private Module
Sub PicShow()
Dim pct As Picture
Dim cmt As Comment
Dim arr() As String
Dim arrPics() As Variant
Dim iFile As Integer, iRow As Integer, iCounter As Integer, iPattern As Integer
Dim iAll As Integer, iCol As Integer
Dim sPattern As String, sPath As String, sFile As String
Dim bln As Boolean
Application.ScreenUpdating = False
sPath = Range("B1").Value
Range("A4:D65536").Clear
iAll = 1
sPattern = "*.gif"
For iPattern = 1 To 2
arrPics = FileArray(sPath, sPattern)
Call QuickSort(arrPics) 'Prozedur s. unten
If arrPics(1) = False Then
If iPattern = 1 Then GoTo NEXTPATTERN
If IsEmpty(Range("A4")) Then
Beep
MsgBox "Im Verzeichnis """ & sPath & """ wurde keine Bilddatei gefunden!"
End If
GoTo ERRORHANDLER
End If
For iCounter = iAll To UBound(arrPics)
sFile = sPath & "\" & arrPics(iCounter)
ReDim Preserve arr(1 To 5, 1 To iCounter)
bln = True
Set pct = ActiveSheet.Pictures.Insert(sFile)
arr(1, iCounter) = sFile
arr(2, iCounter) = arrPics(iCounter)
arr(3, iCounter) = FileDateTime(sFile)
arr(4, iCounter) = CInt(pct.Width * 1.33333)
arr(5, iCounter) = CInt(pct.Height * 1.33333)
pct.Delete
For iCol = 2 To 5
Cells(iCounter + 3, iCol - 1).Value = arr(iCol, iCounter)
Next iCol
Set cmt = Cells(iCounter + 3, 1).AddComment
With cmt.Shape
.Width = CInt(arr(4, iCounter) / 1.33333)
.Height = CInt(arr(5, iCounter) / 1.33333)
With .Line
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.BackColor.SchemeColor = 80
.Transparency = 0#
.UserPicture arr(1, iCounter)
End With
End With
Next iCounter
iAll = iCounter
NEXTPATTERN:
Erase arrPics
sPattern = "*.jpg"
Next iPattern
If bln = False Then
Beep
MsgBox "Es wurden keine Bilddateien gefunden -" & vbLf & _
"überprüfen Sie die eingetragenen Verzeichnisse!"
End If
Columns.AutoFit
ERRORHANDLER:
Application.ScreenUpdating = True
End Sub
Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
On Error Resume Next
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
V_Low2 = V_Low1
V_high2 = V_high1
V_val1 = VA_array((V_Low1 + V_high1) / 2)
While (V_Low2 V_val1 And _
V_high2 > V_Low1)
V_high2 = V_high2 - 1
Wend
If (V_Low2 V_Low1) Then Call _
QuickSort(VA_array, V_Low1, V_high2)
If (V_Low2
Grüße
Franz