CICA 1993 August/CICA.cdr/unzipped/programr/wpjv1n1/trash.pas

Pascal/Delphi Source File | 1993-01-03 | 5.5 KB | 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.