Option
Explicit
Sub
BilderHyperlink()
Dim
strSelectedPath
As
String
Dim
xFDObject
As
FileDialog
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
strSelectedPath = xFDObject.SelectedItems.Item(1)
Else
MsgBox
"Keinen Ordner Ausgewählt"
, vbInformation
Or
vbOKOnly,
"/ Information"
Exit
Sub
End
If
Dim
colFiles
As
VBA.Collection
If
SearchFiles(strSelectedPath, colFiles) = 0
Then
Call
MsgBox(
"Keine Treffer."
, vbExclamation)
Exit
Sub
End
If
Dim
vntFullFilename
As
Variant
For
Each
vntFullFilename
In
colFiles
Call
HandleFile(
CStr
(vntFullFilename))
Next
Dim
XRgName
As
Range
Dim
XRgKurzbezeichnung
As
Range
Dim
XRgBezeichnung
As
Range
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
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
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
Dim
SearchTerm1
As
String
Dim
cy
As
Long
SearchTerm1 = NormalizeName(cy, XRgName, XRgKurzbezeichnung, XRgBezeichnung, SearchTerm1)
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
Dim
Filename
As
String
CommentHyperlink SearchTerm1, Filename
Next
End
Sub
Private
Sub
HandleFile(
Optional
FullFilename
As
String
)
Dim
CheckFile
As
Boolean
CheckFile = Right$(FullFilename, Len(
"thumbs.dp"
)) =
"thumbs.dp"
If
CheckFile =
True
Then
Exit
Sub
Else
Call
NormalizeFileName(FullFilename)
End
If
End
Sub
Function
NormalizeFileName(
ByVal
Filename
As
String
)
As
String
Filename = Trim(Filename)
Dim
specialChars()
As
String
specialChars = Split(
"!@#$%^&*()+=-[]{}|\;:'"
"<>,.?/~`"
,
""
)
Dim
i
As
Integer
For
i = 0
To
UBound(specialChars)
Filename = Replace(Filename, specialChars(i),
""
)
Next
i
Filename = LCase(Filename)
NormalizeFileName = Filename
End
Function
Function
NormalizeName(
ByVal
cy
As
Integer
, XRgName
As
Range, XRgKurzbezeichnung
As
Range, XRgBezeichnung
As
Range,
ByRef
SearchTerm1
As
String
)
As
String
Dim
specialChars()
As
Variant
Dim
i
As
Integer
SearchTerm1 = Trim(SearchTerm1)
specialChars = Array(
"!"
,
"@"
,
"#"
,
"$"
,
"%"
,
"^"
,
"&"
,
"*"
,
"("
,
")"
,
"+"
,
"="
,
"-"
,
"["
,
"]"
,
"{"
,
"}"
,
"|"
,
"\", "
;
", "
:
", "
""
", "
<
", "
>
", "
,
", "
.
", "
?
", "
/
", "
~
", "
`")
For
i = LBound(specialChars)
To
UBound(specialChars)
SearchTerm1 = Replace(SearchTerm1, specialChars(i),
""
)
Next
i
SearchTerm1 = LCase(SearchTerm1)
NormalizeName = SearchTerm1
End
Function
Private
Function
CheckFile(FullFilename
As
String
)
As
Boolean
CheckFile = Right$(FullFilename, 4) =
".png"
End
Function
Function
CommentHyperlink(SearchTerm1
As
String
, Filename
As
String
)
As
Boolean
Dim
file
As
Object
Dim
XRgBezeichnung
As
Range
Dim
cy
As
Integer
Dim
cmt
As
Comment
Filename = NormalizeFileName(Filename)
If
SearchTerm1 = 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
CommentHyperlink =
True
Else
MsgBox
"Die Datei: "
& file.Name &
" kann nicht zugeordnet werden. Auf korrekten Dateinamen prüfen!"
, vbCritical
Or
vbOKOnly,
"/ Problem"
CommentHyperlink =
False
End
If
End
Function
Private
Function
SearchFiles(Path
As
String
, FoundFiles
As
VBA.Collection)
As
Long
If
FoundFiles
Is
Nothing
Then
Set
FoundFiles =
New
VBA.Collection
End
If
Dim
strPath
As
String
Dim
strFilename
As
String
strPath = IIf(Right$(Path, 1) <>
"\", Path & "
\", Path)
On
Error
GoTo
ErrHandler
strFilename = Dir$(strPath, vbDirectory)
On
Error
GoTo
0
Dim
fileAttr
As
VbFileAttribute
Dim
colDirectories
As
VBA.Collection
Set
colDirectories =
New
VBA.Collection
Do
While
strFilename <> vbNullString
On
Error
GoTo
ErrHandler
fileAttr = -1
fileAttr = GetAttr(strPath & strFilename)
On
Error
GoTo
0
If
(fileAttr
And
vbDirectory) = vbDirectory
And
Not
(fileAttr
And
vbSystem) = vbSystem
Then
If
strFilename =
"."
Or
strFilename =
".."
Then
GoTo
Continue_Do
End
If
Call
colDirectories.Add(strPath & strFilename)
ElseIf
(fileAttr
And
vbNormal) = vbNormal
And
Not
(fileAttr
And
vbSystem) = vbSystem
Then
If
CheckFile(strPath & strFilename)
Then
Call
FoundFiles.Add(strPath & strFilename)
End
If
End
If
Continue_Do:
strFilename = Dir$()
Loop
DoEvents
Dim
vntDirectory
As
Variant
For
Each
vntDirectory
In
colDirectories
Call
SearchFiles(
CStr
(vntDirectory), FoundFiles)
Next
SearchFiles = FoundFiles.Count
Exit
Function
ErrHandler:
Debug.Print Format$(Now,
"yyyy-mm-dd"
); Tab(12);
"'"
; Err.Source;
"'"
; _
Tab(2);
"Path: '"
; strPath & strFilename;
"'"
; _
Tab(4);
"=> '"
; Err.Description;
"'"
Resume
Next
End
Function