Probleme bei der Abbildung eines Trees

11/05/2014 - 15:05 von Hans Schlonies | Report spam
Hallo zusammen,

ich versuche gerade eine Verzeichnisstruktur als Baumsansicht im
Debug-Fenster auszugeben, was auch grundsàtzlich klappt.

Leider bekomme ich es überhaupt nicht gebacken, einige überflüssige
vertikale Treelines auszublenden. Ich hatte zwar zwischenzeitlich eine
Lösung gebastelt, die jedoch aus einer größeren Ansammlung Dirty Hacks
bestand. Deshalb habe ich noch einmal neu angesetzt.

Hier mal der Code:
(Einfach in ein Modul kopieren, den Pfad anpassen und starten)

Vielleicht hat ja jemand eine Idee, wie ich das am besten sauber und
effizient löse.

[code]
Option Explicit

Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
FTCreationTime As FILETIME
FTLastAccessTime As FILETIME
FTLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Declare Function FindFirstFile Lib "kernel32" Alias
"FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As
WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias
"FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As
WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As
Long) As Long

Private Type TreeItem
Folder As String
Level As Integer
SubItems As Integer
IsFirst As Boolean
IsLast As Boolean
End Type
Private m_Tree() As TreeItem
Private m_Trees As Long

Sub Main()
Call FindTree("T:\Desktop\")
Debug.Print BuildTree()
End Sub

Private Function BuildTree() As String
Dim i As Integer
Dim j As Integer
Dim szLine As String
Dim szText As String

szText = ""
For i = 0 To m_Trees
If i > 0 Then
szLine = ""

For j = 1 To m_Tree(i).Level - 1
szLine = szLine & Chr$(5) & " "
Next j

If m_Tree(i).IsLast Then
szLine = szLine & Chr$(3) & Chr$(6)
Else
szLine = szLine & Chr$(25) & Chr$(6)
End If

End If

szText = szText & szLine & m_Tree(i).Folder & vbCrLf
Next i

BuildTree = szText
End Function

Public Sub FindTree(ByVal szPath As String, _
Optional ByVal szPattern As String = "*.*", _
Optional ByVal bIsFirst As Boolean = True, _
Optional ByVal bIsLast As Boolean = False, _
Optional iMaxLevel As Integer = 255)
Static iLevel As Integer

Dim i As Long
Dim lFolders As Long
Dim szFolders() As String

If iLevel = 0 Then
If Right$(szPath, 1) <> "\" Then
szPath = szPath & "\"
End If
m_Trees = -1
End If

m_Trees = m_Trees + 1
ReDim Preserve m_Tree(m_Trees)

m_Tree(m_Trees).Folder = szPath
m_Tree(m_Trees).Level = iLevel
m_Tree(m_Trees).IsFirst = bIsFirst
m_Tree(m_Trees).IsLast = bIsLast

iLevel = iLevel + 1
If iLevel <= iMaxLevel Then
lFolders = FindFolders(szPath, szPattern, szFolders())
m_Tree(m_Trees).SubItems = lFolders
For i = 1 To lFolders
Call FindTree(szPath & szFolders(i) + "\", szPattern, CBool(i =
1), CBool(i = lFolders), iMaxLevel)
Next i
End If
iLevel = iLevel - 1

If iLevel = 0 Then
ReDim Preserve m_Tree(m_Trees + 1)
End If
End Sub

Public Function FindFolders(ByVal szPath As String, ByVal szPattern As
String, szFolder() As String) As Long
Dim lpFindFileData As WIN32_FIND_DATA
Dim hFindFile As Long
Dim lResult As Long
Dim lFolders As Long

lFolders = 0
ReDim szFolder(lFolders)

If Right$(szPath, 1) <> "\" Then szPath = szPath & "\"
szFolder(lFolders) = szPath

