Option Explicit
' Typdeklaration für API-Dialog->Verzeichnis auswählen'
Private Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
'***********************************************************
' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
Public Function VerzeichnisWählen(Optional DialogTitel) As String
Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
Dim hWndAccessApp As Long
With StrukturVerzeichnisInfo
.hOwner = hWndAccessApp
.lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
.ulFlags = &H1-> BIF_RETURNONLYFSDIRS
End With
ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
Pfad = Space$(512)
If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWählen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
End Function
'***********************************************************
Sub JPEGSEinfügenInSpalteBMitWurzelPfadAuswahlUndSuche()
->Im der aktuellen Arbeitsmappe wird für
->alle Bezeichnungen in Splate A (z.B A1: 1111)
->das entsprechende Bild 1111.jpg in Spalte B eingefügt.
->Die Bildhöhe wird auf c_MAXBILDHOEHE begrenzt
->
->Vor dem eigentlichen Bilder-Einfügen werden
->vorhandene Bilder in Spalte B gelöscht
->Ebenfalls Zellinhalte.
->
->Werden Bilder nicht gefunden, wird der Text
->'Bild nvorh.' in der Spalte B eingefügt.
->In der Schlußmeldung wird die Anzahl der nicht
->gefundenen Bilder genannt
->Das WurzelVerzeichnis wird über einen Auswahldialog
->bestimmt. Weiterhin wird abgefragt, ob die Unterverzeichnisse
->auch in die Suche mit einbezogen werden sollen.
->Sind zu einem Bild-Namen mehrere Fundstellen vorhanden,
->wird abgefragt, welches Bild eingefügt werden soll.
->
->Const c_PFAD_JPGs = c:\Test_jpgs-> !!!!! ANPASSEN !!!!!!
Const c_SPALTEQUELLE = 1 ' Splate A
Const c_SPALTEZIEL = 2 ' Spalte B
Const c_MAXBILDHOEHE = 100-> max. Bildhöhe in Punkten
Dim l_rows As Long, ws As Worksheet, x As Long, s As Long
Dim s_Bez As String, s_Bez_Full As String
Dim l_ZaehlerBildNichtVorh As Long, l_ZaehlerBildNichtEingefuegt As Long
Dim o_Bild As OLEObject, d_tmp As Double, l_faktor As Double
Dim sh As Shape, l_AnzBildNichtGelöscht As Long
Dim s_Pfad As String, ret As Integer, b_mitUterverzeichnissen As Boolean
Dim s_Datei As String, l_Spalte As Long
->*** Wurzelverzeichnis abfragen
s_Pfad = VerzeichnisWählen(Wurzel-Verzeichnis für jpg's auswählen)
If s_Pfad = Then Exit Sub-> Abbruch ?
->*** Abfrage mit/ohne Sub-Directories
ret = MsgBox( _
Sollen die Unterverzeichnisse mit in die Suche nach den jpg's einbezogen werden?, _
vbYesNo + vbDefaultButton2 + vbQuestion, _
Auswahl mit/ohne Unterverzeichnisse)
If ret = vbYes Then
b_mitUterverzeichnissen = True
Else
b_mitUterverzeichnissen = False
End If
->*** na dann an die Arbeit
Set ws = ActiveSheet
Application.ScreenUpdating = False
->*** alle Bilder in Spalte c_SPALTEZIEL wegräumen
l_AnzBildNichtGelöscht = 0
On Error Resume Next
For Each sh In ws.Shapes
l_Spalte = sh.TopLeftCell.Column
If Err.Number = 0 Then
If l_Spalte = c_SPALTEZIEL Then
sh.Delete
If Err.Number <> 0 Then
Err.Clear
l_AnzBildNichtGelöscht = l_AnzBildNichtGelöscht + 1
End If
End If
Else
Err.Clear
End If
Next
On Error GoTo 0
If l_AnzBildNichtGelöscht > 0 Then
MsgBox ( _
l_AnzBildNichtGelöscht & Bilder konnten in Spalte & _
c_SPALTEZIEL & nicht gelöscht werden.)
End If
->*** Anzahl Zeilen feststellen
l_rows = ws.Cells(ws.Rows.Count, c_SPALTEQUELLE).End(xlUp).Row
->über alle Zeilen
For x = 1 To l_rows
->Status-Bar: momentanen Stand ausgeben
Application.StatusBar = Bearbeiutng & l_rows & / & x
->alten Zellinhalt entfernen
ws.Cells(x, c_SPALTEZIEL).Value =
s_Bez = ws.Cells(x, c_SPALTEQUELLE).Value
->Dateiname
s_Datei = s_Bez & .jpg
->*** Datei suchen
s_Bez_Full = jpg_DateiSuchen(s_Pfad, b_mitUterverzeichnissen, s_Datei)
->*** Datei gefunden ?
If = s_Bez_Full Then
->*** Bild nicht vorhanden
ws.Cells(x, c_SPALTEZIEL).Value = Bild nvorh.
l_ZaehlerBildNichtVorh = l_ZaehlerBildNichtVorh + 1
Else
->*** Bild eintragen
->Zelle markieren
ws.Cells(x, c_SPALTEZIEL).Select
->Bild als Objekt einfügen
On Error Resume Next
ws.OLEObjects.Add(FileName:=s_Bez_Full, _
Link:=False, DisplayAsIcon:=False).Select
If Err.Number <> 0 Then
Err.Clear
l_ZaehlerBildNichtEingefuegt = l_ZaehlerBildNichtEingefuegt + 1
ws.Cells(x, c_SPALTEZIEL).Select
ret = MsgBox(Das Bild & s_Bez_Full & _
konnte nicht eingefügt werden. & vbLf & vbLf & _
Zelle: & ws.Cells(x, c_SPALTEZIEL).Address & vbLf & _
Wollen Sie fortfahren?, vbExclamation + vbYesNo)
If ret = vbNo Then Exit For
Else
Set o_Bild = Selection
o_Bild.Placement = xlMove->xlFreeFloating
o_Bild.PrintObject = True
->Bildhöhe begrenzen
If o_Bild.Height > c_MAXBILDHOEHE Then
->skalieren
l_faktor = c_MAXBILDHOEHE / o_Bild.Height
o_Bild.ShapeRange.ScaleWidth l_faktor, msoFalse, msoScaleFromTopLeft
o_Bild.ShapeRange.ScaleHeight l_faktor, msoFalse, msoScaleFromTopLeft
End If
->Zeilenhöhe dem Bild anpassen
ws.Rows(x).RowHeight = o_Bild.Height
End If
End If
Next
ws.Cells(1, c_SPALTEQUELLE).Select
->Ende-Meldung
Application.StatusBar =
If l_ZaehlerBildNichtVorh > 0 Or l_ZaehlerBildNichtEingefuegt > 0 Then
MsgBox (l_ZaehlerBildNichtVorh & Bilder wurden nicht gefunden. & vbLf & _
l_ZaehlerBildNichtEingefuegt & Bilder konnten nicht eingefügt werden.)
Else
MsgBox (Alle Bilder eingefügt.)
End If
Aufraeumen:
Application.ScreenUpdating = True
Set ws = Nothing: Set o_Bild = Nothing
End Sub
'***********************************************************
Private Function jpg_DateiSuchen(s_Pfad As String, b_mitUterverzeichnissen As Boolean, _
s_Datei As String) As String
Dim s_Bez_Full As String, x As Long
Dim f_Bild() As String, f_Bild_cnt As Long
With Application.FileSearch
.NewSearch
.LookIn = s_Pfad
.SearchSubFolders = b_mitUterverzeichnissen
.FileName = s_Datei
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
->*** Fund analysieren
If .FoundFiles.Count = 1 Then
->ein Bild gefunden
s_Bez_Full = .FoundFiles(1)
->richtigen Dateinamen gefunden ?
If \ <> Mid(s_Bez_Full, Len(s_Bez_Full) - Len(s_Datei), 1) Then
s_Bez_Full = ->ist nicht die gesuchte Datei
End If
ElseIf .FoundFiles.Count = 0 Then
s_Bez_Full =
Else
->mehrere Bilder gefunden
ReDim f_Bild(1 To 1): f_Bild_cnt = 0
For x = 1 To .FoundFiles.Count
s_Bez_Full = .FoundFiles(x)
If \ = Mid(s_Bez_Full, Len(s_Bez_Full) - Len(s_Datei), 1) Then
f_Bild_cnt = f_Bild_cnt + 1
ReDim Preserve f_Bild(1 To f_Bild_cnt)
f_Bild(f_Bild_cnt) = s_Bez_Full
End If
Next x
If f_Bild_cnt = 0 Then
s_Bez_Full =
ElseIf f_Bild_cnt = 1 Then
s_Bez_Full = f_Bild(1)
ElseIf f_Bild_cnt > 20 Then
MsgBox ( _
Datei: & s_Datei & vbLf & vbLf & _
Es wurden mehr als 20 potenzielle Kandidaten für die gefunden. & vbLf & _
--> wird übersprungen )
s_Bez_Full =
Else
->mehrere relevante Fundstellen -> eine auswählen
s_Bez_Full = DateiAuswaehlen(f_Bild(), f_Bild_cnt)
End If
End If
Else
s_Bez_Full =
End If
End With
ReDim f_Bild(1 To 1)
jpg_DateiSuchen = s_Bez_Full->vollen Dateinamen zurueckgeben
End Function
'***********************************************************
Private Function DateiAuswaehlen(f() As String, f_cnt As Long) As String
Const c_BREITE_ZEILEANGABE = 3
Dim l_zaehler As Long, s_tmp As String, s_r As String
Dim l_AnzLeerzeichen As Long, l_AnzStellen As Long, x As Long
Dim s_Nr As String, l_Nr As Long, y As Long, s As String
->Meldung zusammenstellen
s_tmp = Bitte geben Sie den Index der auszuwählenden Datei an & vbLf & vbLf
l_zaehler = 0
For x = 1 To f_cnt
s_r = x
l_AnzLeerzeichen = c_BREITE_ZEILEANGABE - Len(s_r)
If l_AnzLeerzeichen < 0 Then l_AnzLeerzeichen = 0
l_AnzStellen = Len(s_r)
s_tmp = s_tmp & Format(x, String(l_AnzLeerzeichen, _) & _
String(Len(s_r), 0)) & vbTab & f(x) & vbLf
l_zaehler = l_zaehler + 1
Next
->Meldung ausgeben und Auswahl
Nochmal:
s_Nr = InputBox( _
s_tmp, _
Auswahl zwischen mehreren gefundenen Dateien mit gleichem Namen, _
)
If s_Nr <> Then
For y = 1 To Len(s_Nr)
s = Mid(s_Nr, y, 1)
Select Case s
Case 0 To 9->zulässig
Case Else
MsgBox (Bitte nur eine Zahl eingeben.)
GoTo Nochmal
End Select
Next
l_Nr = s_Nr
If l_Nr < 0 Or l_Nr > f_cnt Then
MsgBox (Index zu groß.)
GoTo Nochmal
End If
->ausgewahlte Datei
DateiAuswaehlen = f(l_Nr)
Else
DateiAuswaehlen =
End If
End Function
