AW: Hyperlink Kurzform setzen
28.05.2019 12:19:21
peterk
Hallo
Es sind zwar einige Deiner Funktionalitäten noch nicht drin, die Aufflistung und der Hyperlink sind aber OK
Modul Modul1
Option Explicit
Dim arrType As Variant
Dim cc As Long
Dim fso As Object
Sub Verzeichnisbaum()
Dim objBrowseDir As Object
cc = 3
Set objBrowseDir = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", &H0, 17)
Application.ScreenUpdating = False
Worksheets("Tabelle1").Range("A3:C10000").ClearContents
If Not objBrowseDir Is Nothing Then
If MsgBox("Sollen alle Dateien angezeigt werden?", vbYesNo, "alle Dateien anzeigen?") = vbNo Then
arrType = Split(InputBox("Nur Dateien mit folgenden Endungen angezeigen?" & Chr(10) & _
"(Dateiendungen kommagetrennt eingeben)", "Dateityp") & ",", ",")
Else
arrType = Split("*,", ",")
End If
AllFiles (objBrowseDir.self.path)
End If
Application.ScreenUpdating = True
Set objBrowseDir = Nothing
End Sub
Sub AllFiles(path As String)
Set fso = CreateObject("Scripting.FileSystemObject")
processfolder (path)
Set fso = Nothing
End Sub
Sub processfolder(FName As String)
Dim myFolder, mySFolder, myFile As Object
Dim myExtension As String
Dim i As Long
Set myFolder = fso.getfolder(FName)
Worksheets("Tabelle1").Cells(cc, 1).Value = myFolder.path
cc = cc + 1
For Each myFile In myFolder.Files
myExtension = UCase(fso.getextensionname(myFile))
For i = Lbound(arrType) To Ubound(arrType)
If (myExtension = Trim(UCase(arrType(i)))) Or (arrType(i) = "*") Then
Worksheets("Tabelle1").Cells(cc, 2).Value = myFile.Name
Worksheets("Tabelle1").Hyperlinks.Add Anchor:=Worksheets("Tabelle1").Cells(cc, 3), _
Address:=myFile.path, TextToDisplay:=CStr(Mid(myFile.Name, 1, 2))
cc = cc + 1
End If
Next i
Next
For Each mySFolder In myFolder.subfolders
processfolder (mySFolder.path)
Next
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0