Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Вниз

И снова удаление файлов :((   Найти похожие ветки 

 
Dmitry Toropov   (2002-07-25 18:22) [0]

Но ничего не могу сделать - сегодня часов 6 потратил, чтобы найти ответ на вопрос, как правильно удалять файлы. Проблема, как я понял, у меня с удалением файлов с длинным fullname и помеченных read only.
Вот такая вот у меня процедурка получилась, подскажити, кто захочет, где грабли? (желательно без SHFileOperation - она на моих 9x отказывается работать правильно).
function TThreadFileDelete.fbDoWork: boolean;
var
i:integer;
sLastDir:string;
begin
Result:=false;
try
try
mlstFiles:=TStringList.Create;
mlstDirs:=TStringList.Create;

fSetInitCallBack(
"Формирование списка удаляемых файлов ..."
,0,100,1,0,true);
Synchronize(fInitCallBack);

//form list of files for deletion
fFindAllFiles(msSourcePath,msMask,fDataFromFindAllFiles);
if mbSubDirs then
fScanDirs(msSourcePath,msMask,
fFindAllFiles,fDataFromFindAllFiles,fDataFromScanDirs);

//deletion of files
fSetInitCallBack("",0,mlstFiles.Count,1,0,true);
Synchronize(fInitCallBack);

if mlstFiles.Count=0 then
raise EThreadNoMessage.Create("Файлов не найдено");

for i := 0 to mlstFiles.Count-1 do begin
fSetProgressCallBack(Format(
"Удаление файла <%s> ...",[mlstFiles[i]]),1);
Synchronize(fProgressCallBack);
if Terminated then
raise EThreadNoMessage.Create("");
if not SysUtils.DeleteFile(mlstFiles[i]) then
raise EThreadWithMessage.CreateFmt(
"Ошибка при удалении файла"+#13+"%s",[mlstFiles[i]]);
Sleep(1000);
end; //for i

//здесь я еще не доделал правильно удаление всех подкаталогов
if msMask = "*.*" then begin //remove subDirs
sLastDir:="";
for i:=mlstDirs.Count-1 downto 0 do begin
if sLastDir <> ExtractFileDir(mlstDirs[i]) then begin
sLastDir:=ExtractFileDir(mlstDirs[i]);
RemoveDirectory(PChar(sLastDir));
//if error with dir deletion, ignore it
end; //if
end;//for
end; //if remove subdirs
Result:=true;
fSetInitCallBack("Готово.",1,100,1,100,true);
Synchronize(fInitCallBack);
except
raise;
end;
finally
mlstFiles.Free;
mlstDirs.Free;
end;
end;


 
Skier   (2002-07-25 19:04) [1]

>Dmitry Toropov


> Проблема, как я понял, у меня с удалением файлов с длинным
> fullname и помеченных read only


А в чём собственно проблема ?
(Кстати Sleep(1000); тебе зачем ?)


 
Dmitry Toropov   (2002-07-25 19:12) [2]

>(Кстати Sleep(1000); тебе зачем ?)

;) Пытался определить, на каком именно файле происходит сбой. Уже уходить домой надо (у меня 22:11), и вроде бы только понял, что перед удалением файла нужно его всякие архивные атрибуты снять (вроде бы где-то когда-то об этом читал). Правильно я мыслю или есть какая-нибудь более другая и лучшая функция для удаления, чем DeleteFile?


 
Skier   (2002-07-25 19:18) [3]

>Dmitry Toropov


> нужно его всякие архивные атрибуты снять


Посмотри здесь :

Sets the file attributes of a specified file.

Unit

Sysutils

Category

file management routines

function FileSetAttr(const FileName: string; Attr: Integer): Integer;


 
Dmitry Toropov   (2002-07-25 19:23) [4]

Спасибо, конечно, но чем снять атрибуты - не проблема (хелп на что?) - я интересуюсь, действительно ли перед удалением файла необходимо убрать у него всякие архивные атрибуты?


 
Skier   (2002-07-25 19:29) [5]

>Dmitry Toropov


> действительно ли перед удалением файла необходимо убрать
> у него всякие архивные атрибуты


IMHO, да.


 
Antonius   (2002-07-25 19:42) [6]

Извиняюсь, но это бред. Архивный атрибут - не имеет отношения к удалению. ReadOnly - имеет. System - не уверен - проверить не сложно. В принципе могу выслать процедурку, которая удалят любые файлы.


 
Anatoly Podgoretsky   (2002-07-25 20:33) [7]

Все не удалит, аттрибутов для этого недостаточно, надо что бц еще файл не был открыт


 
SuMaga   (2002-07-25 20:40) [8]

слушай ,Мой тебе совет не ленись Напиши лучше все заново!!!!
и ставь атрибут для всех файлов толькл архивный
и причем файл не должен быть ни в коем слче открыт!!!


 
VID   (2002-07-25 22:27) [9]

to Antonius:
насчёт процедурки по удалению любых файлов... опубликуй здесь, если не трудно, интересно посмотреть...


 
Dmitry Toropov   (2002-07-26 06:57) [10]

Так получается, перед
DeleteFile(sFileName);
делаю:
FileSetAttr(sFileName,faArchive)
и должно заработать? (если, конечно файл кем-то другим в это время не открыт).


 
Antonius   (2002-07-26 10:27) [11]

to VID:
ну под любыми я естественно понимаю с любым атрибутом, но не открытые, не находящиеся на компакт диске, с разрешенными правами на удаление (для текущего пользователя, если NTFS) и тд. :) Вобщем нечто похожее на ответ предыдущего оратора. Просто там добавлены некие маленькие удобства.


 
Dmitry Toropov   (2002-07-26 11:05) [12]

2Antonius

Если она (процедурка с удобствами) небольшая и опубликовать не жалко, то интересно было бы глануть ...


 
Dmitry Toropov   (2002-07-26 11:05) [13]

2Antonius

Если она (процедурка с удобствами) небольшая и опубликовать не жалко, то интересно было бы глянуть ...


 
Antonius   (2002-07-26 11:36) [14]

to Dmitry Toropov
ok. Две процедуры для удаления и переименования:
в функции RaiseLastFileError используется ParseString, ее у меня с собой нет, но заменить ее на что нибудь - не сложно. Она для корректирования стандартного сообщения windows об ошибке. или ее вообще выкинуть.

to TFileDeleteOptions=set of (fdDelReadOnly,fdCheckExists);
//fdDelReadOnly - Удалять файл даже если он ReadOnly или System
//fdCheckExist - Если файл не существует - ошибки не возникает

TFileRenameOptions=set of (frRenameReadOnly,frForceDelete);
//fdRenameReadOnly - переименовывать файл даже если он ReadOnly или System
//fdForceDelete - если Dst file существует - удалять его

procedure RaiseLastFileError(const fileName:string);
var s:string;
begin
try
RaiseLastWin32Error;
except
on E:EWin32Error do
begin
s:=e.message;
ParseString(s,#10,true);
e.message:=s+" ("+fileName+")";
raise;
end;
end;

end;



Procedure DeleteFileOpt(const fn:string; options:TFileDeleteOptions);
var
attr:DWord;
begin
if (fdCheckExists in options) and not FileExists(fn) then exit;
if (fdDelReadOnly in options) then begin
attr:=GetFileAttributes(pchar(fn));
if attr=$FFFFFFFF then RaiseLastFileError(fn);
if attr and (FILE_ATTRIBUTE_READONLY+FILE_ATTRIBUTE_SYSTEM)>0 then begin
attr:=attr and not (FILE_ATTRIBUTE_READONLY+FILE_ATTRIBUTE_SYSTEM);
if not SetFileAttributes(pchar(fn),attr) then RaiseLastFileError(fn);
end;
end;
if not DeleteFile(fn) then RaiseLastFileError(fn);
end;

procedure RenameFileOpt(const Src,Dst:string; options:TFileRenameOptions);
var
Attr,OldAttr:DWord;
DelOpt:TFileDeleteOptions;
ResetAttr:boolean;
begin
if frForceDelete in options then begin
delOpt:=[fdCheckExists];
if frRenameReadOnly in options then
DelOpt:=DelOpt+[fdDelReadOnly];
DeleteFileOpt(Dst,DelOpt);
end;

OldAttr:=0;
ResetAttr:=false;
if (frRenameReadOnly in Options) then begin
OldAttr:=GetFileAttributes(pchar(src));
if OldAttr=$FFFFFFFF then RaiseLastFileError(src);
if OldAttr and (FILE_ATTRIBUTE_READONLY+FILE_ATTRIBUTE_SYSTEM)>0 then begin
attr:=OldAttr and not (FILE_ATTRIBUTE_READONLY+FILE_ATTRIBUTE_SYSTEM);
if not SetFileAttributes(pchar(src),attr) then RaiseLastFileError(src);
ResetAttr:=true;
end;
end;

if not RenameFile(src,dst) then RaiseLastFileError(src);
if ResetAttr and not SetFileAttributes(pchar(dst),OldAttr) then RaiseLastFileError(dst);
end;





Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.6 MB
Время: 0.037 c
3-23858
kaif
2002-07-17 15:05
2002.08.08
И все-таки нужен нормальный инсталлятор IB/Firebird/Yaffil


1-24124
V.Turecky
2002-07-26 15:31
2002.08.08
Transparent in TImage...


14-24183
^Sanya
2002-07-08 00:11
2002.08.08
Почём нынче лицензионное Delphi? (5,6)


1-24023
KPY
2002-07-29 05:38
2002.08.08
Как остановить программу и посмотреть значение переменных


1-24011
mdk
2002-07-28 19:34
2002.08.08
работа с фалами и проч.штуковины!





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский