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]
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
OptionExplicit
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : PictureComment
' Author : Case (Ralf Stolzenburg)
' Date : 10.04.2013
' Purpose : Bilder - Liste in Spalte A - alle in Kommentaren einfügen...
'--------------------------------------------------------------------------
PublicSubPictureComment()
' Variablendeklaration
DimstrPathFileAsString
DimlngLastRowAsLong
DimobjComAsObject
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' 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
EndWith
' 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
WithTabelle1
' 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
ForlngLastRow=2TolngLastRow
' Wenn die Datei vorhanden ist, dann...
IfDir$(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
IfNot.Cells(lngLastRow,2).CommentIsNothingThen
.Cells(lngLastRow,2).Comment.Delete
EndIf
' 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
SetobjCom=.Cells(lngLastRow,2).Comment.Shape
' Bild in Kommentar einfügen und Größe ändern
WithobjCom
.Fill.UserPicturestrPathFile
.Width=266
.Height=200
EndWith
Else
' Bild wurde nicht gefunden
.Cells(lngLastRow,2).Value="no picture"
EndIf
' Objektvariable leeren
SetobjCom=Nothing
NextlngLastRow
EndWith
Fin:
' Objektvariable leeren
SetobjCom=Nothing
' Die Applikation aufwecken
WithApplication
' 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
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub