Untitled

Bildergalerie

Sie wollen mit Excel eine Übersicht der Bilder eines Verzeichnisses haben?
Schön wäre auch noch eine kleine Vorschau!
Und ein Klick soll das Bild zum Bearbeiten öffnen?
Leider bringen Bilder, die in eine Tabelle eingebettet sind, viel Verdruss. Jedes Formatieren der Tabelle kann die Position der Bilder ändern. Ein Ausweg liefern Kommentare, dort kann man als Hintergrund eine Grafik verwenden. Nun ist es aber mühselig, das von Hand zu machen.
Mein Code startet einen Dialog zur Verzeichnisauswahl. Es ist dabei zu beachten, dass der Code für XL 97 geschrieben wurde, dort existiert der Operator AddressOf noch nicht, und muss nachgebildet werden. Bei Versionen > XL97 wird dir ganze Sache etwas einfacher, man muss nur folgende Zeile
    'Version = XL97
    .lpfnCallback = GetFuncAdress("Startdirectory")
durch diese ersetzen
    'Versionen > XL97
    .lpfnCallback = AddressOf_ToLong(AddressOf Startdirectory )
und kann die Funktion GetFuncAdress mitsamt der Deklarationen löschen.
Ist das Verzeichnis ausgewählt, werden alle Unterverzeichnisse nach JPGs durchsucht. Dann wird die Größe der Bilder ermittelt, um die Seitenverhältnisse richtig darzustellen. Der Pfad, der Dateiname und die Größe wird ins Tabellenblatt eingetragen. Ein Hyperlink auf die Datei wird erzeugt, und der Kommentar mit Bild eingefügt. Da der Pfad für die Grafiken auf 99 Zeichen begrenzt ist, zumindestens bei mir war danach Schluss, werden die 8+3 Datei- und Pfadnamen benutzt. Eine kleine API-Funktion macht das.

Beispieldatei (bilderschau.zip 21 KB)

'########################################################
'# Aufrufen mit
'########################################################

Private Sub cmbParsen_Click()
Bildervorschau
End Sub

'########################################################
'# In ein Modul
'########################################################
Option Explicit

Private Declare Function GetShortPathName Lib "kernel32" _
Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long

Public Sub Bildervorschau()
Dim myPfad As String, myDatei As String, Zeile As Long
Dim Weite As Double, Höhe As Double, Verhältnis As Double
Dim a As Comment, MyXlliste As New Collection, z
Dim ShortPath As String
myPfad = VBGetFolder("Ordner wählen", "C:\")
If myPfad = "" Then Exit Sub
xlliste myPfad, MyXlliste, "jpg"
With Worksheets("Bilderschau")
    .Range("A:D").ClearComments
    .Range("A:D").ClearContents
    .Range("A1") = "Pfad"
    .Range("B1") = "Datei"
    .Range("C1") = "Höhe"
    .Range("D1") = "Breite"
    Zeile = 1
    For Each z In MyXlliste
        JPEGSize z, Weite, Höhe
        ShortPath = String(150, 0)
        GetShortPathName z, ShortPath, 150
        ShortPath = Left(ShortPath, InStr(1, ShortPath, Chr(0)) - 1)
        Zeile = Zeile + 1
        .Cells(Zeile, 1) = z
        .Cells(Zeile, 2) = Dir(z)
        .Cells(Zeile, 3) = Höhe
        .Cells(Zeile, 4) = Weite
        Verhältnis = Weite / Höhe
        ActiveSheet.Hyperlinks.Add Anchor:=.Cells(Zeile, 2), Address:=ShortPath
        Set a = .Cells(Zeile, 1).AddComment
        a.Shape.Fill.UserPicture ShortPath
        a.Shape.Height = 100
        a.Shape.Width = a.Shape.Height * Verhältnis
    Next
End With
End Sub

Private Sub xlliste(Startdir As String, _
    ByRef Liste As Collection, Filter As String)
Dim V() As String, zähler As Long
Dim aktVerz As String, Dateiname As String
On Error Resume Next
If Left$(Filter, 1) <> "." Then Filter = "." & Filter
ReDim V(1 To 100)
If Right$(Startdir, 1) <> "\" Then
    'Nachschauen, ob übergebener Pfad auch einen Backslash enthält.
    'Wenn nicht, dann anhängen
    Startdir = Startdir & "\"
End If
aktVerz = Startdir
Startdir = Startdir & "*"
Dateiname = Dir$(Startdir, vbDirectory Or vbNormal)
Do While Dateiname <> ""
    If Right$(Dateiname, 1) <> "." Then
        If GetAttr(aktVerz & Dateiname) And vbDirectory Then
            'wenn Datei ein Verzeichnis ist
            zähler = zähler + 1
            'dann ein Array mit Verzeichnissen füllen.
            If zähler > UBound(V) Then
                ReDim Preserve V(1 To zähler + 1)
            End If
            V(zähler) = Dateiname
        Else
            'Handelt es sich um eine Datei,
            If LCase(Right$(Dateiname, Len(Filter))) = LCase(Filter) Then
                'und entspricht sie noch den Filterbedingungen,
                'dann den Pfad an die Collection Liste hängen.
                Liste.Add aktVerz & Dateiname, aktVerz & Dateiname
            End If
        End If
    End If
    Dateiname = Dir$()
Loop
'Jetzt erst werden die Unterverzeichnisse abgearbeitet,
'weil Dir$ mit Rekursionen nicht klarkommt.
If zähler = 0 Then Exit Sub
ReDim Preserve V(1 To zähler)
For zähler = 1 To UBound(V)
    'Jetzt ruft sich diese Sub noch mal auf.
    xlliste aktVerz & V(zähler), Liste, Filter
Next
End Sub

Private Function JPEGSize(ByVal myDatei As String, _
    Weite As Double, Höhe As Double) As Boolean
Dim ff As Long, Flag As Byte, c As Long
Dim x As Byte, y As Byte, Zeiger As Long
ff = FreeFile: Zeiger = 1
Open myDatei For Binary Access Read As ff
    Get ff, 2, Flag: Get ff, 5, x: Get ff, 6, y
    c = CDbl(x) * 256 + CDbl(y)
    Zeiger = 6
    Do
        If (Flag = &HC2) Or (Flag = &HC0) Then
            Get ff, Zeiger + 4, x: Get ff, , y
            Weite = CDbl(x) * 256 + CDbl(y)
            Get ff, Zeiger + 2, x: Get ff, , y
            Höhe = CDbl(x) * 256 + CDbl(y)
            JPEGSize = True
            Exit Do
        End If
        Zeiger = Zeiger + c - 2
        Get ff, Zeiger + 1, x
        If x <> 255 Then Exit Do
        Get ff, , Flag
        Zeiger = Zeiger + 2
        Get ff, Zeiger + 1, x: Get ff, , y
        c = CLng(x) * 256 + CLng(y)
        Zeiger = Zeiger + 2
    Loop While Flag <> &HD9
Close
End Function

'########################################################
'# In ein Modul zur Verzeichnisauswahl
'########################################################

Option Explicit
'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************
Private Declare Function GetVbaProjekt _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hVBA As Long) As Long
Private Declare Function GetFunktionsnummerString _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hVBA As Long, ByVal strFuncNameUnicode _
As String, _
strFunktionsnummer As String) As Long
Private Declare Function GetFunktionsnummerLong _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hVBA As Long, ByVal strFunktionsnummer _
As String, hlngFunction As Long) As Long
'*************************************
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDList _
Lib "shell32" (ByVal pidList As Long, _
ByVal lpBuffer As String) As Long

Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Type BROWSEINFO
  hwndOwner As Long
  pidlRoot As Long
  pszDisplayName As Long
  lpszTitle As Long
  ulFlags As Long
  lpfnCallback As Long
  lParam As Long
  iImage As Long
