Aus Wikibooks
[Bearbeiten] CheckPathLength Beispiel
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmWait
Caption = "##"
ClientHeight = 915
ClientLeft = 120
ClientTop = 1170
ClientWidth = 9075
ControlBox = 0 'False
Icon = "frmWait.frx":0000
LinkTopic = "Form1"
ScaleHeight = 915
ScaleWidth = 9075
Begin MSComDlg.CommonDialog dlgFile
Left = 5940
Top = 60
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label lblWait
Caption = "##"
Height = 765
Left = 90
TabIndex = 0
Top = 60
Width = 8880
End
End
Attribute VB_Name = "frmWait"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
Me.Move 100, 100
End Sub
Private Sub Form_Resize()
If Me.Width < 4000 Or Me.Height < 1000 Then Exit Sub
lblWait.Width = Me.ScaleWidth - 200
lblWait.Height = Me.ScaleHeight - 200
End Sub
Attribute VB_Name = "basMain"
Option Explicit
' Win32 API Deklaration (Ordner auswählen)
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Public Const MAX_PATH As Long = 260
Public Type BROWSEINFO
hOwner As Long ' Form.hwnd
pidlRoot As Long ' = 0
pszDisplayName As String ' Verzeichnis Rückgabe (MAX_PATH)
lpszTitle As String ' Beschreibung im Dialog
ulFlags As Long ' = 0
lpfn As Long ' = 0
lParam As Long ' = 0
iImage As Long ' = 0
End Type
Public intMaxCharsInPath As Integer
Public dblFehler As Double
Sub main()
Dim strSearchFolder As String
Dim strExportFile As String
Dim intDatei As Integer
Dim strMSG As String
Load frmWait
With frmWait
.Caption = "Initialisierung"
.lblWait.Caption = "Variable werden vom Benutzer abgefragt..."
.Show vbModeless
End With
' Suchpfad vom Benutzer erfragen
strMSG = "Bitte geben Sie den zu durchsuchenden Pfad ein"
If GetFolder(strSearchFolder, strMSG) = False Then
MsgBox "Ohne Suchpfad kann das Programm nicht fortgesetzt werden.", _
vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
If strSearchFolder = "" Then
MsgBox "Ohne Suchpfad kann das Programm nicht fortgesetzt werden.", _
vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
frmWait.lblWait.Caption = frmWait.lblWait.Caption & vbCrLf & "Pfad: " & strSearchFolder
frmWait.Refresh
' Alarmlänge vom Benutzer erfragen
strExportFile = InputBox("Geben Sie die Länge des Pfades an bei dem eine Ausgabe " & _
"in die Ergebnisdatei erfolgen soll", "Alarm Pfadlänge eingeben", "235")
If strExportFile = "" Then
MsgBox "Ohne Angabe der ""Alarmlänge"" kann das Programm nicht fortgesetzt _
werden.", vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
ElseIf IsNumeric(strExportFile) = False Then
MsgBox "Es wurde keine Zahl eingegeben. Ohne Angabe der ""Alarmlänge"" kann _
das Programm nicht fortgesetzt werden.", _
vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
On Error Resume Next
intMaxCharsInPath = CInt(strExportFile)
If Err.Number <> 0 Then
MsgBox "Die angegebene Zahl ist ungültig. Ohne Angabe der ""Alarmlänge"" kann _
das Programm nicht fortgesetzt werden.", _
vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
On Error GoTo 0
If intMaxCharsInPath < 1 Or intMaxCharsInPath > 255 Then
MsgBox "Die angegebene Zahl ist ungültig. Ohne Angabe der ""Alarmlänge"" kann _
das Programm nicht fortgesetzt werden.", _
vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
frmWait.lblWait.Caption = frmWait.lblWait.Caption & vbCrLf & "Alarmlänge: " & strExportFile
frmWait.Refresh
' Dateinamen für Ergebnisdatei vom Benutzer erfragen
strExportFile = ""
If GetExportFile(strExportFile) = False Then
MsgBox "Ohne Angabe einer Ergebnisdatei kann das Programm nicht fortgesetzt _
werden.", vbInformation + vbOKOnly, "Abbruch"
Unload frmWait
Exit Sub
End If
frmWait.Caption = "Durchsuche Dateibaum, bitte warten..."
frmWait.lblWait.Caption = ""
frmWait.Refresh
' Ergebnisdatei öffnen
intDatei = FreeFile
Open strExportFile For Output As #intDatei
' Dateikopf schreiben
strMSG = String(79, "-")
Print #intDatei, strMSG
strMSG = App.ProductName & " Version " & App.Major & "." & App.Minor & "." & App.Revision & " "
strMSG = strMSG & String(54 - Len(strMSG), " ") & App.LegalCopyright
Print #intDatei, strMSG
strMSG = "CPL gestartet am " & Format(Date, "dd.mm.yyyy") & " um " & _
Format(Time, "HH:mm") & " Uhr."
Print #intDatei, strMSG
strMSG = String(79, "-")
Print #intDatei, strMSG
' Suchfunktion aufrufen (ruft sich rekursiv immer wieder selbst auf)
dblFehler = 0
SearchTree strSearchFolder, intDatei
' Fehleranzahl in Datei schreiben
strMSG = "Es wurden " & CStr(dblFehler) & " Fehler nach eingegebener Definition festgestellt."
strSearchFolder = vbCrLf & String(79, "-") & vbCrLf & strMSG
Print #intDatei, strSearchFolder
' Ergebnisdatei schliessen, Ergebnis ausgeben und Formular entladen
Close #intDatei
frmWait.Caption = "Vorgang abgeschlossen"
frmWait.lblWait.Caption = strMSG
frmWait.Refresh
MsgBox strMSG, vbInformation + vbOKOnly, "Ergebnis"
Unload frmWait
End Sub
Private Function GetExportFile(ByRef File As String) As Boolean
Dim DLG As CommonDialog
GetExportFile = False
Set DLG = frmWait.dlgFile
With DLG
.CancelError = True
.DialogTitle = "Ergebnis speichern unter..."
.Filter = "Textdateien|*.txt|Alle Dateien|*.*"
.FilterIndex = 1
.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt + cdlOFNPathMustExist
On Error Resume Next
.ShowSave
If Err.Number <> 0 Then Exit Function
On Error GoTo 0
File = .FileName
End With
Set DLG = Nothing
GetExportFile = True
End Function
Private Function GetFolder(ByRef Folder As String, ByVal MSG As String) As Boolean
Dim BI As BROWSEINFO
Dim strPfad As String
Dim lngReturnFolder As Long
Dim lngReturnPath As Long
GetFolder = False
BI.hOwner = frmWait.hWnd
BI.iImage = 0
BI.lParam = 0
BI.lpfn = 0
BI.pidlRoot = 0
BI.ulFlags = 0
BI.lpszTitle = MSG
BI.pszDisplayName = String(MAX_PATH, 0)
lngReturnFolder = SHBrowseForFolder(BI)
If lngReturnFolder = 0 Then Exit Function
strPfad = String(MAX_PATH, 0)
lngReturnPath = SHGetPathFromIDList(lngReturnFolder, strPfad)
Folder = Left(strPfad, InStr(strPfad, vbNullChar) - 1)
GetFolder = True
End Function
Private Sub SearchTree(ByRef sPath As String, ByVal FileNumber As Integer)
Dim colDirs As New Collection
Dim strDir As String
Dim varDir As Variant
Dim intPathlenght As Integer
Dim lngDirectory As Long
Dim strZeile As String
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
intPathlenght = Len(sPath)
On Error Resume Next
If Len(Dir(sPath & "*.*", vbArchive + vbDirectory + vbHidden + vbNormal + _
vbReadOnly + vbSystem)) = 0 Then
strZeile = "# Fehler # Verzeichnis konnte nicht gefunden oder geöffnet _
werden: " & sPath & vbCrLf
Print #FileNumber, strZeile
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
frmWait.lblWait.Caption = sPath
frmWait.lblWait.Refresh
strDir = Dir(sPath & "*.*", vbArchive + vbDirectory + vbHidden + vbNormal + _
vbReadOnly + vbSystem)
Do Until Len(strDir) = 0
DoEvents
If strDir <> "." And strDir <> ".." Then
On Error Resume Next
lngDirectory = (GetAttr(sPath & strDir) And vbDirectory)
If Err.Number = 0 Then
If lngDirectory <> 0 Then
varDir = sPath & strDir & "\"
colDirs.Add varDir
Else
If intMaxCharsInPath - 1 < Len(sPath & strDir) Then
strZeile = sPath & strDir & vbCrLf & Len(sPath & strDir) & vbCrLf
Print #FileNumber, strZeile
dblFehler = dblFehler + 1
End If
End If
Else
'MsgBox "Fehler bei Attributprüfung: " & Err.Number & vbCrLf _
& "Beschreibung: " & Err.Description & vbCrLf & vbCrLf _
& "Verzeichnis: " & sPath & vbCrLf & "Datei/Verzeichnis: " & strDir
strZeile = sPath & strDir & vbCrLf & Len(sPath & strDir) & vbCrLf
Print #FileNumber, strZeile
dblFehler = dblFehler + 1
End If
Err.Clear
On Error GoTo 0
End If
strDir = Dir()
Loop
For Each varDir In colDirs
DoEvents
strDir = varDir
SearchTree strDir, FileNumber
Next varDir
End Sub
[Bearbeiten] CheckPathLength.vbp
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINNT\System32\Stdole2.tlb#OLE Automation
Module=basMain; basMain.bas
Form=frmWait.frm
Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0; comdlg32.ocx
IconForm="frmWait"
Startup="Sub Main"
HelpFile=""
Title="CheckPathLength"
ExeName32="CPL.exe"
Command32=""
Name="CheckPathLength"
HelpContextID="0"
Description="Prüft die Länge von Dateipfaden"
CompatibleMode="0"
MajorVer=1
MinorVer=1
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionComments="Prüft die Länge von Dateipfaden"
VersionCompanyName=""
VersionFileDescription="Prüft die Länge von Dateipfaden"
VersionLegalCopyright=""
VersionLegalTrademarks=""
VersionProductName="Check Path Length"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
