Stars of Shareware: Windows Tools/SOS-WIN_TOOLS.ISO/programm/divers/ecotrash/trash.pas

Pascal/Delphi Source File | 1994-02-18 | 21.1 KB | 765 lines

Program Trash;

{***********************************************************************

                     The first ecologic trash !!


        By Sebastien Stormacq (c) 1993 - FNDP Namur - Belgium

***********************************************************************}


{$R TRASH}

Uses
 WinTypes,WinProcs,Win31,ShellAPI,WObjects,Strings, WinDos, BWCC, LZExpand;

Const
  AppName      = 'Trash Can';
  id_path      = 101;
  id_Recycle   = 400;
  cm_show      = 991;
  cm_empty     = 992;
  cm_ontop     = 995;
  id_pathname  = 996;
  id_filelist  = 997;
  id_help      = 998;
  Title        = 'Eco Taxe : ' + #13;

Type
  PTrashWin = ^TTrashWin;
  TTrashWin = Object(TWindow)

                LExtension          : PStrCollection;
                msg_Title           : array[0..30] of char;
                ontop               : boolean;
                currency            : array[0..4] of char;

                Constructor Init(AParent : PWindowsObject; AName : PChar);

                Destructor Done;
                  Virtual;

                Procedure SetupWindow;
                  Virtual;

                Function GetClassName : PChar;
                  Virtual;

                Procedure GetWindowClass(Var AWndClass : TWndClass);
                  Virtual;

                Procedure WMSysMessage(Var msg : TMessage);
                  Virtual wm_SysCommand;

                Procedure Show_message(Var msg : TMessage);
                  Virtual cm_first + cm_show;

                Procedure Empty_Trash(Var msg : TMessage);
                  Virtual cm_first + cm_empty;

                Procedure WMQueryOpen(Var Msg : TMessage);
                  Virtual wm_QueryOpen;

                Procedure WMDropFiles(var Msg : TMessage);
                  Virtual wm_first + wm_DropFiles;

                Procedure FileDropped(FileName : PChar;
                                      Var DropPos : TPoint;
                                      InClient : Boolean);
                  Virtual;

                Procedure OnTopProc(var msg : TMessage);
                  Virtual wm_first + cm_ontop;

                Procedure Make_Message;
              End;

 TMyApp = Object(TApplication)
            Procedure InitMainWindow;
              Virtual;
          End;

 PEmpty = ^TEmpty;
 TEmpty = Object(TDialog)
            path_name  : PStatic;
            File_List  : PListBox;
            MainWind   : PTrashWin;

            Constructor Init(AParent : PWindowsObject; AName : PChar);
            Procedure SetupWindow;
              Virtual;
            Procedure OK(var msg : TMessage);
              Virtual id_first + id_ok;
            Procedure Help(Var msg : TMessage);
              Virtual id_first + id_help;
            Procedure Recycle(var msg : Tmessage);
              Virtual id_first + id_recycle;
            Function  GetSelFile : PChar;
            End;

 PToWhere = ^TToWhere;
 TToWhere = Object(TDialog)

            ppath     : PEdit;
            path      : array[0..144] of char;
            father    : PEmpty;
            bt_ok     : PButton;

            Constructor Init(AParent : PWindowsObject; AName : PChar);
            Destructor  Done;
              Virtual;
            Procedure SetupWindow;
              Virtual;
            Procedure OK(var msg : TMessage);
              Virtual id_first + id_ok;
            Procedure CheckEdit(var msg : TMessage);
              Virtual id_first + id_path;
            end;

var
   config_show_message : boolean;
   config_move_to_dir  : array[0..144] of char;
   a_file              : array[0..13] of char;
   MyApp               : TMyApp;
   ecotax              : LongInt;
{---------------------------------------------------}

{ --- Application Methods --- }

Procedure TMyApp.InitMainWindow;

Begin
  MainWindow := New(PTrashWin,Init(nil,AppName));
End;

{---------------------------------------------------}
Constructor TTrashWin.Init;

