Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Grafiken in Zellkommentaren anzeigen

Gruppe

Grafikimport

Problem

Es sollen alle Bilddateien des in Zelle B1 genannten Verzeichnisses aufgelistet und die Bilder in einem Zellkommentar angezeigt werden.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

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

    

Beiträge aus dem Excel-Forum zu den Themen Grafik und Grafikimport