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
Set
colFiles =
New
Collection
SearchFiles strSelectedPath, colFiles
If
colFiles.Count = 0
Then
MsgBox
"Keine Treffer."
, vbExclamation
Exit
Sub
End
If
Dim
ColCleanedFiles
As
VBA.Collection
Set
ColCleanedFiles =
New
Collection
Dim
i
As
Integer
For
i = 1
To
colFiles.Count
Dim
filename
As
String
filename = FoundFiles(colFiles(i))
ColCleanedFiles.Add filename
Next
i
Dim
xRgBezeichnung
As
Excel.Range
Dim
results
As
Collection
Set
results = Kriterien(xRgBezeichnung)
CommentHyperlink colFiles, ColCleanedFiles, results, xRgBezeichnung
End
Sub
Private
Function
CheckFile(FullFilename
As
String
)
As
Boolean
If
Right$(FullFilename, 4) <>
".png"
Then
Exit
Function
CheckFile =
True
Dim
filename
As
String
filename = GetFileName(FullFilename)
End
Function
Private
Function
GetFileName(FullPath
As
String
)
As
String
Dim
arrPath()
As
String
arrPath = Split(FullPath, "\")
GetFileName = arrPath(UBound(arrPath))
End
Function
Private
Function
FoundFiles(
ByVal
filename
As
String
)
As
String
filename = ModifyFilename(filename)
If
UBound(Split(filename,
"_"
)) >= 4
Then
Dim
parts()
As
String
parts = Split(filename,
"_"
)
filename = parts(2) & parts(3) & parts(4)
End
If
Dim
specialChars
As
String
specialChars =
"!@#$%^&*()+=-[]{}|\;:'"
"<>,.?/~`"
Dim
i
As
Integer
For
i = 1
To
Len(specialChars)
filename = Replace(filename, Mid(specialChars, i, 1),
""
)
Next
i
filename = Replace(filename,
" "
,
""
)
filename = LCase(filename)
FoundFiles = filename
End
Function
Private
Function
ModifyFilename(
ByVal
filename
As
String
)
As
String
Dim
parts()
As
String
parts = Split(filename,
"_"
)
If
UBound(parts) >= 2
Then
Dim
secondPart
As
String
secondPart = parts(1)
If
InStr(secondPart,
"."
) > 0
Then
parts(1) = Replace(secondPart,
"."
,
""
)
End
If
filename = Join(parts,
"_"
)
End
If
If
InStr(filename,
"_"
) > 0
Then
Dim
firstPart
As
String
firstPart = Split(filename,
"_"
)(0)
secondPart = Split(filename,
"_"
)(1)
If
secondPart =
"fettansatz1"
& Chr(95) &
"2"
Then
filename = firstPart &
"_fettansatz12"
End
If
End
If
filename = Replace(filename,
".png"
,
""
)
ModifyFilename = filename
End
Function
Private
Function
Kriterien(xRgBezeichnung
As
Excel.Range)
As
Collection
Dim
XRgName
As
Excel.Range
Dim
XRgKurzbezeichnung
As
Excel.Range
Dim
searchTerm1
As
String
Set
xRgBezeichnung = Application.InputBox(
"Bitte den Bereich mit der Bezeichnung auswählen:"
,
"Bitte die Spalte wählen"
, Type:=8)
If
xRgBezeichnung
Is
Nothing
Then
Exit
Function
Call
Delete(xRgBezeichnung)
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
Function
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
Function
Dim
cy
As
Long
cy = 1
Dim
results
As
Collection
Set
results =
New
Collection
Do
While
XRgName(cy, 1) <>
""
searchTerm1 = XRgName(cy, 1) & xRgBezeichnung(cy, 1) & XRgKurzbezeichnung(cy, 1)
Dim
normalizedTerm
As
String
normalizedTerm = NormalizeName(searchTerm1)
results.Add normalizedTerm
cy = cy + 1
Loop
If
XRgName(cy, 1) =
""
Then
End
If
Set
Kriterien = results
End
Function
Private
Function
NormalizeName(
ByVal
searchTerm1
As
String
)
As
String
Dim
specialChars
As
String
specialChars =
"!@#$%^&*()+=-[]{}|\;:'"
"<>,.?/~`"
Dim
i
As
Integer
For
i = 1
To
Len(specialChars)
searchTerm1 = Replace(searchTerm1, Mid(specialChars, i, 1),
""
)
Next
i
searchTerm1 = LCase(Trim(searchTerm1))
searchTerm1 = Replace(searchTerm1,
" "
,
""
)
NormalizeName = searchTerm1
End
Function
Private
Function
Delete(xRgBezeichnung
As
Excel.Range)
Dim
cy
As
Long
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
End
Function
Private
Function
CommentHyperlink(colFiles
As
VBA.Collection, ColCleanedFiles
As
VBA.Collection, results
As
Collection, xRgBezeichnung
As
Excel.Range)
As
Boolean
Dim
cmt
As
Comment
Dim
cy
As
Long
Dim
cleanedFile
As
Variant
Dim
result
As
Variant
Dim
file
As
Variant
cy = 1
For
Each
cleanedFile
In
ColCleanedFiles
For
Each
result
In
results
If
cleanedFile = result
Then
xRgBezeichnung(cy, 1).Hyperlinks.Add Anchor:=xRgBezeichnung(cy, 1), Address:=colFiles(cy)
Set
cmt = xRgBezeichnung(cy, 1).AddComment
With
cmt
.Shape.Fill.UserPicture colFiles(cy)
.Shape.Height = 260
.Shape.Width = 520
.Shape.LockAspectRatio = msoFalse
End
With
End
If
Next
result
cy = cy + 1
Next
cleanedFile
CommentHyperlink =
True
If
CommentHyperlink =
False
Then
MsgBox
"Die Datei: "
& colFiles(file) &
" kann nicht zugeordnet werden. Auf korrekten Dateinamen prüfen!"
, vbCritical
Or
vbOKOnly,
"/ Problem"
End
If
cy = cy + 1
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