End Type

Private Const RETURNONLYFSDIRS = &H3
Private Const WM_SETTEXT = &HC
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, _
  ByVal lParam As String) As Long
Private strStartdirectory As String
Private strTitelDialog As String

Private Function Startdirectory(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal lp As Long, ByVal pData As Long) As Long
  'Diese Funktion wird vom Dialog aufgerufen
  If uMsg = BFFM_INITIALIZED Then
    'Wenn Dialog initialisiert wird
    If Len(strStartdirectory) > 1 Then
      'Jetzt wird das Startverzeichnis gesetzt
      SendMessage hwnd, BFFM_SETSELECTION, 1, strStartdirectory
    End If
    'Da Titel setzen bei mir unter Win XP nicht
    'Funktioniert, machen wir es hier
    SetWindowText hwnd, strTitelDialog
  End If
End Function

Public Function VBGetFolder(Titel As String, Startdir As String) As String
Dim lngListID As Long
Dim strBuffer As String
Dim udtBrowseInfo As BROWSEINFO
  'Funktioniert auch ohne vbNullChar
  strStartdirectory = Startdir & vbNullChar
  'Funktioniert auch ohne vbNullChar
  Titel = Titel & vbNullChar
  strTitelDialog = Titel
  With udtBrowseInfo
    .hwndOwner = 0
    'Funktioniert bei mir nicht (Win XP)
    '.lpszTitle = StrPtr(Titel)
    .ulFlags = RETURNONLYFSDIRS
    'Version = XL97
    .lpfnCallback = GetFuncAdress("Startdirectory")
    'Versionen > XL97
    '.lpfnCallback = AddressOf_ToLong(AddressOf Startdirectory )
  End With
  lngListID = SHBrowseForFolder(udtBrowseInfo)
  If lngListID Then
    strBuffer = String(512, 0)
    SHGetPathFromIDList lngListID, strBuffer
    strBuffer = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)
    VBGetFolder = strBuffer
  End If
End Function

Private Function AddressOf_ToLong(ByVal FPointer As Long) As Long
  'Wenn AddressOf in Versionen > XL97 benutzt wird
  'ist diese auf dem ersten Blick unnötige Funktion wichtig
  AddressOf_ToLong = FPointer
End Function

'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************
Public Function GetFuncAdress&(strFunktion$)
Dim hVBA&, lngRück&, strFunktionsnummer$
Dim hlngFunction&, strFuncNameUnicode$
strFuncNameUnicode = StrConv(strFunktion, vbUnicode)
GetVbaProjekt hVBA
If hVBA <> 0 Then
    lngRück = GetFunktionsnummerString(hVBA, _
        strFuncNameUnicode, strFunktionsnummer)
    If lngRück = 0 Then
        lngRück = GetFunktionsnummerLong(hVBA, _
            strFunktionsnummer, hlngFunction)
            If lngRück = 0 Then GetFuncAdress = _
                hlngFunction
        End If
    End If
End Function