Automatisierung, Excel: Alle Dateien aus Ordner mit Hyperlink?

Option Explicit
'© 2004 Matthias Köhler, [email][email protected][/email]


' 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



Public Sub mp3VerzeichnisAuflistenAlsHyperlink()
'Makro zum Auflisten der mp3-Files eines Directories
'
'Die Ausgabe erfolgt in einem neu angelegten Blatt
'
'a) mit Auswahl des Pfades
'b) fester Filter *.mp3 für Dateinamen
'c) Hyperlink wird nur mit Dateinamen angezeigt
Dim ws As Worksheet
Dim fs As FileSearch
Dim i As Long, z As Long
Dim s_tmp As String, sSuchpfad As String
Dim ret As Integer

 -> Auswahl des Pfades
  sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)

  If sSuchpfad =  Then
    ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
            vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
  Else
    
   ->neues Blatt anlegen
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set ws = Worksheets(Worksheets.Count)
   ->Zeilenzähler für nächsten Eintrag initialisieren
    z = 1
   ->Überschrift
    ws.Cells(z, 1).Value = folgende mp3files befinden sich im Pfad  & sSuchpfad
    ws.Cells(z, 1).Font.Bold = True
    z = z + 2->Zeilenzaehler für naechsten Eintrag erhöhen
     
    ws.Cells(z, 1).Value = links zu mp3-files
    ws.Cells(z, 1).Font.Bold = True
    z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
     
   ->Filenamen aus dem Directory sPath auflisten
     Set fs = Application.FileSearch
     
     With fs
        .NewSearch
        .LookIn = sSuchpfad
        .FileName = *.mp3
        i = .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending)
        If .FoundFiles.Count > 0 Then
          For i = 1 To .FoundFiles.Count
              s_tmp = .FoundFiles(i)
              ws.Cells(z, 1).Value = NurFilenamen(s_tmp)->ohne Pfad
              ws.Hyperlinks.Add Anchor:=ws.Cells(z, 1), Address:=s_tmp
              z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
          Next i
        Else
          ws.Cells(z, 1).Value = kein File vorhanden :-(
          MsgBox Keine Dokumente gefunden
        End If
     End With
     ws.Columns(1).AutoFit
  End If
End Sub
Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
Dim p1 As Integer, p2 As Integer

  p2 = 0: p1 = 0
  Do
    p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
    If p1 <> 0 Then p2 = p1
  Loop While p1 <> 0
  NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
End Function

Option Explicit
'© 2004 Matthias Köhler, [email][email protected][/email]


' 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
    Const c_DateiFilter = *.mp3

' 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
Public Sub mp3VerzeichnisAuflistenAlsHyperlink()
  Dim b_ok As Boolean, l_Zanf As Long, l_Zend As Long
  b_ok = fkt_mp3VerzeichnisAuflistenAlsHyperlink(l_Zanf, l_Zend)
End Sub
Private Function fkt_mp3VerzeichnisAuflistenAlsHyperlink( _
                                    l_Zanf As Long, _
                                    l_Zend As Long) As Boolean
'Makro zum Auflisten der mp3-Files eines Directories
'
'Die Ausgabe erfolgt in einem neu angelegten Blatt
'
'a) mit Auswahl des Pfades
'b) fester Filter *.mp3 für Dateinamen
'c) Hyperlink wird nur mit Dateinamen angezeigt
Dim ws As Worksheet
Dim fs As FileSearch
Dim i As Long, z As Long
Dim s_tmp As String, sSuchpfad As String
Dim ret As Integer
  
 ->Rückgabekennung auf ok setzen
  fkt_mp3VerzeichnisAuflistenAlsHyperlink = True
  
 -> Auswahl des Pfades
  sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)

  If sSuchpfad =  Then
    ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
            vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
    fkt_mp3VerzeichnisAuflistenAlsHyperlink = False
  Else
    
   ->neues Blatt anlegen
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set ws = Worksheets(Worksheets.Count)
   ->Zeilenzähler für nächsten Eintrag initialisieren
    z = 1
   ->Überschrift
    ws.Cells(z, 1).Value = folgende mp3files befinden sich im Pfad  & sSuchpfad
    ws.Cells(z, 1).Font.Bold = True
    z = z + 2->Zeilenzaehler für naechsten Eintrag erhöhen
     
    ws.Cells(z, 1).Value = links zu mp3-files
    ws.Cells(z, 1).Font.Bold = True
    z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
    
   ->Filenamen aus dem Directory sPath auflisten
     Set fs = Application.FileSearch
     
     With fs
        .NewSearch
        .LookIn = sSuchpfad
        .FileName = c_DateiFilter
        i = .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending)
        If .FoundFiles.Count > 0 Then
          For i = 1 To .FoundFiles.Count
              If i = 1 Then l_Zanf = z
              s_tmp = .FoundFiles(i)
              ws.Cells(z, 1).Value = NurFilenamen(s_tmp)->ohne Pfad
              ws.Hyperlinks.Add Anchor:=ws.Cells(z, 1), Address:=s_tmp
              l_Zend = z
              z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
          Next i
        Else
          ws.Cells(z, 1).Value = kein File vorhanden :-(
          MsgBox Keine Dokumente gefunden
          fkt_mp3VerzeichnisAuflistenAlsHyperlink = False
        End If
     End With
     ws.Columns(1).AutoFit
  End If
End Function
Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
Dim p1 As Integer, p2 As Integer

  p2 = 0: p1 = 0
  Do
    p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
    If p1 <> 0 Then p2 = p1
  Loop While p1 <> 0
  NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
End Function


'***************************************************************
Public Sub NeueMp3AlsHyperlinkAnVorhandeneListeAnfuegen()
'***************************************************************
'Anhängen neuer mp3-Files eines Directories an eine bestehende Liste
'
'Das Blatt mit der bereits vorhandene Liste muß aktiviert sein.
'
'a) Auflistung der mp3-files eines wählbaren Directories
'   auf einem neu angelegten Tabellenblatt
'   (mit Auswahl des Pfades, fester Filter *.mp3 für Dateinamen,
'   Hyperlink nur mit Dateinamen)
'
'b) es wird die Spaltennummer des aktiven Blattes abgefragt,
'   mit der die neue Liste verglichen werden soll
'
'c) die bereits vorhandenen mp3files-Hyperlinks werden
'   auf dem neuen Tabellenblatt gelöscht
'
'd) die verbleibenden mp3files-Hyperlinks werden der alten Liste
'   entsprechend der Spaltennummer unten angefügt
'
'e) das neue Tabellenblatt wird gelöscht
'***************************************************************
  Dim l_Spaltennummer As Long, s_tmp As String
  Dim ws_a As Worksheet, ws_n As Worksheet
  Dim l_Zanf As Long, l_Zend As Long
  Dim l_Rows As Long, a As Long, n As Long, l_Rows2 As Long
  
 ->aktuelles Blatt merken
  Set ws_a = ActiveSheet
  
 ->a) Auflistung der mp3-files eines wählbaren Directories
 ->   auf einem neu angelegten Tabellenblatt
 ->   (mit Auswahl des Pfades, fester Filter *.mp3 für Dateinamen,
 ->   Hyperlink nur mit Dateinamen)
  If fkt_mp3VerzeichnisAuflistenAlsHyperlink(l_Zanf, l_Zend) = False Then
    Exit Sub
  End If
  Set ws_n = ActiveWorkbook.Worksheets(Worksheets.Count)
  
 ->b) es wird die Spaltennummer des aktiven Blattes abgefragt,
 ->   mit der die neue Liste verglichen werden soll
  ws_a.Activate
  l_Spaltennummer = 0
  Do
    s_tmp = InputBox( _
      Bitte geben Sie für den Vergleich die Spaltennummer & vbLf & _
      auf dem aktiven Tabellenblatt an (zulässig 1-10)., _
      Eingabe der Spaltennummer)
    Select Case s_tmp
      Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 10
        l_Spaltennummer = s_tmp
    End Select
  Loop While l_Spaltennummer = 0

 ->c) die bereits vorhandenen mp3files-Hyperlinks werden
 ->   auf dem neuen Tabellenblatt gelöscht
  l_Rows = ws_a.Cells(ws_a.Rows.Count, l_Spaltennummer).End(xlUp).Row
  For n = l_Zend To l_Zanf Step -1
    s_tmp = ws_n.Cells(n, 1).Value
    For a = 1 To l_Rows
      If s_tmp = ws_a.Cells(a, l_Spaltennummer).Value Then
       ->gleicher Eintrag in alt und neu -> neuen löschen
        ws_n.Rows(n).Delete
        Exit For
      End If
    Next
  Next

 ->d) die verbleibenden mp3files-Hyperlinks werden der alten Liste
 ->   entsprechend der Spaltennummer unten angefügt
  ws_n.Activate
  l_Rows2 = ws_n.Cells(ws_n.Rows.Count, 1).End(xlUp).Row
 ->ist was Neues übriggeblieben ?
  If l_Rows2 >= l_Zanf Then
    ws_n.Range(ws_n.Cells(l_Zanf, 1), ws_n.Cells(l_Rows2, 1)).Copy
    ws_a.Activate
    ws_a.Cells(l_Rows + 1, l_Spaltennummer).Select
    ws_a.Paste
    ws_a.Cells(l_Rows + 1, l_Spaltennummer).Select
  End If

 ->e) das neue Tabellenblatt wird gelöscht
  Application.DisplayAlerts = False
  ws_n.Delete
  Application.DisplayAlerts = True
  
  
  On Error Resume Next
  Set ws_a = Nothing: Set ws_n = Nothing
  On Error GoTo 0
End Sub

Const c_DateiFilter = *.mp3

Const c_DateiFilter = *.xls;*.txt