Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!Code-Beispiel
Ordnerinhalte vergleichen
| Lizenz: | Erster Autor: | Letzte Bearbeitung: |
| k. A. |  hhr |  23.06.2020 |
Für die Suchfunktion wird ein iteratives Verfahren verwendet:
- Alle gefundenen Ordnerpfade werden dem Ordnerarray (aFolder) hinzugefügt.
- Alle im Ordnerarray gespeicherten Ordnerpfade werden nacheinander durchsucht.
Bezüglich der Verarbeitungszeit scheint 2^16 im Makro comparefiles ein brauchbarer Kompromiss zu sein.
Im Temp-Ordner mögen Rückstände verbleiben, was sich mit der FreeBasic-Zeile
shell "explorer %TEMP%"
überprüfen lässt.
https://www.freebasic-portal.de/code-beispiele/dateien-laufwerke/durchsuchen-von-dateien-rekursiv-283.html
https://www.freebasic-portal.de/tutorials/iteration-rekursion-43.html
https://www.freebasic-portal.de/code-beispiele/dateien-laufwerke/dateidatum-unter-win-lesen-setzen-95.html
https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-getfiletime
Function scanfolder(path As String, afolder() As String, afile() As String) As Long
If Len(path) = 3 Then Return 1 ' Main directory.
If Len(Dir(path, &hFF)) = 0 Then Return 2 ' Path not found.
Redim afile(0), afolder(0) ' a: array
Dim As Ulong attribute, inextfolder ' i: index
Dim As String getname
Dir(path, &hFF, attribute)
If Bit(attribute, 4) Then ' Folder
afolder(0) = path
Do
afolder(0) = afolder(inextfolder) & "\"
getname = Dir(afolder(0) & "*", &hFF, attribute)
While Len(getname)
If Bit(attribute, 4) Then ' Folder
If Not((getname = ".") Or (getname = "..")) Then
Redim Preserve afolder(Ubound(afolder) + 1)
afolder(Ubound(afolder)) = afolder(0) & getname
End If
Else ' File
Redim Preserve afile(Ubound(afile) + 1)
afile(Ubound(afile)) = afolder(0) & getname
End If
getname = Dir("", &hFF, attribute)
Wend
inextfolder += 1
Loop Until inextfolder > Ubound(afolder)
Function = 4 ' Folder
Else ' File
Redim afile(1)
afile(1) = path
Function = 8 ' File
End If
End Function
#include once "windows.bi" ' Messagebox, Sendmessage
#include once "win/shlobj.bi" ' BrowseForFolder
#include once "vbcompat.bi" ' Filedatetime
Function BrowseForFolder(Title As String) As String
Dim As String*MAX_PATH path
Dim As BROWSEINFO lpbi
With lpbi
.lpszTitle = Strptr(Title)
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES
End With
SHGetPathFromIDList(SHBrowseForFolder(@lpbi), path)
Function = path
End Function
Dim As String path1 = Command(1)
Dim As String path2 = Command(2)
If Len(path1) = 0 And Len(path2) = 0 Then
Do
path1 = BrowseForFolder("Select file or folder.")
If Len(path1) = 0 Then End
path2 = BrowseForFolder("Select second file or folder.")
If Len(path2) = 0 Then End
Select Case Messagebox(0, path1 & !"\n\n" & path2, "comparetest", MB_CANCELTRYCONTINUE)
Case IDCANCEL
End
Case IDCONTINUE
Exit Do
End Select
Loop
End If
Dim As String afolder1(), afile1()
Dim As String afolder2(), afile2()
Dim As Long result1 = scanfolder(path1, afolder1(), afile1())
Dim As Long result2 = scanfolder(path2, afolder2(), afile2())
#Macro getbasicinformation
text = path1
text &= CRLF
If result1 = 2 Then
text &= "Path not found."
Elseif result1 = 1 Then
text &= "Main directory."
Else
text &= "Files: " & Str(Ubound(afile1))
If result1 = 4 Then
text &= CRLF
text &= "Folders: " & Str(Ubound(afolder1))
End If
End If
text &= CRLF
text &= CRLF
text &= path2
text &= CRLF
If result2 = 2 Then
text &= "Path not found."
Elseif result2 = 1 Then
text &= "Main directory."
Else
text &= "Files: " & Str(Ubound(afile2))
If result2 = 4 Then
text &= CRLF
text &= "Folders: " & Str(Ubound(afolder2))
End If
End If
#EndMacro
#Macro getsamefilenames
Redim samefilenames1(0)
Redim samefilenames2(0)
If Ubound(afile1) < Ubound(afile2) Then
For i = 1 To Ubound(afile1)
s = path2 & Right(afile1(i), Len(afile1(i)) - Len(path1))
If Len(Dir(s, &hFF)) Then
Redim Preserve samefilenames1(Ubound(samefilenames1) + 1)
samefilenames1(Ubound(samefilenames1)) = afile1(i)
Redim Preserve samefilenames2(Ubound(samefilenames2) + 1)
samefilenames2(Ubound(samefilenames2)) = s
End If
Next i
Else
For i = 1 To Ubound(afile2)
s = path1 & Right(afile2(i), Len(afile2(i)) - Len(path2))
If Len(Dir(s, &hFF)) Then
Redim Preserve samefilenames1(Ubound(samefilenames1) + 1)
samefilenames1(Ubound(samefilenames1)) = s
Redim Preserve samefilenames2(Ubound(samefilenames2) + 1)
samefilenames2(Ubound(samefilenames2)) = afile2(i)
End If
Next i
End If
If Ubound(samefilenames1) = 0 Then
text &= CRLF
text &= CRLF
text &= "Matched filenames: 0"
End If
#EndMacro
#Macro comparefiles
Const As Ulong c = 2^16
Dim As String sample1, sample2
sample1 = Space(c)
sample2 = Space(c)
k = Ubound(samefilenames1)
For i = 1 To Ubound(samefilenames1)
Open samefilenames1(i) For Binary As #1
Open samefilenames2(i) For Binary As #2
If Lof(1) <> Lof(2) Then
text &= CRLF
text &= CRLF
text &= "Size mismatch:" & CRLF & samefilenames1(i) & CRLF & samefilenames2(i)
k -= 1
Else
Do Until Eof(1)
Get #1,,sample1
Get #2,,sample2
If sample1 <> sample2 Then
text &= CRLF
text &= CRLF
text &= "Data mismatch:" & CRLF & samefilenames1(i) & CRLF & samefilenames2(i)
k -= 1
Exit Do
End If
Loop
End If
Close
Next i
text &= CRLF
text &= CRLF
text &= "Matched files: " & Str(k)
#EndMacro
#Macro getmissingfolders
k = 1
For i = 1 To Ubound(afolder2)
s = path1 & Right(afolder2(i), Len(afolder2(i)) - Len(path2))
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing folder: " & s
End If
Next i
k = 1
For i = 1 To Ubound(afolder1)
s = path2 & Right(afolder1(i), Len(afolder1(i)) - Len(path1))
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing folder: " & s
End If
Next i
#EndMacro
#Macro getmissingfiles
k = 1
For i = 1 To Ubound(afile2)
s = path1 & Right(afile2(i), Len(afile2(i)) - Len(path2))
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing file: " & s
End If
Next i
k = 1
For i = 1 To Ubound(afile1)
s = path2 & Right(afile1(i), Len(afile1(i)) - Len(path1))
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing file: " & s
End If
Next i
#EndMacro
Dim As String samefilenames1(), samefilenames2()
Dim As String s, text, CRLF = Chr(13, 10) ' !"\r\n"
Dim As Ulong i, k
Dim As Ulong attribute1, attribute2
getbasicinformation
If result1 + result2 = 12 Then
text &= CRLF
text &= CRLF
text &= "Parameter mismatch."
Else
If Ubound(afile1) > 0 And Ubound(afile2) > 0 Then
getsamefilenames
If Ubound(samefilenames1) > 0 Then
comparefiles
getmissingfolders
getmissingfiles
End If
End If
End If
#Macro SendTextToNotepad
s = Environ("temp") & "\comparetest"
Dim As String textpath = s & ".txt"
i = 1
While Len(Dir(textpath, &hFF)) > 0
i += 1
textpath = s & "(" & Str(i) & ").txt"
Wend
Open textpath For Output As #1
Print #1, text
Close #1
Exec(Environ("windir") & "\System32\notepad.exe", textpath)
Kill(textpath)
#EndMacro
SendTextToNotepad
End
'
Auf der Seite
https://www.freebasic.net/forum/viewtopic.php?f=2&t=21639
findet man ein Programm, das Text an den Editor sendet, ohne den Umweg über den Temp-Ordner zu machen:
Re: Sendmessage, Zippy » Oct 02, 2013 11:38
Das folgende Makro ist davon abgeleitet und kann anstelle des oben angegebenen Makros eingefügt werden.
#Macro SendTextToNotepad
Dim As Long result
Dim As String CommandLine
Dim As HANDLE edit, hWnd
Dim As STARTUPINFO si
Dim As PROCESS_INFORMATION pi
Declare Function Get_hWnd(pid As Long) As hWnd
CommandLine = "notepad.exe" 'may need complete path
result = CreateProcess(NULL, CommandLine, NULL, NULL, NULL, NULL, NULL, NULL, @si, @pi)
If result = 0 Then Messagebox(0, "Failed to start Notepad.", "", MB_OK) : End
'wait for process initialization
result = WaitForInputIdle(pi.hProcess, 2000) 'error if result <> 0
'get notepad's hWnd from process id
hWnd = Get_hWnd(pi.dwProcessId) 'error if hWnd = 0
'get notepad's "Edit" window hWnd
edit = FindWindowEx(hWnd, Null, "Edit", Null) 'error if edit = 0
'send text
result = SendMessage(edit, WM_SETTEXT, Null, Cast(LPARAM, Strptr(text))) 'error if result <> 1
Function Get_hWnd(pid As Long) As hWnd
Dim As Long ProcID
Dim As HWND hWnd
hWnd = FindWindow(NULL, NULL)
Do While hWnd > 0
If GetParent(hwnd) = 0 Then
GetWindowThreadProcessId(hWnd, @ProcID)
If ProcID = pid Then
Return hWnd
End If
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop
Return 0
End Function
#EndMacro
Die Funktion scanfolder kann absolute oder relative Pfade ausgeben.
Dafür sind drei Zeilen zu ändern:
Function scanfolder(path As String, afolder() As String, afile() As String) As Long
If Len(path) = 3 Then Return 1 ' Main directory.
If Len(Dir(path, &hFF)) = 0 Then Return 2 ' Path not found.
' Absolute path: mode = true
' Relative path: mode = false
Dim As boolean mode = true
Redim afile(0), afolder(0) ' a: array
Dim As Ulong attribute, inextfolder ' i: index
Dim As String getname
Dir(path, &hFF, attribute)
If Bit(attribute, 4) Then ' Folder
If mode = true Then
afolder(0) = path ' Absolute path
Else
afolder(0) = "" ' Relative path
End If
Do
afolder(0) = afolder(inextfolder) & "\"
If mode = true Then
getname = Dir(afolder(0) & "*", &hFF, attribute) ' Absolute path
Else
getname = Dir(path & afolder(0) & "*", &hFF, attribute) ' Relative path
End If
While Len(getname)
If Bit(attribute, 4) Then ' Folder
If Not((getname = ".") Or (getname = "..")) Then
Redim Preserve afolder(Ubound(afolder) + 1)
afolder(Ubound(afolder)) = afolder(0) & getname
End If
Else ' File
Redim Preserve afile(Ubound(afile) + 1)
afile(Ubound(afile)) = afolder(0) & getname
End If
getname = Dir("", &hFF, attribute)
Wend
inextfolder += 1
Loop Until inextfolder > Ubound(afolder)
Function = 4 ' Folder
Else ' File
Redim afile(1)
If mode = true Then
afile(1) = path ' Absolute path
Else
afile(1) = "" ' Relative path
End If
Function = 8 ' File
End If
End Function
#include "windows.bi" ' OemToCharBuff
Dim As String path
Dim As String afolder(), afile()
Dim As Long result
Do
Input "Paste folder path: ", path
path = Rtrim(path)
If Len(path) = 0 Then End
OemToCharBuff(path, path, Len(path)) ' AsciiToAnsi
result = scanfolder(path, afolder(), afile())
Loop Until result > 2
Print Wstr(path)
Print "Files:"; Ubound(afile)
Print "Folders:"; Ubound(afolder)
Print "-- More --" : Sleep
Dim As Ulong i
For i = 1 To Ubound(afolder)
Print i; " Folder: "; Wstr(afolder(i))
Next i
For i = 1 To Ubound(afile)
Print i; " File: "; Wstr(afile(i))
Next i
Sleep
End
'
Das folgende Programm verwendet relative Pfade:
Function scanfolder(path As String, afolder() As String, afile() As String) As Long
If Len(path) = 3 Then Return 1 ' Main directory.
If Len(Dir(path, &hFF)) = 0 Then Return 2 ' Path not found.
Redim afile(0), afolder(0) ' a: array
Dim As Ulong attribute, inextfolder ' i: index
Dim As String getname
Dir(path, &hFF, attribute)
If Bit(attribute, 4) Then ' Folder
Do
afolder(0) = afolder(inextfolder) & "\"
getname = Dir(path & afolder(0) & "*", &hFF, attribute)
While Len(getname)
If Bit(attribute, 4) Then ' Folder
If Not((getname = ".") Or (getname = "..")) Then
Redim Preserve afolder(Ubound(afolder) + 1)
afolder(Ubound(afolder)) = afolder(0) & getname
End If
Else ' File
Redim Preserve afile(Ubound(afile) + 1)
afile(Ubound(afile)) = afolder(0) & getname
End If
getname = Dir("", &hFF, attribute)
Wend
inextfolder += 1
Loop Until inextfolder > Ubound(afolder)
Function = 4 ' Folder
Else ' File
Redim afile(1)
Function = 8 ' File
End If
End Function
#include once "windows.bi" ' Messagebox, Sendmessage
#include once "win/shlobj.bi" ' BrowseForFolder
#include once "vbcompat.bi" ' Filedatetime, Filelen
Function BrowseForFolder(Title As String) As String
Dim As String*MAX_PATH path
Dim As BROWSEINFO lpbi
With lpbi
.lpszTitle = Strptr(Title)
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES
End With
SHGetPathFromIDList(SHBrowseForFolder(@lpbi), path)
Function = path
End Function
Dim As String path1 = Command(1)
Dim As String path2 = Command(2)
If (Len(path1) = 0) And (Len(path2) = 0) Then
Do
path1 = BrowseForFolder("Select first file or folder.")
If Len(path1) = 0 Then End
path2 = BrowseForFolder("Select second file or folder.")
If Len(path2) = 0 Then End
Select Case Messagebox(0, path1 & !"\n\n" & path2, "comparetest", MB_CANCELTRYCONTINUE)
Case IDCANCEL
End
Case IDCONTINUE
Exit Do
End Select
Loop
End If
Dim As String afolder1(), afile1()
Dim As String afolder2(), afile2()
Dim As Long result1 = scanfolder(path1, afolder1(), afile1())
Dim As Long result2 = scanfolder(path2, afolder2(), afile2())
#Macro getbasicinformation
text = path1
text &= CRLF
If result1 = 2 Then
text &= "Path not found."
Elseif result1 = 1 Then
text &= "Main directory."
Else
text &= "Files: " & Str(Ubound(afile1))
If result1 = 4 Then
text &= CRLF
text &= "Folders: " & Str(Ubound(afolder1))
End If
End If
text &= CRLF & CRLF
text &= path2
text &= CRLF
If result2 = 2 Then
text &= "Path not found."
Elseif result2 = 1 Then
text &= "Main directory."
Else
text &= "Files: " & Str(Ubound(afile2))
If result2 = 4 Then
text &= CRLF
text &= "Folders: " & Str(Ubound(afolder2))
End If
End If
#EndMacro
#Macro getsamefilenames
Dim As String samefilenames()
Redim samefilenames(0)
If Ubound(afile1) < Ubound(afile2) Then
For i = 1 To Ubound(afile1)
If Len(Dir(path2 & afile1(i), &hFF)) Then
Redim Preserve samefilenames(Ubound(samefilenames) + 1)
samefilenames(Ubound(samefilenames)) = afile1(i)
End If
Next i
Else
For i = 1 To Ubound(afile2)
If Len(Dir(path1 & afile2(i), &hFF)) Then
Redim Preserve samefilenames(Ubound(samefilenames) + 1)
samefilenames(Ubound(samefilenames)) = afile2(i)
End If
Next i
End If
If Ubound(samefilenames) = 0 Then
text &= CRLF & CRLF
text &= "Matched filenames: 0"
End If
#EndMacro
#Macro comparefiles
Const As Ulong c = 2^16
Dim As String sample1, sample2, s1, s2
sample1 = Space(c)
sample2 = Space(c)
k = Ubound(samefilenames)
For i = 1 To Ubound(samefilenames)
s1 = path1 & samefilenames(i)
s2 = path2 & samefilenames(i)
'Print CRLF & "Comparing" & CRLF & Wstr(s1) & CRLF & "and" & CRLF & Wstr(s2)
j = k
If Filelen(s1) <> Filelen(s2) Then
text &= CRLF & CRLF
text &= "Size mismatch:" & CRLF & s1 & CRLF & s2
k -= 1
Else
Open s1 For Binary As #1
Open s2 For Binary As #2
Do Until Eof(1)
Get #1,,sample1
Get #2,,sample2
If sample1 <> sample2 Then
text &= CRLF & CRLF
text &= "Data mismatch:" & CRLF & s1 & CRLF & s2
k -= 1
Exit Do
End If
Loop
Close
End If
If j = k Then ' Files are equal
If Abs(Filedatetime(s1) - Filedatetime(s2)) > 3e-5 Then ' 2.6s
textFiledatetime &= CRLF & CRLF
textFiledatetime &= "LastWriteTime mismatch:" & CRLF & s1 & CRLF & s2
End If
Dir(s1, &hFF, attribute1)
Dir(s2, &hFF, attribute2)
If attribute1 <> attribute2 Then
textAttributemismatch &= CRLF & CRLF
textAttributemismatch &= "Attribute mismatch:" & CRLF & s1 & CRLF & s2
textAttributemismatch &= CRLF & Bin(attribute1, 8) & CRLF & Bin(attribute2, 8)
End If
'textEqualfiles &= CRLF & CRLF & "Equal files:" & CRLF & s1 & CRLF & s2
End If
'Print i & " of " & Ubound(samefilenames) & " files compared"
Next i
text &= CRLF & CRLF
text &= "Matched files: " & Str(k)
#EndMacro
#Macro getmissingfolders
k = 1
For i = 1 To Ubound(afolder2)
s = path1 & afolder2(i)
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing folder: " & s
End If
Next i
k = 1
For i = 1 To Ubound(afolder1)
s = path2 & afolder1(i)
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing folder: " & s
End If
Next i
#EndMacro
#Macro getmissingfiles
k = 1
For i = 1 To Ubound(afile2)
s = path1 & afile2(i)
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing file: " & s
End If
Next i
k = 1
For i = 1 To Ubound(afile1)
s = path2 & afile1(i)
If Len(Dir(s, &hFF)) = 0 Then
If k = 1 Then text &= CRLF : k = 0
text &= CRLF
text &= "Missing file: " & s
End If
Next i
#EndMacro
Dim As String s, text, CRLF = Chr(13, 10) ' !"\r\n"
Dim As String textFiledatetime, textAttributemismatch, textEqualfiles
Dim As Ulong i, j, k
Dim As Ulong attribute1, attribute2
getbasicinformation
If result1 + result2 = 12 Then
text &= CRLF
text &= CRLF
text &= "Parameter mismatch."
Else
If (Ubound(afile1) > 0) And (Ubound(afile2) > 0) Then
getsamefilenames
If Ubound(samefilenames) > 0 Then
comparefiles
getmissingfolders
getmissingfiles
End If
End If
End If
If Len(textFiledatetime) > 0 Then
text &= CRLF & CRLF & "============="
text &= textFiledatetime
End If
If Len(textAttributemismatch) > 0 Then
text &= CRLF & CRLF & "============="
text &= textAttributemismatch
End If
If Len(textEqualfiles) > 0 Then
text &= CRLF & CRLF & "============="
text &= textEqualfiles
End If
text &= CRLF & CRLF & "============="
#Macro SendTextToNotepad
s = Environ("temp") & "\comparetest"
Dim As String textpath = s & ".txt"
i = 1
While Len(Dir(textpath, &hFF)) > 0
i += 1
textpath = s & "(" & Str(i) & ").txt"
Wend
Open textpath For Output As #1
Print #1, text
Close #1
s = "start notepad /A " & textpath
Shell(s)
Sleep 2000
s = "del " & textpath
Shell(s)
#EndMacro
SendTextToNotepad
End
'Das Makro SendTextToNotepad ist hier noch einmal geändert worden.
| Zusätzliche Informationen und Funktionen | |||||||
|---|---|---|---|---|---|---|---|
|
|||||||
Bearbeiten
Versionen