home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Mother of All Windows Books
/
CD-MOM.iso
/
cd_mom
/
newsletr
/
winprogj
/
wpjv1n1
/
trash.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-01
|
6KB
|
213 lines
(*****************************************)
(* *)
(* Trashcan (trash.pas) *)
(* *)
(* Copyright (c) 1992,93 by A. Furrer *)
(* *)
(* This program requires Windows 3.1 *)
(*****************************************)
program Trashcan;
{$M 1024,0}
{$R-} {no range checking}
{$S-} {no stack checking}
{$I-} {no i/o checking}
{$D-} {no debug informations}
{$L-} {no local symbols}
{$R TRASH.RES}
uses Strings, WinTypes, WinProcs, WObjects, WinDOS;
const cm_About = 1;
(****************************************)
(* Declarations for Drag&Drop-functions *)
(****************************************)
const
wm_DropFiles = $0233;
function DragQueryFile(Drop: THandle;FileIndex: Word;
FileName: PChar;MaxChars: Word):Word; external 'SHELL'
index 11;
function DragQueryPoint(Drop: THandle;var Pt: TPoint):Bool; external 'SHELL'
index 13;
procedure DragFinish(Drop: THandle); external 'SHELL'
index 12;
procedure DragAcceptFiles(Wnd: HWnd;Accept: Bool); external 'SHELL'
index 9;
(****************)
(* Mainwindow *)
(****************)
type
PMainwindow = ¼TMainwindow;
TMainwindow =object(TWindow)
procedure SetupWindow; virtual;
function CanClose: Boolean; virtual;
function GetClassName : PChar;virtual;
procedure GetWindowClass(var AWndClass:TWndClass);virtual;
procedure WMQueryOpen(var Msg : TMessage);virtual wm_First+wm_QueryOpen;
procedure WMSysCommand(var Msg : TMessage); virtual wm_First +
wm_SysCommand;
procedure WMDropFiles(var Msg : TMessage); virtual wm_first + wm_DropFiles;
procedure Delete(s : PChar);
end;
procedure TMainwindow.SetupWindow;
begin
TWindow.SetupWindow;
(* append 'About' to Trashcabs systemmenu *)
AppendMenu(GetSystemMenu(HWindow,FALSE),
mf_Separator,0,NIL);
AppendMenu(GetSystemMenu(HWindow,FALSE),
mf_ByCommand or mf_String,cm_About,
'About Trashcan...');
(* register mainwindow to accept Drag&Drop *)
DragAcceptFiles(HWindow,TRUE);
end;
function TMainwindow.CanClose;
begin
if TWindow.CanClose then
(* Unregister mainwindow for Drag&Drop *)
DragAcceptFiles(HWindow,false);
CanClose:=true;
end;
function TMainwindow.GetClassName :PChar;
begin
GetClassName:='Trashcan';
end;
procedure TMainwindow.GetWindowClass;
begin
TWindow.GetWindowClass(AWndClass);
AWndClass.HIcon:=LoadIcon(HInstance, 'Trashcan');
end;
procedure TMainwindow.WMQueryOpen;
begin
Msg.Result:=0; (* so trashcan will always be an icon *)
end;
procedure TMainwindow.WMSysCommand;
begin
if Msg.wParam = cm_About then (* show about dialog *)
Application¼.ExecDialog(New(PDialog,Init(@self,'About')));
DefWndProc(Msg);
end;
(* this is the Drag&Drop procedure *)
procedure TMainwindow.WMDropFiles;
var s : array╒0..255╩ OF char;
i,number : word;
begin
(* get number of dropped filenames *)
number:=DragQueryFile(Msg.wParam,$ffff,nil,0);
(* get each dropped filename *)
(* and call the delete function *)
for i:=0 TO number-1 DO begin
DragQueryFile(Msg.wParam,i,s,SizeOf(s));
Delete(s);
end;
(* dispose internal Drag&Drop memory *)
DragFinish(Msg.wParam);
end;
(* Function to delete a file or a directory *)
procedure TMainwindow.Delete(s : PChar);
var F : file;
Attribut : word;
DirInfo: TSearchRec;
ss : Array╒0..255╩ of char;
deleteOK : boolean;
begin
Assign(F,s);
GetFAttr(F,Attribut);
if Attribut and (faReadOnly or faHidden or faSysFile)<>0 then begin
(* file is hidden, system or readonly *)
if Attribut and faDirectory <>0 then
StrCopy(ss,'The directory ')
else
StrCopy(ss,'The file ');
StrCat(ss,s);
StrCat(ss,' is read only, hidden or a system file.'#13'Do you really want to
delete it?');
if MessageBox(HWindow,ss,'Trashcan',mb_YesNo or mb_IconQuestion)=id_yes then
begin
(* clear readonly attribut *)
Attribut:=Attribut and not faReadOnly;
SetFAttr(F,Attribut);
deleteOK:=TRUE;
end
else
deleteOK:=FALSE;
end
else
deleteOK:=TRUE;
if deleteOK then begin
(* this will delete the file or directory *)
if Attribut and faDirectory <>0 then begin
(* delete all files in this directory recursive *)
(* and at the end the directory itself *)
StrCopy(ss,s);
StrCat(ss,'\*.*');
FindFirst(ss, faAnyFile, DirInfo);
while DosError = 0 do begin
if (StrComp(DirInfo.Name,'.')<>0)
and (StrComp(DirInfo.Name,'..')<>0) then begin
StrCopy(ss,s);
StrCat(ss,'\');
StrCat(ss,DirInfo.Name);
Delete(ss);
end;
FindNext(DirInfo);
end;
RemoveDir(s);
end
else Erase(F);
end;
end;
(************************)
(* TTrashcanApplication *)
(************************)
type
TTrashcanApplication =
object(TApplication)
procedure InitMainWindow; virtual;
end;
procedure TTrashcanApplication.InitMainWindow;
begin
MainWindow := New(PMainwindow,Init(nil, 'Trashcan'));
end;
(***************)
(* Mainprogram *)
(***************)
var
Prg : TTrashcanApplication;
begin
if HPrevInst=0 then begin (* start only one instance *)
CmdShow := sw_Minimize; (* start as icon *)
Prg.Init('Trashcan');
Prg.Run;
Prg.Done;
end;
end.