AW: Suchen Sie Sowas?
14.03.2006 14:05:10
Heiko
Hallo Andreas,
dann so, bitte Code komplett austauschen.
Option Explicit
Dim strDirs() As String
Dim strPaths() As String
Dim intTiefe() As Integer
Dim intArrayCounter As Integer, intTiefeMerker As Integer
Sub ShowDir()
Dim inthelp As Integer, intN As Integer, intI As Integer
Dim strPfad As String
Application.ScreenUpdating = False
strPfad = "D:\"
Erase strDirs
Erase intTiefe
Erase strPaths
ReDim Preserve strDirs(intArrayCounter)
ReDim Preserve strPaths(intArrayCounter)
ReDim Preserve intTiefe(intArrayCounter)
strDirs(0) = strPfad
strPaths(0) = strPfad
intTiefe(0) = 1
intTiefeMerker = 1
intArrayCounter = 1
ShowFolderList1 (strPfad)
ActiveSheet.Cells.Delete
intN = 1
For inthelp = LBound(strDirs) To UBound(strDirs)
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp)), _
Address:=strPaths(inthelp), TextToDisplay:=strDirs(inthelp)
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.Bold = True
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.ColorIndex = 3
With Application.FileSearch
.NewSearch
.LookIn = strPaths(inthelp)
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Execute
If .FoundFiles.Count > 0 Then
For intI = 1 To .FoundFiles.Count
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp) + 1), _
.FoundFiles(intI)
intN = intN + 1
Next intI
End If
End With
intN = intN + 1
Next inthelp
Application.ScreenUpdating = True
End Sub
Private Function ShowFolderList1(strPath As String)
Dim objFileSystemOb As Object, objGetFolder As Object, objSubFolderList As Object
Dim objSubFolder As Object
Dim strSubName As String
Set objFileSystemOb = CreateObject("Scripting.FileSystemObject")
Set objGetFolder = objFileSystemOb.GetFolder(strPath)
Set objSubFolder = objGetFolder.SubFolders
On Error GoTo errorhandler
For Each objSubFolderList In objSubFolder
strSubName = objSubFolderList.Name
' Versteckte Verzeichnisse und Systemordner nicht mit ausgeben.
If (GetAttr(strPath & strSubName) And vbDirectory) And _
(GetAttr(strPath & strSubName) And vbHidden) = False And _
(GetAttr(strPath & strSubName) And vbSystem) = False Then
ReDim Preserve strDirs(intArrayCounter)
ReDim Preserve strPaths(intArrayCounter)
ReDim Preserve intTiefe(intArrayCounter)
strDirs(intArrayCounter) = strSubName
strPaths(intArrayCounter) = objSubFolderList.Path
intTiefe(intArrayCounter) = intTiefeMerker
intArrayCounter = intArrayCounter + 1
intTiefeMerker = intTiefeMerker + 1
ShowFolderList1 (strPath & objSubFolderList.Name & "\")
intTiefeMerker = intTiefeMerker - 1
End If
Next
errorhandler:
strSubName = "Kein Zugriff"
Resume Next
End Function
Gruß Heiko
PS: Rückmeldung wäre nett !