Bilder - Liste in Spalte A - in Kommentar einfügen...

Frage: In einem Tabellenblatt in Spalte A ab Zeile 2 habe ich Dateinamen gelistet (Bilddateien - jpg). Diese sind in einem Unterordner (Ordnername = Images) in welchem die Exceldatei liegt. Alle Bilder sollen als Kommentar in Spalte B eingefügt werden. Ist ein Bild nicht vorhanden - kurzer Hinweis in Spalte B. Wie geht das?
Kurze Notiz: Auf den Bildern ist mein Husky (Hündin) Kira.

In a worksheet in column A from row 2 I have listed filenames (image files - jpg). These are in a subfolder (folder name = Images) where the Excel file is located. All images should be inserted as a comment in Column B. If an image is not available - short note in column B. How does it work?
Short Note: On the pictures is my Husky (Female) Kira.

Hier noch eine Beispieldatei / Here's a sample file:
Bilder - Liste in Spalte A - in Kommentar einfügen...[ZIP 8 MB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : PictureComment
' Author    : Case (Ralf Stolzenburg)
' Date      : 10.04.2013
' Purpose   : Bilder - Liste in Spalte A - alle in Kommentaren einfügen...
'--------------------------------------------------------------------------
Public Sub PictureComment()
    ' Variablendeklaration
    Dim strPathFile As String
    Dim lngLastRow As Long
    Dim objCom As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier Tabelle1 = der CodeName der Tabelle
    ' Im VBA-Editor der name VOR der Klammer - Tabelle1 (Tabelle1)
    ' im englischen Excel in der Regel Sheet1
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With Tabelle1
        ' Letzte Zeile in Spalte A ermitteln
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ' Ab Zeile 2 bis Ende
        For lngLastRow = 2 To lngLastRow
            ' Wenn die Datei vorhanden ist, dann...
            If Dir$(ThisWorkbook.Path & Application.PathSeparator & _
                    "Images" & Application.PathSeparator & _
                    .Cells(lngLastRow, 1).Value) <> "" Then
                ' Ist schon ein Kommentar in der entsprechenden Zeile
                ' in Spalte B vorhanden, dann lösche ihn
                If Not .Cells(lngLastRow, 2).Comment Is Nothing Then
                    .Cells(lngLastRow, 2).Comment.Delete
                End If
                ' Füge in der entsprechenden Zeile
                ' in Spalte B einen Kommentar hinzu
                .Cells(lngLastRow, 2).AddComment
                ' Variable mit Pfad- und Dateinamen belegen
                strPathFile = ThisWorkbook.Path & Application.PathSeparator & _
                    "Images" & Application.PathSeparator & _
                    .Cells(lngLastRow, 1).Value
                ' Objektvariable mit dem Kommentar belegen
                Set objCom = .Cells(lngLastRow, 2).Comment.Shape
                ' Bild in Kommentar einfügen und Größe ändern
                With objCom
                    .Fill.UserPicture strPathFile
                    .Width = 266
                    .Height = 200
                End With
            Else
                ' Bild wurde nicht gefunden
                .Cells(lngLastRow, 2).Value = "no picture"
            End If
            ' Objektvariable leeren
            Set objCom = Nothing
        Next lngLastRow
    End With
Fin:
    ' Objektvariable leeren
    Set objCom = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...