Thema Datum  Von Nutzer Rating
Antwort
07.08.2023 13:32:24 Sven
Solved
07.08.2023 14:20:35 Gast49419
NotSolved
07.08.2023 15:22:44 Sven
NotSolved
07.08.2023 17:50:15 Gast78637
NotSolved
07.08.2023 18:16:20 Sven
NotSolved
07.08.2023 18:34:19 Gast59948
NotSolved
08.08.2023 06:58:57 Sven
NotSolved
08.08.2023 11:16:16 Gast40343
NotSolved
14.08.2023 15:05:32 Sven
NotSolved
15.08.2023 00:03:25 Gast27989
NotSolved
15.08.2023 08:25:11 Sven
NotSolved
15.08.2023 13:24:52 Gast20621
NotSolved
15.08.2023 14:27:50 Sven
NotSolved
16.08.2023 10:01:05 Gast11842
NotSolved
16.08.2023 12:09:31 Sven
NotSolved
16.08.2023 18:39:13 Gast50512
NotSolved
Rot Okidoki - happy coding :)
06.09.2023 11:24:56 Sven
NotSolved
07.09.2023 18:03:43 Gast32657
NotSolved
08.09.2023 11:25:14 sven
NotSolved
08.09.2023 14:47:37 Gast54751
NotSolved
08.09.2023 15:05:17 Gast74933
NotSolved
08.09.2023 17:41:50 Gast28898
NotSolved
11.09.2023 07:44:00 Sven
NotSolved
11.09.2023 14:06:32 Gast56381
NotSolved
07.08.2023 17:10:58 ralf_b
Solved
07.08.2023 18:09:35 Sven
NotSolved
07.08.2023 18:12:02 ralf_b
NotSolved
07.08.2023 18:17:57 Sven
NotSolved

Ansicht des Beitrags:
Von:
Sven
Datum:
06.09.2023 11:24:56
Views:
242
Rating: Antwort:
  Ja
Thema:
Okidoki - happy coding :)

Halli, Hallo, Hallöle...

Nach langem hin und her bin ich in meinem Projekt weiter gekommen. Nun hängt es aber leider wieder...

Ich schaffe es nicht dass Kommentare mit dem Bild als Hintergrund und die Hyperlinks zu den Bildern in der richtigen Zelle hinterlegt werden. 

Beim Debuggen werden alle benötigten Informationen von colCleanfiles, colfiles, xRgBezeichnung und results vollständig an die Function übergeben. In der  "Private Function CommentHyperlink" an der Position "Set cmt = xRgBezeichnung(cy, 1).AddComment" kommt der Laufzeitfehler '1004': Anwendungs- oder objektdefinerter Fehler. Für Ideen und vorschläge bin ich durchaus offen. Im anschluss der vollständige Code:
 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
Option Explicit
 
'////////////////////////////////////////////////
'// Auswählen eines Ordners in dem die Benötigeten
'// Bilddateien hinterlegt sind
'// Es werden alle Unterordner durchsucht und es wird
'// eine Sammlung der Dateien erstellt.
Sub BilderHyperlink()
   
Dim strSelectedPath As String
Dim xFDObject As FileDialog
   
'Ordner Auswählen
  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
   
'Nur wenn ein Ordner nicht angewählt wurde kommt eine Warnung
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
    
'Sammlung erstellen
  Dim colFiles As VBA.Collection
      Set colFiles = New Collection
 
    'Dateien im ausgewählten Ordner suchen und zur Sammlung hinzufügen
    SearchFiles strSelectedPath, colFiles
 
    If colFiles.Count = 0 Then
        MsgBox "Keine Treffer.", vbExclamation
        Exit Sub
    End If
     
    ' Anzahl der gefundenen Dateien anzeigen bei bedarf aktivieren!
    'MsgBox "Anzahl der gefundenen Dateien: " & colFiles.Count, vbInformation
    ' Übersicht der Dateien in der Sammlung
    'Dim j As Integer
    'For j = 1 To colFiles.Count
    'Debug.Print colFiles(j)
    'Next j
    
    
 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
     
    'Kontrolle über die Wertausgabe bei bedarf Aktivieren
    'For i = 1 To ColCleanedFiles.Count
    'Debug.Print ColCleanedFiles(i)
    'Next i
     
    Dim xRgBezeichnung As Excel.Range
    Dim results As Collection
    Set results = Kriterien(xRgBezeichnung)
     
    'Kontrolle über die Wertausgabe von results bei bedarf Aktivieren
    'Dim result As Variant
    'For Each result In results
    'Debug.Print result
    'Next result
 
    CommentHyperlink colFiles, ColCleanedFiles, results, xRgBezeichnung
 
End Sub
 
'////////////////////////////////////////////////
'// Untersucht eine Dateiangabe nach bestimmten Kritieren.
'// Liefert: TRUE, wenn diese Datei berücksichtigt werden soll.
'//
 
Private Function CheckFile(FullFilename As String) As Boolean
    
  'nur PNG-Dateien berücksichtigen
  If Right$(FullFilename, 4) <> ".png" Then Exit Function
    
  CheckFile = True
     
    'Den Dateinamen aus dem FullFilename extrahieren
    Dim filename As String
    filename = GetFileName(FullFilename)
 