Begin
     TWindow.Init(Aparent, AName);

     LExtension := New(PStrCollection,Init(10,10));
End;

{---------------------------------------------------}
Destructor TTrashWin.Done;

Begin
     TWindow.Done;

     Dispose(LExtension,Done)
End;
{---------------------------------------------------}

{ --- Window Methods --- }

Procedure TTrashWin.Make_Message;

var
    tmp_ecotax     : integer;
    st_ecotax      : string[9];
    nt_ecotax      : array[0..9] of char;

Begin
  StrCopy(msg_Title,'');
  tmp_ecotax := ecotax div 1024;
  Str(tmp_ecotax,st_ecotax);
  StrPCopy(nt_ecotax,st_ecotax);
  StrCat(msg_Title,Title);
  StrCat(msg_Title,nt_ecotax);
  StrCat(msg_Title,' ');
  StrCat(msg_Title, currency);
End;
{---------------------------------------------------}
Procedure TTrashWin.SetupWindow;

var menu               : hmenu;
    show_msg,
    nt_ontop           : array[0..3]  of char;
    config_list_file,
    temp               : array[0..70] of char;
    extension          : array[0..4]  of char;
    dirInfo            : TSearchRec;
    file_mask          : array[0..127] of char;

    win_dir            : array[0..80] of char;
    buffer             : TOfStruct;