If Len(szPath) > 1 Then
hFindFile = FindFirstFile(szPath & szPattern, lpFindFileData)
If hFindFile > 0 Then
Do
If lpFindFileData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY
Then
If Left$(lpFindFileData.cFileName, 1) <> "." Then
lFolders = lFolders + 1
ReDim Preserve szFolder(lFolders)
szFolder(lFolders) = Left$(lpFindFileData.cFileName,
InStr(lpFindFileData.cFileName, Chr$(0)) - 1)
End If
End If
lResult = FindNextFile(hFindFile, lpFindFileData)
Loop Until lResult = False
lResult = FindClose(hFindFile)
End If
End If

FindFolders = lFolders
End Function

[/code]

Gruß

Klaus
 

Lesen sie die antworten

#1 Wolfgang Enzinger
11/05/2014 - 21:16 | Warnen spam
Hallo Klaus,

ich versuche gerade eine Verzeichnisstruktur als Baumsansicht im
Debug-Fenster auszugeben, was auch grundsàtzlich klappt.

Leider bekomme ich es überhaupt nicht gebacken, einige überflüssige
vertikale Treelines auszublenden. Ich hatte zwar zwischenzeitlich eine
Lösung gebastelt, die jedoch aus einer größeren Ansammlung Dirty Hacks
bestand. Deshalb habe ich noch einmal neu angesetzt.



ich habe etwas Schwierigkeiten, deinen Code zu verstehen, was wohl auch daran
liegt, dass Chr$(3), Chr$(6) und Chr$(25) beim mir nur als "Kàstchen"
dargestellt werden. Du verwendest im Debug-Fenster wohl einen anderen
Zeichensatz als ich. Wie auch immer, ich nehme an, dass du +, - und | damit
meinst.

Wenn ja: hier eine (etwas angepasste) Routine von mir, die das bewerkstelligt
und obendrein ohne Zwischenspeicherung auskommt, vielmehr wird das Layout "on
the fly" beim rekursiven Abfahren des Vezeichnisbaums erzeugt.

Schau mal, ob du das so gebrauchen kannst. Ggfs. müsstest du nur meine etwas
eigenwillige Einrückungstechnik zurechtbiegen ... ;-)

OK, hier der Code:

*************************************************************

Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
FTCreationTime As FILETIME
FTLastAccessTime As FILETIME
FTLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

*************************************************************

Sub Main()
PrintNode "T:\Desktop\", "", False
End Sub

*************************************************************

Public Sub PrintNode(ByVal Folder As String, ByVal Lines As String, _
ByVal HasNext As Boolean)
Dim hFindFile As Long
Dim lResult As Long
Dim FFD As WIN32_FIND_DATA
Dim s As String

If Right$(Folder, 1) <> "\" Then Folder = Folder & "\"

Debug.Print Lines & "+--" & Folder

hFindFile = FindFirstFile(Folder & "*.*", FFD)

If hFindFile > 0 Then
Do
s = AcceptableDirectoryName(FFD)
If LenB(s) Then
lResult = FindNextFile(hFindFile, FFD)
Do While lResult
If LenB(AcceptableDirectoryName(FFD)) Then
Exit Do
End If
lResult = FindNextFile(hFindFile, FFD)
Loop

PrintNode Folder & s, Lines & IIf(HasNext, "|", " ") & " ", _
CBool(lResult)

Else
lResult = FindNextFile(hFindFile, FFD)
End If
Loop While lResult
FindClose hFindFile
End If
End Sub

*************************************************************

Public Function AcceptableDirectoryName(FFD As WIN32_FIND_DATA) As String
Dim s As String
If FFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
s = Left$(FFD.cFileName, InStr(FFD.cFileName, vbNullChar) - 1)
Select Case s
Case ".", ".."
Case Else
AcceptableDirectoryName = s
End Select
End If
End Function

*************************************************************

Viele Grüsse,
Wolfgang
http://www.enzinger.net

Ähnliche fragen