'Kontrolle über die Wertausgabe bei bedarf Aktivieren
'Debug.Print "CheckFile: " & CheckFile
 
End Function
 
'////////////////////////////////////////////////
'// Initialisiert um es für weitere schritten nutzen zu können
'//
'//
 
Private Function GetFileName(FullPath As String) As String
 
Dim arrPath() As String
arrPath = Split(FullPath, "\")
GetFileName = arrPath(UBound(arrPath))
 
'Kontrolle über die Wertausgabe bei bedarf Aktivieren
'Debug.Print "Der Dateiname ist: " & GetFileName
 
    'Funktionsaufruf von FoundFiles
    'FoundFiles GetFileName
 
End Function
 
'////////////////////////////////////////////////
'// Dateiname ist wie Folgt aufgebaut XX_XXXXX_Name_Bezeichnung_KurzBezeichnung_XXXXXXXX
'// X ist eine variable und soll nicht beachtet werden
'// Der Dateiname wird Zerlegt und Bereinigt um es
'// im Nächsten schritt mit den suchkriterien abzugleichen
'// der Dateiname wir in nameBezeichnungKurzbezeichnung
'// Am ende wird der Bereinigtename ausgegeben
 
'Dateinamen anpassen
Private Function FoundFiles(ByVal filename As String) As String
     
'Beim Dateinamen die Kriterien selectieren
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
 
' Entferne Sonderzeichen aus dem Dateinamen
Dim specialChars As String
specialChars = "!@#$%^&*()+=-[]{}|\;:'""<>,.?/~`"
 
Dim i As Integer
For i = 1 To Len(specialChars)
    filename = Replace(filename, Mid(specialChars, i, 1), "")
Next i
 
' Entferne Leerzeichen im Dateinamen
filename = Replace(filename, " ", "")
 
' Vereinheitliche die Groß- und Kleinschreibung des Dateinamens
filename = LCase(filename)
 
FoundFiles = filename
 
'Kontrolle der Ergebnisse bei Bedarf aktivieren
'Debug.Print "fileName: " & filename
 
End Function
 
 
'////////////////////////////////////////////////
'// Um Regelkarten die auserhalb der Norm sind auf die
'// benötigten gegebenheiten anzupassen wird vor dem
'// erstellen des vermeintlichen Dateinamens eine
'// Funktion durchlaufen die die Dateinamen so zuschneidet,
'// dass diese in ein Dateinamen umgewandelt werden können
 
 
Private Function ModifyFilename(ByVal filename As String) As String
Dim parts() As String
parts = Split(filename, "_")
 
' Überprüfe, ob ein Punkt vor dem zweiten Unterstrich steht
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
 
' Überprüfe, ob nach dem ersten Unterstrich "fettansatz1_2" steht
' durch den Unterstricht wird der Dateiname ansonsten verfälscht
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
 
' Entferne .png aus dem Dateinamen
filename = Replace(filename, ".png", "")
 
ModifyFilename = filename
 
End Function
 
 
 
 
'////////////////////////////////////////////////
'// Damit die Bilder richtig zugeordnet werden, muss ein
'// abgleich mit dem Dateinamen erfolgen. Hierzu werden
'// die Kriterien aus der Tabelle ausgewählt und zur
'// weiterverarbeitung bereit gestellt.
 
Private Function Kriterien(xRgBezeichnung As Excel.Range) As Collection
    ' Kriterien Auswählen
    Dim XRgName As Excel.Range
    Dim XRgKurzbezeichnung As Excel.Range
    Dim searchTerm1 As String
 
    ' Hier wird die Bezeichnung ausgewählt und der Hyperlink und das Bild hinterlegt
    Set xRgBezeichnung = Application.InputBox("Bitte den Bereich mit der Bezeichnung auswählen:", "Bitte die Spalte wählen", Type:=8)
    'Zum Überprüfen der Range aktivieren wen nötig
    'MsgBox xRgBezeichnung.Address
    If xRgBezeichnung Is Nothing Then Exit Function
 
    Call Delete(xRgBezeichnung)
 
    ' Hier wird die Kurzbezeichnung ausgewählt
    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
 
    ' Hier wird der Name ausgewählt
    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
 
    ' Container für die Ergebnisse
    Dim results As Collection
    Set results = New Collection
 
    ' Schleife über die gesamte Range
    Do While XRgName(cy, 1) <> ""
        ' Aus den Kriterien wird der mögliche Dateiname erstellt
        searchTerm1 = XRgName(cy, 1) & xRgBezeichnung(cy, 1) & XRgKurzbezeichnung(cy, 1)
 
        ' Ergebnis von Searchterm1 anzeigen (optional)
        'Debug.Print searchTerm1
 
        ' Aufruf der NormalizeName-Funktion und Zuweisung des Rückgabewerts
        Dim normalizedTerm As String
        normalizedTerm = NormalizeName(searchTerm1)
 
        ' Ergebnis zur Ergebnis-Collection hinzufügen
        results.Add normalizedTerm
        cy = cy + 1
 
    Loop
 
' Überprüfe, ob die Range durchlaufen wurde
If XRgName(cy, 1) = "" Then
 
End If
 
' Ausgabe des Inhalts der Ergebnis-Collection
'Dim result As Variant
'For Each result In Results
    'Debug.Print result
'Next result
 
' Gib die Ergebnis-Collection zurück
Set Kriterien = results
 
End Function
 
'////////////////////////////////////////////////
'// Damit ein Abgleich richtig erfolgen kann, müssen
'// die Kriterien in der Art und Weis wie der Dateiname
'// aufgebaut werden. Hierzu wird die selbe Prozedur
'// durchgeführt wie beim Dateinmaen
 
Private Function NormalizeName(ByVal searchTerm1 As String) As String
 
'Entfernen von Sonderzeichen
Dim specialChars As String
specialChars = "!@#$%^&*()+=-[]{}|\;:'""<>,.?/~`"
 
Dim i As Integer
For i = 1 To Len(specialChars)
searchTerm1 = Replace(searchTerm1, Mid(specialChars, i, 1), "")
Next i
 
'Einheitliche Groß- und Kleinschreibung
searchTerm1 = LCase(Trim(searchTerm1))
 
'Entfernt Leerzeichen
searchTerm1 = Replace(searchTerm1, " ", "")
 
'Ergebnis von searchTerm1 (nach Bereinigung) anzeigen
'Wenn nötig, aktivieren
'Debug.Print searchTerm1
 
'Speichern des normalisierten Namens
NormalizeName = searchTerm1
 
End Function
 
 
 
 
 
'////////////////////////////////////////////////
'// Um sicherzustellen, das es zu keinen Komplikationen
'// kommt, werden alle zuvor Hinterlegten Kommentare
'// und Hyperlinks in der Spalte Bezeichnung gelöscht.
'// Dieser schritt ist nur zur sicherheit um mögliche
'// eventualitäten auszuschließen
 
Private Function Delete(xRgBezeichnung As Excel.Range)
 
' Lösche alle Kommentare und Hyperlinks im ausgewählten Bereich
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
 
 
 
'////////////////////////////////////////////////
'// In diesem Schritt wird geprüft ob der Dateiname
'// und die Kriterien übereinstimmen. Wen es dem so
'// ist, wird das Bild im Kommentarfenster als Hinter-
'// grund hinterlegt und auf die Bezeichnung ein Hyper-
'// link zum Bild hinterlegt.
 
 
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
            ' Add hyperlink
            xRgBezeichnung(cy, 1).Hyperlinks.Add Anchor:=xRgBezeichnung(cy, 1), Address:=colFiles(cy)
 
            ' Add comment
            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
  
'////////////////////////////////////////////////
'// Durchsucht alle Unterordner nach bestimmten Dateien.
'// - siehe auch: CheckFile()
'// Liefert:
'//   Die Anzahl der Dateien in 'FoundFiles'.
 
Private Function SearchFiles(Path As String, FoundFiles As VBA.Collection) As Long
   
  'Alle Unterordner durchlaufen
   
  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:
  'TODO: implement proper logging
  Debug.Print Format$(Now, "yyyy-mm-dd"); Tab(12); "'"; Err.Source; "'"; _
              Tab(2); "Path: '"; strPath & strFilename; "'"; _
              Tab(4); "=> '"; Err.Description; "'"
  Resume Next
End Function

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
07.08.2023 13:32:24 Sven
Solved
07.08.2023 14:20:35 Gast49419
NotSolved
07.08.2023 15:22:44 Sven
NotSolved
07.08.2023 17:50:15 Gast78637
NotSolved
07.08.2023 18:16:20 Sven
NotSolved
07.08.2023 18:34:19 Gast59948
NotSolved
08.08.2023 06:58:57 Sven
NotSolved
08.08.2023 11:16:16 Gast40343
NotSolved
14.08.2023 15:05:32 Sven
NotSolved
15.08.2023 00:03:25 Gast27989
NotSolved
15.08.2023 08:25:11 Sven
NotSolved
15.08.2023 13:24:52 Gast20621
NotSolved
15.08.2023 14:27:50 Sven
NotSolved
16.08.2023 10:01:05 Gast11842
NotSolved
16.08.2023 12:09:31 Sven
NotSolved
16.08.2023 18:39:13 Gast50512
NotSolved
Rot Okidoki - happy coding :)
06.09.2023 11:24:56 Sven
NotSolved
07.09.2023 18:03:43 Gast32657
NotSolved
08.09.2023 11:25:14 sven
NotSolved
08.09.2023 14:47:37 Gast54751
NotSolved
08.09.2023 15:05:17 Gast74933
NotSolved
08.09.2023 17:41:50 Gast28898
NotSolved
11.09.2023 07:44:00 Sven
NotSolved
11.09.2023 14:06:32 Gast56381
NotSolved
07.08.2023 17:10:58 ralf_b
Solved
07.08.2023 18:09:35 Sven
NotSolved
07.08.2023 18:12:02 ralf_b
NotSolved
07.08.2023 18:17:57 Sven
NotSolved