Begin
  TWindow.SetupWindow;

  SetCursor(LoadCursor(0,idc_wait));

  DragAcceptFiles(hWindow,True); { Inform Windows that we accept file drops }

  {Append two new item to the system menu}
  menu := GetSystemMenu(hWindow,false);
  AppendMenu(menu,mf_separator,0,Nil);
  AppendMenu(menu,mf_string,cm_show,'&Show Messages');
  AppendMenu(menu,mf_string,cm_ontop,'&On Top');

  {test the trash.ini file existence}
  GetWindowsDirectory(win_dir,80);
  StrCat(win_dir,'\trash.ini');
  {if it doesn't exist create it with default values}
  if LZOpenFile(win_dir,buffer,of_exist) < 0 then begin
     WritePrivateProfileString('Configuration','Show_Message','Yes',win_dir);
     if GetEnvVar('TEMP')<>NIL then begin
                                 StrCopy(temp, GetEnvVar('TEMP'));
                                 StrCat(temp,'\TRASH')
                                 end
                                else StrCopy(temp,'c:\trash');

     WritePrivateProfileString('Configuration','Move_To',temp,win_dir);
     WritePrivateProfileString('Configuration','On_Top','Yes',win_dir);
     WritePrivateProfileString('Configuration','Reusable','.TXT .DOC .WRI',win_dir);
     end;



  GetPrivateProfileString('Configuration','Show_Message','Yes',show_msg,4,'trash.ini');
  if StrComp(show_msg,'Yes')=0 then begin
     CheckMenuItem(Menu,cm_show,mf_ByCommand Or mf_Checked);
     config_show_message := TRUE
     end
  else Begin
     CheckMenuItem(Menu,cm_show,mf_ByCommand Or mf_UnChecked);
     config_show_message := FALSE
     end;


  AppendMenu(menu,mf_separator,0,Nil);
  AppendMenu(menu,mf_string,cm_empty,'&Empty Trash...');

  {Disabled the items Maximize and Restore}
  ModifyMenu(menu,sc_restore,mf_bycommand or mf_grayed,0,'Restore');
  ModifyMenu(menu,sc_MAximize,mf_bycommand or mf_grayed,0,'Maximize');

  {Get the directory_name where the files will be stored}
  GetPrivateProfileString('Configuration','Move_To',GetEnvVar('Temp'),config_move_to_dir,30,'trash.ini');


  {Get the local currency in the win.ini file}
  GetProfileString('intl','sCurrency','FB',currency,4);

  {Get the ontop flag}
  GetPrivateProfileString('Configuration','On_Top','Yes',nt_ontop,4,'trash.ini');
  if StrComp(nt_ontop,'Yes')=0 then begin
     ontop := TRUE;
     CheckMenuItem(Menu,cm_ontop,mf_ByCommand Or mf_Checked);
     end
  else begin
     ontop := false;
     CheckMenuItem(menu,cm_ontop,mf_bycommand or mf_unchecked);
  end;

  if ontop then SetWindowPos(hWindow,hwnd_topmost,0,0,0,0,swp_nosize or swp_nomove) {Put the icon on top of another windows}
           else SetWindowPos(hWindow,hwnd_notopmost,0,0,0,0,swp_nosize or swp_nomove);

  {Get the list of ReUsable files}
  GetPrivateProfileString('Configuration','Reusable','.TXT',config_list_file,69,'trash.ini');
  StrCopy(temp,'');

  while StrScan(config_list_file,'.')<>nil do
  begin
     StrLCopy(extension,config_list_file,4);

     LExtension^.Insert(StrNew(extension));
     config_list_file[0] := '/';
     if StrScan(config_list_file,'.') <> nil then StrCopy(temp,StrScan(config_list_file,'.'));
     StrCopy(Config_list_file,'');
     StrCopy(config_list_file,temp);
     StrCopy(temp,'');
  End;

  ecotax := 0;
  StrCopy(file_mask,config_move_to_dir);
  StrCat(File_mask,'\*.*');
  FindFirst(file_mask,faanyfile, DirInfo);

  While DosError = 0 do begin
      ecotax := ecotax + DirInfo.Size;
      FindNext(DirInfo)
      End;

  Make_Message;

  SetWindowText(hWindow,msg_Title); {Set the text beyond the icon}
  if ecotax = 0 then Begin
     ModifyMenu(menu,cm_empty,mf_bycommand or mf_grayed,cm_empty,'&Empty Trash...');
     SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Empty_Trash'))
     End
  else SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Full_Trash'));


  InvalidateRect(HWindow,Nil,True);
  SetCursor(LoadCursor(0,idc_arrow));
  UpdateWindow(HWindow);

End;  {SetupWindow}

{---------------------------------------------------}

Procedure TTrashWin.WMDropFiles;

Var
 NumFiles : word;
 FileName : array[0..127] of char;
 i : word;
 DropPoint : TPoint;
 InClientArea : boolean;

Begin
 { Msg.wParam contains a handle to the "drop info" }

 { First, find out how many files were dropped }
 NumFiles := DragQueryFile(Msg.wParam,$FFFF,Nil,0);

 { Next, find out where the file was dropped }
 InClientArea := DragQueryPoint(Msg.wParam,DropPoint);

 { Finally, retrieve the dropped files and call the virtual method
   "FileDropped" }
 For i := 0 to Pred(NumFiles) Do
 Begin
   DragQueryFile(Msg.wParam,i,FileName,Pred(Sizeof(FileName)));
   FileDropped(FileName,DropPoint,InClientArea);
 End;

 { Cleanup - tell Windows that we're done with the "drop info" }
 DragFinish(Msg.wParam);

End {WMDropFiles};

{---------------------------------------------------}

Procedure TTrashWin.FileDropped(FileName : PChar;
                                       Var DropPos : TPoint;
                                       InClient : Boolean);

Const msg_txt = 'Your file is not reusable.'+#13+#13+'You have to pay an ecotaxe.';

Var
  TrashFile    : File;
  ext          : array [0..4] of char;
  ReUsable     : Boolean;
  size         : LongInt;
  DirInfo      : TSearchRec;
  OpenBuffer   : TOfStruct;
  Real_FileName: array[0..12] of char;
  New_FileName : array[0..144] of char;
  lzfile_source,
  lzfile_dest  : integer;
  menu         : hMenu;
  copy_ok      : boolean;

  temp         : array[0..80] of char;

procedure Check_ReUsability(item : pchar); far;

Begin
  if not reusable then ReUsable := ReUsable or (StrComp(ext,item)=0)
end;

Begin
  {exit if you try to trash a file from the trash directory}
  if not(StrPos(FileName,config_move_to_dir) = nil) then exit;

  if ecotax>0 then SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Open_trash'))
              else SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Empty_Open_trash'));
  InvalidateRect(HWindow,Nil,True);
  UpdateWindow(hwindow);

  SetCursor(LoadCursor(0,idc_wait));

  ReUsable := false;

  if StrScan(FileName,'.') <> nil then StrLCopy(ext,StrScan(FileName,'.'),4);

  LExtension^.ForEach(@Check_ReUsability);

  if not ReUsable and config_show_message then
     MessageBox(HWindow,msg_txt,'Ministerial decision',mb_ok or mb_IconExclamation);

  FindFirst(FileName,faAnyFile,DirInfo);

  StrCopy(temp,'The file ');
  StrCat(temp,DirInfo.name);
  StrCat(temp,' is read-only.');
  StrCat(temp,#13);
  StrCAt(temp,'It won''t be deleted.');
  if (DirInfo.attr AND faReadOnly) = faReadOnly then MessageBox(0,temp,'WARNING',MB_OK);

  ecotax := ecotax + DirInfo.size;
  if ecotax > 0 then begin
     menu := GetSystemMenu(hWindow,false);
     ModifyMenu(menu,cm_empty,mf_bycommand or mf_enabled,cm_empty,'&Empty Trash...');
     end;

  Make_Message;
  SetWindowtext(hWindow,msg_Title);

  {get the real file name - without the path - }
  StrCopy(Real_filename,DirInfo.Name);

  StrCopy(New_FileName,config_move_to_dir);

  if LZOpenFile(New_FileName, OpenBuffer, of_exist)=-1 then CreateDir(New_FileName);

  StrCat(New_FileName,'\');
  StrCat(New_FileName,Real_FileName);

  lzfile_source := LZOpenFile(FileName, OpenBuffer, of_read);
  lzfile_dest   := LZOpenFile(New_FileName, OpenBuffer, of_create);
  copy_ok := not(LZCopy(lzfile_source,lzfile_dest) < 0);
  LZClose(lzfile_source);
  LZClose(lzfile_dest);

  if copy_ok then begin
     Assign(TrashFile,FileName);
     {$i-}
     Erase(TrashFile);
     {$i+}
     end;

  SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Full_trash'));
  InvalidateRect(HWindow,Nil,True);
  UpdateWindow(HWindow);


  SetCursor(LoadCursor(0,idc_arrow));

End {FileDropped};

{---------------------------------------------------}

Procedure TTrashWin.WMSysMessage(Var Msg : TMessage);

Begin
  Case Msg.wParam of
    cm_Show   : Show_Message(Msg);
    cm_Empty  : Empty_Trash(msg);
    cm_ontop  : OnTopProc(Msg);
    Else DefWndProc(Msg);
  End;
End {WMSysCommand};

{---------------------------------------------------}
Procedure TTrashWin.Show_Message;

var menu   : hmenu;
    state  : boolean;

Begin

     menu  := GetSystemMenu(hwindow,false);

     if CheckMenuItem(menu,cm_show,mf_bycommand or mf_checked) then
        Begin
          CheckMenuItem(menu,cm_show,mf_bycommand or mf_unchecked);
          config_show_message := false;
          WritePrivateProfileString('Configuration','Show_Message','No','Trash.ini')
          End

     else Begin
          CheckMenuItem(menu,cm_show,mf_bycommand or mf_checked);
          config_show_message := true;
          WritePrivateProfileString('Configuration','Show_Message','Yes','Trash.ini')
          end;
End;

{---------------------------------------------------}
Procedure TTrashWin.Empty_Trash;

var
   EmptyDlg : TEmpty;
   fm_hwnd  : hwnd;
   menu     : hMenu;
   return   : integer;

begin
  SetClassWord(hWindow,gcw_HIcon,LoadIcon(HInstance,'Open_trash'));
  InvalidateRect(HWindow,Nil,True);
  SetCursor(LoadCursor(0,idc_wait));
  UpdateWindow(HWindow);

  EmptyDlg.Init(@Self,'EmptyDlg');

  EmptyDlg.Execute;
  if (ecotax=0) then begin
     SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Empty_trash'));
     InvalidateRect(HWindow,Nil,True);
     SetCursor(LoadCursor(0,idc_arrow));
     UpdateWindow(HWindow);
     end;

  if (ecotax>0) then begin
     SetClassWord(HWindow,gcw_HIcon,LoadIcon(HInstance,'Full_trash'));
     InvalidateRect(HWindow,Nil,True);
     SetCursor(LoadCursor(0,idc_arrow));
     UpdateWindow(HWindow);
     end;

  EmptyDlg.Done;

  Make_Message;
  SetWindowtext(hWindow,msg_title);

  if ecotax = 0 then begin
     menu := GetSystemMenu(Hwindow,false);
     ModifyMenu(menu,cm_empty,mf_bycommand or mf_grayed,cm_empty,'&Empty Trash...');
     end;
End;

{---------------------------------------------------}

Procedure TTrashWin.WMQueryOpen(Var Msg : TMessage);

var msg_temp : TMessage;

Begin
  if ecotax <> 0 then Empty_Trash(msg_temp);

  Msg.Result := 0;       { Deny open }

End {WMQueryOpen};

{---------------------------------------------------}
Procedure TTrashWin.OnTopProc;

Var
   nt_ontop : array [0..3] of char;
   menu     : hMenu;

Begin

  menu := GetSystemMenu(hWindow,FALSE);

  if ontop then begin
     ontop := False;
     CheckMenuItem(Menu,cm_ontop,mf_ByCommand Or mf_UnChecked);
     StrCopy(nt_ontop,'No');
     end
  else begin
     ontop := True;
     CheckMenuItem(menu,cm_ontop,mf_bycommand or mf_checked);
     StrCopy(nt_ontop,'Yes');
  end;

  if ontop then SetWindowPos(hWindow,hwnd_topmost,0,0,0,0,swp_nosize or swp_nomove) {Put the icon on top of another windows}
           else SetWindowPos(hWindow,hwnd_notopmost,0,0,0,0,swp_nosize or swp_nomove);

  WritePrivateProfileString('Configuration','On_Top',nt_ontop,'trash.ini');

end;

{---------------------------------------------------}
Function TTrashWin.GetClassName;

Begin
  GetClassName := AppName;
End {GetClassName};

{---------------------------------------------------}

Procedure TTrashWin.GetWindowClass(Var AWndClass : TWndClass);

Begin
  TWindow.GetWindowClass(AWndClass);

  AWndClass.hIcon := LoadIcon(HInstance,'empty_trash');
End {GetWindowClass};

{---------------------------------------------------}
Constructor TEmpty.Init;

Begin
     TDialog.Init(AParent, AName);
     path_name := New(PStatic, InitResource(@Self, id_pathname,127));
     file_list := New(PListBox, InitResource(@Self, id_filelist));
     MainWind  := New(PTrashWin);
End;
{---------------------------------------------------}
Procedure TEmpty.SetupWindow;

var
    FileName  : array[0..144] of char;

begin
     Tdialog.SetupWindow;
     StrCopy(FileName,config_move_to_dir);
     DlgDirList(hWindow, FileName, id_filelist, id_pathname, ddl_archive);
     file_list^.SetSelIndex(0);
End;
{---------------------------------------------------}
Procedure TEmpty.Ok;

var DirInfo   : TSearchRec;
    FileName  : array[0..144] of char;
    TrashFile : File;

Begin
  StrCopy(FileName,'');
  StrCopy(FileName,config_move_to_dir);
  StrCat(FileName,'\*.*');
  FindFirst(FileName, faArchive + faHidden + faSysFile + faReadOnly, DirInfo);

  while DosError = 0 do
     Begin
        StrCopy(FileName,'');
        StrCopy(FileName,config_move_to_dir);
        StrCat(FileName,'\');
        StrCat(FileName,DirInfo.Name);
        Assign(TrashFile,FileName);
        {$i-}
        Erase(TrashFile);
        {$i+}
        FindNext(DirInfo);
     End;

  ecotax := 0;

  TDialog.Ok(msg);
End;

{---------------------------------------------------}
Procedure TEmpty.Recycle;

var
    FileName  : array[0..144] of char;
    DirInfo   : TSearchRec;

Begin
 file_list^.GetSelString(a_file,13);

 Application^.ExecDialog(New(PToWhere,Init(@Self,'ToWhere')));

 StrCopy(FileName,config_move_to_dir);
 DlgDirList(hWindow, FileName, id_filelist, id_pathname, ddl_archive);
 file_list^.SetSelIndex(0);

 StrCopy(FileName,'');
 StrCopy(FileName,config_move_to_dir);
 ecotax := 0;
 StrCat(FileName,'\*.*');
 FindFirst(fileName,faanyfile, DirInfo);

 While DosError = 0 do begin
     ecotax := ecotax + DirInfo.Size;
     FindNext(DirInfo)
     End;
End;

{---------------------------------------------------}
Function TEmpty.GetSelFile;

Begin
     GetSelFile := a_file;
End;

{---------------------------------------------------}
Constructor TToWhere.Init;

Begin
     TDialog.Init(Aparent, AName);
     ppath  := New(PEdit, InitResource(@Self,id_path,145));
     bt_ok  := New(PButton, InitResource(@Self,id_OK));
     father := new(pempty);
End;

{---------------------------------------------------}
Destructor TToWhere.Done;

Begin
     TDialog.Done;
     Dispose(father);
End;
{---------------------------------------------------}

Procedure TToWhere.SetupWindow;

var directory : array[0..144] of char;

Begin
     TDialog.SetupWindow;
     GetWindowsDirectory(directory,144);
     ppath^.SetText(directory);
end;
{---------------------------------------------------}
Procedure TToWhere.Ok;

var
   copy_ok       : Boolean;
   lzfile_source,
   lzfile_dest   : integer;
   OpenBuffer    : TOfStruct;
   TrashFile     : File;
   FileName,
   new_FileName  : array[0..144] of char;

   temp          : string[144];
   temp_len      : byte;
   erreur        : integer;

Begin

  StrCopy(FileName,'');
  StrCat(FileName,config_move_to_dir);
  StrCat(FileName,'\');
  StrCat(FileName,father^.GetSelFile);

  StrCopy(New_FileName,'');
  ppath^.GetText(New_FileName,144);
  if StrComp(StrEnd(New_FileName)-1,'\') <> 0 then StrCat(New_FileName,'\');
  StrCat(New_FileName,father^.GetSelFile);

  lzfile_source := LZOpenFile(FileName, OpenBuffer, of_read);
  lzfile_dest   := LZOpenFile(New_FileName, OpenBuffer, of_create);
  copy_ok := not(LZCopy(lzfile_source,lzfile_dest) < 0);
  LZClose(lzfile_source);
  LZClose(lzfile_dest);

  if copy_ok then begin
     Assign(TrashFile,FileName);
     {$i-}
     Erase(TrashFile);
     {$i+}
     end
  else MessageBox(hWindow,'The file is not moved',
                  'File Error',mb_ok);

  TDialog.Ok(msg);
End;

{---------------------------------------------------}
Procedure TToWhere.CheckEdit;

var New_FileNAme : array[0..144] of char;

Begin
     if msg.lparamhi = en_change then Begin
        ppath^.GetText(New_FileName,144);
        if StrComp(New_FileNAme,'')=0 then EnableWindow(bt_ok^.hWindow,false)
                                      else EnableWindow(bt_ok^.hWindow,true);
        end;
End;

{---------------------------------------------------}
Procedure TEmpty.Help;

Begin
    Application^.ExecDialog(New(PDialog,Init(@Self,'About')));
End;

{---------------------------------------------------}
Begin
  CmdShow := sw_ShowMinNoActive;

  MyApp.Init(AppName);
  MyApp.Run;
  MyApp.Done;
End.