Option Explicit
Sub BilderKommentarundHyperlink()
Dim xFDObject As FileDialog
Dim xStrPath, xStrPicPath As String
Dim XRgName As Range
Dim XRgKurzbezeichnung As Range
Dim XRgBezeichnung As Range
Dim xRg As Range
Dim searchTerm1 As String
Dim split_filename As String
Dim cmt As Comment
Dim cy As Long
Dim file As Variant
Dim T As Variant
Dim T1 As Variant
Dim FileSystemObject As Object
Application.ScreenUpdating = False
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFDObject = Application.FileDialog(msoFileDialogFolderPicker)
With xFDObject
.Title = "Bitte den Ordner mit den Bildern wählen:"
.InitialFileName = Application.ActiveWorkbook.Path
.Show
.AllowMultiSelect = False
End With
If xFDObject.SelectedItems.Count > 0 Then
xStrPath = xFDObject.SelectedItems.Item(1)
Else
MsgBox "Keinen Ordner Ausgewählt", vbInformation Or vbOKOnly, "/ Information"
Exit Sub
End If
Set XRgBezeichnung = Application.InputBox("Bitte den Bereich für die Bilder auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgBezeichnung Is Nothing Then Exit Sub
Set XRgName = Application.InputBox("Bitte den Bereich mit dem Namen wählen:", "Bitte die Spalte anwählen", Type:=8)
If XRgName Is Nothing Then Exit Sub
Set XRgKurzbezeichnung = Application.InputBox("Bitte den Bereich mit der Kurzbeschreibung auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgKurzbezeichnung Is Nothing Then Exit Sub
For cy = 1 To XRgBezeichnung.Count
If XRgBezeichnung(cy, 1).Value2 = "" Then Exit For
If Not XRgBezeichnung(cy, 1).Comment Is Nothing Then XRgBezeichnung(cy, 1).Comment.Delete
If Not XRgBezeichnung(cy, 1).Hyperlinks Is Nothing Then XRgBezeichnung(cy, 1).Hyperlinks.Delete
Next
For Each file In FileSystemObject.GetFolder(xStrPath).Files
If UBound(Split(file.Name, "_")) = 4 Then
split_filename = Split(file.Name, "_")(2) & ", " & Split(file.Name, "_")(4) & ", " & Split(file.Name, "_")(3)
For Each T In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
split_filename = Replace(split_filename, T, "")
Next
If InStr(file.Name, "thumbs.dp") = 0 Then
cy = 1
Do While XRgName(cy, 1).Value2 <> ""
searchTerm1 = XRgName(cy, 1) & XRgKurzbezeichnung(cy, 1) & XRgBezeichnung(cy, 1)
For Each T1 In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
searchTerm1 = Replace(searchTerm1, T1, "")
Next
If searchTerm1 = split_filename Then
ActiveSheet.Hyperlinks.Add XRgBezeichnung(cy, 1), Address:=file.Path
Set cmt = XRgBezeichnung(cy, 1).AddComment
With cmt
.Shape.Fill.UserPicture file.Path
.Shape.Height = 260
.Shape.Width = 520
.Shape.LockAspectRatio = msoFalse
End With
End If
cy = cy + 1
Loop
Else
MsgBox "Die Datei: " & file.Name & " kann nicht zugeordnet werden. Auf Korrekten Dateiname prüfen!", vbCritical Or vbOKOnly, "/ Problem"
End If
Next
Application.ScreenUpdating = True
End Sub