Удаление папки с файлами

[newerow1989]

Здравствуйте!

Поможете мне устранить такой баг?

У меня в папке "E:\tmp" имеется множество файлов и папок. Мне нужно удалить полностью всю папку.
Вот код:

type TArrayString = array of string;

procedure DirList(Dir: string; var DirArr: TArrayString; Over: byte = 0);
var F: TSearchRec;
begin
   ChDir(Dir);
   if Over=0 then
      SetLength(DirArr, 0);
   SetLength(DirArr, Length(DirArr)+1);
   DirArr[Length(DirArr)-1]:=Dir;
   if Dir[Length(Dir)]<>'\' then
      Dir:=Dir+'\';
   if FindFirst('*', faAnyFile, F)=0 then
   repeat
      if F.Attr and faDirectory <> faDirectory then
         DeleteFile(Dir+F.Name);
   until FindNext(F)<>0;
   if FindFirst('*', faAnyFile, F)=0 then
   repeat
      if F.Attr and faDirectory = faDirectory then
         if not (F.Name='.') and not (F.Name='..') then
         begin
            DirList(Dir+F.Name, DirArr, 1);
            ChDir(Dir);
         end;
   until FindNext(F)<>0;
   FindClose(F);
   if Over=0 then
      ChDir('C:\');
end;

procedure TForm1.Button1Click(Sender: TObject);
var DirArr: TArrayString;
    i: integer;
begin
   DirList('E:\tmp', DirArr);
   for i:=High(DirArr) downto Low(DirArr) do
      RemoveDir(DirArr[i]);
end;

Проблема заключается в том, что программа удаляет папки с ошибками (см. скриншот).
Подробнее: при нажатии на кнопку папка физически не удаляется (она остается), но зайти в нее не получается. Однако, при закрытии программы она автоматически удаляется.

В связи с этим вопрос: как удалить папку с файлами полностью без закрытия приложения?

[NetSpace]

я удаляю так

//----- удаляем файлы в заданной папке -----------------------------------------
procedure DelFile(FullName:string);
var SHFP:SHFILEOPSTRUCT;
begin
   Windows.SetFileAttributes(PChar(FullName),0);//снимаем с него все атрибуты
   ZeroMemory(@SHFP,SizeOf(SHFP));
   with SHFP do
   begin
      wFunc:=FO_DELETE;
      pFrom:=pChar(FullName);
      fFlags:=FOF_NOCONFIRMATION;//втихаря скрытно удаляем
   end;
   SHFileOperation(SHFP);
end;

попробуй вместо файла поставить папку. вдруг сработает.

[newerow1989]

Спасибо! Работает!

[сфинкс]

Ваша программа синтезирует QR код
и сохраняет только BMP?

1,5 МБ http://newerow1989.ru/my_program/qrcode/QRCode.rar

http://newerow1989.ru/publ/algoritm_...koda/7-1-0-107

Недостаток: qr код без белого поля вокруг
иногда на тёмном фоне не распознаётся
и нужно белое поле вокруг qr кода

Например есть интернет страницы
синтезирующие и сохраняющие qr код
и там белое поле вокруг и всё распознаётся

Также хорошо бы синтезировать qr визитки
сразу в смартфонные контакты
как умеют некоторые сайты

[newerow1989]

NetSpace, все-таки появляется ошибка, при условии, что если предварительно поработать с файлами в папке.

сфинкс, спасибо за информацию. Это всего лишь бэта-версия. Цель данной программы - подробное формирование QR-кода, как образуются квадратики.
В дальнейшем планируется доработка программы.

[NetSpace]

замечал, что чаще всего до последнего висят в папке исполняемые файлы... но потом всё же удаляются... не знаю, это баг системы или всё же стандартная задержка, пока что-то где-то закроется или выгрузится...

[NetSpace]

попробуй-ка скомпилировать этот код, но в конце кода число 9752 (байт) встречается 2 раза - это проверка на то, чтоб программа сама себя не пыталась удалить. после компиляции посмотри размер, запиши его в программу и снова скомпилируй.
-----------
протестировал в папке, где образ Линукса на 8 Гб и куча папок с программами и прочей шелухой офисной - всё улетает за раз!

program ADAPI;
{$R dialog.res}
type
_SECURITY_ATTRIBUTES=record
   nLength:LongWord;
   lpSecurityDescriptor:Pointer;
   bInheritHandle:LongBool;
end;
PSecurityAttributes=^TSecurityAttributes;
TSecurityAttributes=_SECURITY_ATTRIBUTES;

_SHFILEOPSTRUCTA=record
   Wnd:LongWord;
   wFunc:LongWord;
   pFrom:PAnsiChar;
   pTo:PAnsiChar;
   fFlags:Word;
   fAnyOperationsAborted:LongBool;
   hNameMappings:Pointer;
   lpszProgressTitle:PAnsiChar;
end;
TSHFileOpStructA=_SHFILEOPSTRUCTA;
SHFILEOPSTRUCTA=_SHFILEOPSTRUCTA;
SHFILEOPSTRUCT = SHFILEOPSTRUCTA;

TSysLocale=record
   DefaultLCID:LongWord;
   PriLangID:Word;
   SubLangID:Word;
   FarEast:Boolean;
   MiddleEast:Boolean;
end;
TMbcsByteType=(mbSingleByte,mbLeadByte,mbTrailByte);
LongRec=record
   Lo,Hi:Word;
end;
TfileTime=record
   dwLowDateTime:LongWord;
   dwHighDateTime:LongWord;
end;
WIN32_FIND_DATAA=record
   dwFileAttributes:LongWord;
   ftCreationTime:TFileTime;
   ftLastAccessTime:TFileTime;
   ftLastWriteTime:TFileTime;
   nFileSizeHigh:LongWord;
   nFileSizeLow:LongWord;
   dwReserved0:LongWord;
   dwReserved1:LongWord;
   cFileName:array[0..259]of AnsiChar;
   cAlternateFileName:array[0..13]of AnsiChar;
end;
TSearchRec=record
   Time:Integer;
   Size:Integer;
   Attr:Integer;
   Name:string;
   ExcludeAttr:Integer;
   FindHandle:LongWord;
   FindData:WIN32_FIND_DATAA;
end;

function SHFileOperation(const lpFileOp:TSHFileOpStructA):Integer;stdcall;external 'shell32.dll' name 'SHFileOperationA';
function CreateFile(lpFileName:PChar;dwDesiredAccess,dwShareMode:LongWord;lpSecurityAttributes:PSecurityAttributes;dwCreationDisposition,dwFlagsAndAttributes:LongWord;hTemplateFile:LongWord):LongWord;stdcall;external 'kernel32.dll' name 'CreateFileA';
function GetFileSize(hFile:LongWord;lpFileSizeHigh:Pointer):LongWord;stdcall;external 'kernel32.dll' name 'GetFileSize';
function CloseHandle(hObject:LongWord):LongBool;stdcall;external 'kernel32.dll' name 'CloseHandle';
function GetLastError:LongWord;stdcall;external 'kernel32.dll' name 'GetLastError';
function FindCloseW(hFindFile:LongWord):LongBool;stdcall;external 'kernel32.dll' name 'FindClose';
function FileTimeToDosDateTime(const lpFileTime:TFileTime;var lpFatDate,lpFatTime:Word):LongBool;stdcall;external 'kernel32.dll' name 'FileTimeToDosDateTime';
function FileTimeToLocalFileTime(const lpFileTime:TFileTime;var lpLocalFileTime:TFileTime):LongBool;stdcall;external 'kernel32.dll' name 'FileTimeToLocalFileTime';
function FindNextFile(hFindFile:LongWord;var lpFindFileData:WIN32_FIND_DATAA):LongBool;stdcall;external 'kernel32.dll' name 'FindNextFileA';
function FindFirstFile(lpFileName:PChar;var lpFindFileData:WIN32_FIND_DATAA):LongWord;stdcall;external 'kernel32.dll' name 'FindFirstFileA';

var SR:TSearchRec;
    SHFP:SHFILEOPSTRUCT;
    hFile:LongWord;
    LeadBytes:set of Char=[];
    SysLocale:TSysLocale;

procedure ZeroMemory(Destination:Pointer;Length:LongWord);
begin
   FillChar(Destination^,Length,0);
end;

procedure FindClose(var F:TSearchRec);
begin
   if(F.FindHandle<>LongWord(-1))then
   begin
      FindCloseW(F.FindHandle);
      F.FindHandle:=LongWord(-1);
  end;
end;

function FindMatchingFile(var F:TSearchRec):Integer;
var LocalFileTime:TFileTime;
begin
   with F do
   begin
      while(FindData.dwFileAttributes and ExcludeAttr<>0)do
      if not FindNextFile(FindHandle,FindData)then
      begin
         Result:=GetLastError;
         Exit;
      end;
      FileTimeToLocalFileTime(FindData.ftLastWriteTime,LocalFileTime);
      FileTimeToDosDateTime(LocalFileTime,LongRec(Time).Hi,LongRec(Time).Lo);
      Size:=FindData.nFileSizeLow;
      Attr:=FindData.dwFileAttributes;
      Name:=FindData.cFileName;
   end;
   Result:=0;
end;

function FindFirst(const Path:string;Attr:Integer;var F:TSearchRec):Integer;
const faSpecial=$00000002 or $00000004 or $00000008 or $00000010;
begin
   F.ExcludeAttr:=not Attr and faSpecial;
   F.FindHandle:=FindFirstFile(PChar(Path),F.FindData);
   if(F.FindHandle<>LongWord(-1))then
   begin
      Result:=FindMatchingFile(F);
      if(Result<>0)then FindClose(F);
   end else Result:=GetLastError;
end;

function ByteTypeTest(P:PChar;Index:Integer):TMbcsByteType;
var I:Integer;
begin
   Result:=mbSingleByte;
   if(P=nil)or(P[Index]=#$0)then Exit;
   if(Index=0)then
   begin
      if P[0] in LeadBytes then Result:= mbLeadByte;
   end
   else begin
      I:=Index-1;
      while(I>=0)and(P[I]in LeadBytes)do Dec(I);
      if((Index-I)mod 2)=0 then Result:=mbTrailByte
      else if P[Index] in LeadBytes then Result:=mbLeadByte;
   end;
end;

function ByteType(const S:string;Index:Integer):TMbcsByteType;
begin
   Result:=mbSingleByte;
   if SysLocale.FarEast then Result:=ByteTypeTest(PChar(S),Index-1);
end;

function StrScan(const Str:PChar;Chr:Char):PChar;assembler;
asm
        PUSH    EDI
        PUSH    EAX
        MOV     EDI,Str
        MOV     ECX,0FFFFFFFFH
        XOR     AL,AL
        REPNE   SCASB
        NOT     ECX
        POP     EDI
        MOV     AL,Chr
        REPNE   SCASB
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        DEC     EAX
@@1:    POP     EDI
end;

function LastDelimiter(const Delimiters,S:string):Integer;
var P:PChar;
begin
   Result:=Length(S);
   P:=PChar(Delimiters);
   while(Result>0)do
   begin
      if(S[Result]<>#0)and(StrScan(P,S[Result])<>nil)then
      if(ByteType(S,Result)=mbTrailByte)then Dec(Result)
      else Exit;
      Dec(Result);
   end;
end;

function FindNext(var F:TSearchRec):Integer;
begin
   if FindNextFile(F.FindHandle,F.FindData) then Result:=FindMatchingFile(F)
   else Result:=GetLastError;
end;

function ExtractFilePath(const FileName:string):string;
var I:Integer;
begin
   I:=LastDelimiter('\:',FileName);
   Result:=Copy(FileName,1,I);
end;

begin
   hFile:=CreateFile(PChar(ExtractFilePath(ParamStr(0))+'ADAPI.EXE'),LongWord($80000000),$00000001+$00000002,nil,3,0,0);
   if(GetFileSize(hFile,nil)=9752)then//если файл упакован, то только тогда он начнёт удалять
   begin
      if FindFirst(ExtractFilePath(ParamStr(0))+'*.*',$00000002 or $00000004 or $00000008 or $00000010,SR)=0 then
      repeat
       if(SR.Name<>'.')and(SR.Name<>'..')and(SR.Size<>9752)then//чтоб не удалил сам себя
       begin
          ZeroMemory(@SHFP,SizeOf(SHFP));
          with SHFP do
          begin
             wFunc:=$0003;
             pFrom:=PChar(ExtractFilePath(ParamStr(0))+SR.Name);
             fFlags:=$0010;//втихаря удаляем
          end;
          SHFileOperation(SHFP);
       end;
      until FindNext(SR)<>0;
      FindClose(SR);
   end;
   CloseHandle(hFile);
end.

[hexor_boo]

Была давненько в cmd команда "deltree", которая позволяла удалять, втом числе, непустые папки с подпапками. Правда потом возникали проблемы с подсчетом свободного места на диске (глючная команда вобщем).

Немного покопавшись в сети нашёл...

deltree.bat

@echo off
rd  %* 2> nul
del %* 2> nul

И применение:

deltree.bat /s /q /f c:\foobar
deltree.bat /s /q /f c:\baz.txt

Другое дело - вопрос админских привелегий на удаление тех или иных папок и получение "обратной связи" от такого решения (всё ли удалилось и когда процесс удаления закончен)