Hyperlinks innerhalbe der Dateien auflisten
Pascal
Mittels dem Folgenden Code (diesen hatte ich in meiner Code-Sammlung noch aufbewahrt, nachdem ich diesen Code vor -zig Jahren mal irgendwo im Web ... oder hier ? ... gefunden hatte) kann ich einen Dateipfad auflisten lassen in einer Excel-Tabelle.
Dabei werden mir die Dateinamen sowie der komplette Pfad sauber aufgelistet. Per Hyperlink auf den Dateinamen kann ich die Datei dann bequem direkt aus Excel raus öffnen.
Nun möchte ich diese Funktion / Makro / Code um eine weitere Funktion erweitern. Und zwar möchte ich - pro Dateinamen auch noch prüfen lassen, ob es in dieser Datei drin auch Hyperlinks hat.
Wenn ja, sollen diese direkt unter dem Dateinamen auch aufgelistet werden, ehe dann die nächste Datei aufgelistet wird.
Geht das irgendwie ? - ich hoffe, meine Frage seie so einigermassen verständlich ? - Habe echt keine Ahnung wie ich dieses Vorhaben angehen soll.
Denn Ziel der ganzen Sache soll sein:
Alle Dateien eines bestimmten Verzeichnisses sollen an einen anderen Speicherort verschoben werden. Um auch zu wissen, ob in den zu verschiebenden Dateien auch noch Hyperlinks auf andere Dokumente vorher angepasst werden müssen, möchte ich wie gesagt meinen obenstehenden Code entsprechend erweitern. (Es soll pro Datei auch geprüft werden, ob in der Datei drin auch Hyperlinks stehen. Wenn ja, sollen diese direkt unter dem entsprechenden Dateinamen auch aufgelistet werden)
Herzlichen Dank schon mal für Eure Hilfe und Tips ! (ich weiss echt nicht ob das geht ... geschweige denn ... wie anfangen)
Sub beginnt hier()
Option Explicit
Public 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
Declare
Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
_
ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As _
BROWSEINFO) As Long
Sub Verzeichnisse_auflisten()
'Verzeichnisse ab Sharepoint importieren (Pfadimport) unter
'Buchstabe "P" --> Pfadimport
Dim Pfad1, Start, ende, Name1, Anzahl, i, ii, f, fc, fs, f1, x, X0, X1, X2, Verz, Anzverz, Größ _
e
Dim Pfad_Import1, Pfad_Import2 As Worksheet
Dim msg As String
Set Pfad_Import1 = Worksheets("Tabelle1")
Set Pfad_Import2 = Worksheets("Pfad_Import")
Start = Now
Pfad_Import1.[a:D] = ""
Pfad_Import2.[a:D] = ""
' Pfad abfragen
msg = "Wählen Sie bitte einen Ordner aus:"
Pfad1 = getdirectory(msg)
If Pfad1 = "" Then Exit Sub
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Pfad_Import1.[a2] = Pfad1
Anzahl = 2
Pfad_Import1.[a1] = "Pfad"
Pfad_Import1.[b1] = "UnterVerz."
Pfad_Import1.[c1] = "Anz. Dateien"
Pfad_Import1.[d1] = "Datgröße in Verz."
X0 = 2
X1 = 2
Do While Pfad_Import1.Cells(Rows.Count, 1).End(xlUp).Row Pfad_Import1.Cells(Rows.Count, 2). _
End(xlUp).Row
For X2 = X0 To X1
Pfad1 = Pfad_Import1.Cells(X2, 1) ' Pfad setzen.
If Right(Pfad1, 1) "\" Then Pfad1 = Pfad1 & "\"
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Verz = 0
Do While Name1 "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 "." And Name1 ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Anzahl = Anzahl + 1
Pfad_Import1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"
Verz = Verz + 1
'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.
End If
End If
Name1 = Dir
' Nächsten Eintrag abrufen.
Loop
Pfad_Import1.Cells(X2, 2) = Verz
Next X2
X0 = X1 + 1
X1 = X2
Loop
'Dateien aus den Verzeichnissen auslesen
Anzverz = Pfad_Import1.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
ii = 0
For Verz = 2 To Anzverz
Anzahl = 0
Größe = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Pfad_Import1.Cells(Verz, 1))
Set fc = f.Files
For Each f1 In fc
If i = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1
Set Pfad_Import2 = ThisWorkbook.Worksheets(ii + 2)
i = 1
End If
i = i + 1
Anzahl = Anzahl + 1
Pfad_Import2.Cells(i, 1) = f1.Name
Pfad_Import2.Cells(i, 2) = f & "\" & f1.Name
'Hyperlink auf die Datei einfügen
Pfad_Import2.Hyperlinks.Add Anchor:=Pfad_Import2.Cells(i, 2), Address:= _
f & "\" & f1.Name
Pfad_Import2.Cells(i, 3) = FileLen(f1)
Pfad_Import2.Cells(i, 4) = FileDateTime(f1)
Größe = Größe + FileLen(f1)
Next
Pfad_Import1.Cells(Verz, 3) = Anzahl
Pfad_Import1.Cells(Verz, 4) = Größe / 1024 / 1024
Next Verz
'MsgBox (ii * 65536) + i
ende = Now
MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _
"Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _
Chr(13) & "Dauer: " & Format(ende - Start, "nn:ss")
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
' Ausgangsordner = Desktop
bInfo.pidlRoot = 0&
' Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
' Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
' Dialog anzeigen
x = SHBrowseForFolder(bInfo)
' Ergebnis gliedern
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function
End
Sub