Gruppe
Grafik
Problem
Es sollen alle Bilddateien des in Zelle B1 genannten Verzeichnisses aufgelistet und die Bilder in einem Zellkommentar angezeigt werden.
StandardModule: Modul1
Sub PicShow()
Dim pct As Picture
Dim cmt As Comment
Dim arr() As String
Dim iFile As Integer, iRow As Integer, iCounter As Integer, iPattern As Integer
Dim iAll As Integer, iCol As Integer
Dim sPattern As String
Dim bln As Boolean
Application.ScreenUpdating = False
Columns(1).NumberFormat = "@"
Range("A3").Value = "Datei"
Range("B3").Value = "Datum"
Range("C3").Value = "Breite"
Range("D3").Value = "Höhe"
With Range("A3:D3")
.Font.Bold = True
.Interior.ColorIndex = 1
.Font.ColorIndex = 2
End With
iAll = 1
sPattern = "*.gif"
For iPattern = 1 To 2
With Application.FileSearch
.LookIn = Range("B1").Value
.Filename = sPattern
.Execute
For iCounter = iAll To .FoundFiles.Count + iAll - 1
ReDim Preserve arr(1 To 5, 1 To iCounter)
bln = True
Set pct = ActiveSheet.Pictures.Insert(.FoundFiles(iCounter - iAll + 1))
arr(1, iCounter) = .FoundFiles(iCounter - iAll + 1)
arr(2, iCounter) = Dir(.FoundFiles(iCounter - iAll + 1))
arr(3, iCounter) = FileDateTime(.FoundFiles(iCounter - iAll + 1))
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
End With
sPattern = "*.jpg"
iAll = iCounter
Next iPattern
If bln = False Then
Beep
MsgBox "Es wurden keine Bilddateien gefunden -" & vbLf & _
"überprüfen Sie die eingetragenen Verzeichnisse!"
End If
Columns.AutoFit
Application.ScreenUpdating = True
End Sub