Option
Explicit
Sub
BilderHyperlink()
Dim
strPath
As
String
If
GetSelectedPath(strPath) =
False
Then
Exit
Sub
End
If
Dim
colFiles
As
VBA.Collection
If
SearchFiles(strPath, colFiles) = 0
Then
Call
MsgBox(
"Keine Treffer."
, vbExclamation)
Exit
Sub
End
If
Dim
rngShortNames
As
Excel.Range
On
Error
Resume
Next
Set
rngShortNames = Application.InputBox(
"Bitte den Bereich mit der Kurzbeschreibung auswählen:"
,
"Bitte die Spalte wählen"
, Type:=8)
If
rngShortNames
Is
Nothing
Then
Exit
Sub
On
Error
GoTo
0
Dim
vntFullFilename
As
Variant
Dim
rngCell
As
Excel.Range
Dim
strShortName
As
String
For
Each
vntFullFilename
In
colFiles
If
Not
GetShortName(
CStr
(vntFullFilename), rngShortNames, strShortName)
Then
GoTo
Continue_ForEach
End
If
Set
rngCell = Range(
"A1"
)
Call
HandleFile(rngCell, strShortName,
CStr
(vntFullFilename))
Continue_ForEach:
Next
End
Sub
Private
Sub
HandleFile(Cell
As
Excel.Range, TextToDisplay
As
String
, FullFilename
As
String
)
Call
Cell.Worksheet.Hyperlinks.Add(Cell, FullFilename, , , TextToDisplay)
With
Cell.AddComment
Call
.Shape.Fill.UserPicture(FullFilename)
.Shape.Height = 260
.Shape.Width = 520
.Shape.LockAspectRatio = msoFalse
End
With
End
Sub
Private
Function
GetShortName(FullFilename
As
String
, Range
As
Excel.Range,
ByRef
ShortName
As
String
)
As
Boolean
ShortName = Range.Cells(1, 1).Value
GetShortName =
True
End
Function
Private
Function
GetSelectedPath(
ByRef
SelectedPath
As
String
)
As
Boolean
With
Application.FileDialog(msoFileDialogFolderPicker)
.Title =
"Bitte den Ordner mit den Bildern wählen:"
.InitialFileName = Application.ActiveWorkbook.Path
.AllowMultiSelect =
False
If
.Show() = 0
Then
Call
MsgBox(
"Keinen Ordner Ausgewählt"
, vbInformation,
"/ Information"
)
Exit
Function
End
If
SelectedPath = .SelectedItems(1)
End
With
GetSelectedPath =
True
End
Function
Private
Function
CheckFile(FullFilename
As
String
)
As
Boolean
If
Right$(FullFilename, 4) <>
".png"
Then
Exit
Function
End
If
CheckFile =
True
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