type
PDateiRec = ^TDateiRec;
TDateiRec = packed record
_DateiName : WideString;
_FileName : TFileName;
_Erw0 : TFileName;
_Erw1 : TFileName;
_Pfad : string;
_Time : TDateTime;
_Attr : integer;
_Size : int64;
_CRC64Calc : int64;
end;
const
cUnicodeStr = ['?'];
C_P = '.';
C_PP = '..';
//------------------------------------------------------------------------------
function _StringToWideString(const S: AnsiString): WideString;
var
X : integer;
CodePage : word;
begin
CodePage := CP_ACP;
if S = ''
then Result := ''
else begin
X := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@S[1]), - 1, nil, 0);
SetLength(result, X - 1);
if X > 1 then MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@S[1]),- 1, PWideChar(@Result[1]), X - 1);
end;
end;
//------------------------------------------------------------------------------
function _WideStringToString(const WS: WideString): AnsiString;
var
X : integer;
CodePage : word;
begin
CodePage := CP_ACP;
{CP_ACP
ANSI code page
CP_MACCP Macintosh code page
CP_OEMCP OEM code page}
if WS = '' then result := ''
else begin
X := WideCharToMultiByte(codePage,WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
@WS[1], - 1, nil, 0, nil, nil);
SetLength(result, X - 1);
if X > 1 then WideCharToMultiByte(codePage,
WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,@WS[1], - 1, @result[1], X - 1, nil, nil);
end;
end; { WideStringToString }
//------------------------------------------------------------------------------
function _ReNameFile(const FromFile,ToFile:string;AHandle:THandle=0):boolean;
begin
result := _ShellFileOperation(FromFile,ToFile,FO_RENAME,FOF_NOCONFIRMATION or FOF_SILENT);
if not result and (AHandle <> 0) then SendMessage(AHandle,WM_SYSTEM_DATEI,longInt(@FromFile),14);
end;
//------------------------------------------------------------------------------
{Proceduren/Functionen-Anfang**************************************************}
{Damit können wir also die Dateien "windowsgemäß" löschen, die "fFlags" können folgendes
sein:
- FOF_ALLOWUNDO = läßt ein Rückgängigmachen, falls möglich zu
- FOF_NOWCONFIRMATION = Löschen ohne Bestätigungsfrage
- FOF_SIMPLEPROGRESS = mit Fortschritts-Dialogbox, allerdings ohne die Dateinamen anzuzeigen
_ FOF_SILENT = ohne Fortschritts-Dialogbox Mehrere Flags können mit OR kombiniert werden.}
//------------------------------------------------------------------------------
function _ShellFileOperation(const FromFile,ToFile: string; const Func,Flags: integer;AHandle:THandle=0):boolean;
var //uses Forms,ShellAPI
SHFileOpStruct: TSHFileOpStruct;
begin
Application.ProcessMessages;
with SHFileOpStruct do
begin
Wnd := Application.Handle;
wFunc := Func;
fFlags := Flags;// or FOF_NOERRORUI; //keine Fehlermeldung
pFrom := PChar(_ExBackSlash(FromFile)+#0+#0);
hNameMappings := nil;
lpszProgressTitle := nil;
if ToFile = ''
then pTo := nil
else pTo := PChar(ToFile+#0+#0);
// if ToFile = pFrom then exit;
// if pFrom ='' then exit;
end;
result := SHFileOperation(SHFileOpStruct) = 0;
if not result then SendMessage(AHandle,WM_SYSTEM_DATEI,longInt(@FromFile),15);
Application.ProcessMessages;
end;
//------------------------------------------------------------------------------
procedure TDrive.GetFiles(APfad,AMaske:string);
var
SR : TSearchRec;
HFind : THandle;
Directory : string;
SRW : WIN32_FIND_DATAW;
X :String;
begin
// X := 'C:\Temp\Test\*.*';
Directory:= ExtractFilePath(APfad);
try
HFind:=FindFirstFileW(PWideChar(_StringToWideString(APfad+AMaske)),SRW);
if HFind<>INVALID_HANDLE_VALUE then
begin
repeat
if SRW.dwFileAttributes and faDirectory <> faDirectory then FilesAdd(DateiRecList,Directory,SRW);
until FindNextFileW(HFind,SRW) <> true;
end;
except
end;
if not AMitDir then exit;
try
try
if FindFirst(Directory + '*.*',AAttrDir ,SR) = 0 then
begin
repeat
if ((SR.Attr and faDirectory) = faDirectory) and ((SR.Name[1] <> C_P) and (SR.Name[1] <> C_PP)) then
begin
SendMessage(
Handle,WM_READ_PFAD,0,DateiRecList.Count);
GetFiles(Directory+_BackSlash(SR.Name)+ExtractFileName(APfad),AMaske);
end;
until FindNext(SR) <> 0;
end;
except
end;
finally
SysUtils.FindClose(SR);
end;
end;
//------------------------------------------------------------------------------
function _UniCodeErkennen(var Value: string;Ch :TChOfSet):boolean;
var
I: integer;
begin
Result := false;
for I:=1 to length(Value) do
if Value[I] in Ch then
begin
Value[I] := '_';
Result := true;
end;
end;
//------------------------------------------------------------------------------
procedure TDrive.ClearRec(P:pointer);
begin
with PDateiRec(P)^ do
begin
_DateiName :=#0;
_FileName := '';
_Erw0 := '';
_Erw1 := '';
_Pfad := '';
_Time := 0;
_Attr := 0;
_Size := 0;
_CRC64Calc := 0;
end;
end;
//------------------------------------------------------------------------------
procedure TDrive.FilesAdd(TL:TList;Directory:string;SRW : WIN32_FIND_DATAW);
var//uses SysUtils,_Strings;
P : pointer;
FromFile : string;
ToFile : string;
begin
with SRW do
begin
P := new(PDateiRec);
with PDateiRec(P)^,SRW do
begin //_StringToWideString
ClearRec(P);
if dwFileAttributes and faDirectory <> faDirectory then _DateiName := cFileName;
ToFile := _WideStringToString(_DateiName);
_Pfad := Directory;
if _UniCodeErkennen(ToFile,cUnicodeStr) then
begin
{$I+}
// Dispose(P);
{$I-}
// exit; //Noch keine Lösung für das Problem
FromFile := _Pfad+_WideStringToString(_DateiName);
ToFile := _Pfad+ToFile;
_ReNameFile(FromFile,ToFile)
end;
_FileName := _WideStringToString(_DateiName);
_Erw0 := _ExtractFileExtOhnePunkt(_FileName);
_Erw1 := ExtractFileExt(_FileName);
_FileName := ChangeFileExt(_FileName,'');
_Pfad := Directory;
_Time := _FileTimeToDateTime(ftCreationTime);//TFileTime
_Attr := dwFileAttributes;
_Size := nFileSizeHigh shl 32 or nFileSizeLow;
end;
end;
TL.Add(P);
end;