home *** CD-ROM | disk | FTP | other *** search
/ Wacky Windows Stuff... / WACKY.iso / toolbook / filecopy.pas < prev    next >
Pascal/Delphi Source File  |  1992-08-09  |  13KB  |  471 lines
  1. {****  FileCopy Copyright 1992 Doug Overmyer ********}
  2. unit filecopy;
  3. {$R filecopy.RES}
  4. {$I+}
  5. interface
  6. uses WinTypes, WinProcs, WObjects,Strings,windos,commdlg,win31,
  7.     sclptext,Meter;
  8. const
  9.   FC_Name =  'FileCopy';
  10.   id_StH       = 101;
  11.   id_STJ       = 102;
  12.   id_Copy      = 201;
  13.   id_Move      = 202;
  14.   id_About     = 501;
  15.   id_CMFrom =    601;
  16.   id_CMTo =      602;
  17.   id_CMCopy =    603;
  18.   id_CMMove =    604;
  19.   id_CMDel  =    605;
  20.   id_CMExit =    610;
  21. {**********************  TYPES      ******************************}
  22. type
  23. PFCWindow = ^TFCWindow;
  24. TFCWindow = object(TWindow)
  25.     Files:PStrCollection;
  26.      StH,StJ:PSText;
  27.      SourceBuf:PChar;
  28.      SourceDir,TargetDir:PChar;
  29.   IsActive:Boolean;
  30.   constructor Init(AParent:PWindowsObject;ATitle: PChar);
  31.   function GetClassName:PChar;virtual;
  32.   destructor Done; virtual;
  33.   procedure SetupWindow;virtual;
  34.   procedure CMFrom(Var Msg:TMessage);virtual cm_First+id_CMFrom;
  35.   procedure CMTo(var Msg:TMessage);virtual cm_First+id_CMTo;
  36.   procedure CMCopy(Var Msg:TMessage);virtual cm_First+id_CMCopy;
  37.   procedure CMMove(Var Msg:TMessage);virtual cm_First+id_CMMove;
  38.   procedure CMDel(var Msg:TMessage);virtual cm_First+id_CMDel;
  39.   procedure CMExxit(Var Msg:TMessage);virtual cm_First+id_CMExit;
  40.   procedure CopyMove(ActionType:Integer);
  41.   procedure SetHeader(Msg:Pchar);
  42.   procedure    WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
  43.   function CanClose:Boolean;virtual;
  44.   procedure CleanUp;virtual;
  45. end;
  46. {*****************************************************************}
  47. implementation
  48. {*********************  Functions  *******************************}
  49. function StrTok(P:PChar;C:Char):PChar;
  50. const
  51.     Next:Pchar = nil;
  52. begin
  53.     if P = NIL then P := Next;
  54.   if P <> NIL then
  55.       begin
  56.       Next := StrScan(P,C);
  57.       If Next <> NIL then
  58.           begin
  59.         Next^ := #0;
  60.         Next := Next+1;
  61.           end;
  62.       end;
  63.   StrTok := P;
  64. end;
  65. procedure Take5;
  66. var MsgP:TMsg;
  67. begin
  68.     while PeekMessage(MsgP,0,0,0,PM_REMOVE) do
  69.       begin
  70.     if MsgP.Message = WM_QUIT then
  71.         begin
  72.       Application^.Done;
  73.       Halt;
  74.       end;
  75.     TranslateMessage(MsgP);
  76.     DispatchMessage(MsgP);
  77.     end
  78. end;
  79. {**********************  METHODS    ******************************}
  80. {**********************  TFCWindow  *******************************}
  81. constructor TFCWindow.Init(AParent:PWindowsObject;ATitle: PChar);
  82. var
  83.   Indx:Integer;
  84. begin
  85.   TWindow.Init(nil, ATitle);
  86.   with Attr do
  87.     begin
  88.     X := 50; Y := 50; W := 340; H := 100;
  89.     DisableAutoCreate;
  90.          Attr.Style := ws_Popup or ws_Visible or ws_Border or ws_Caption
  91.              or ws_MinimizeBox or ws_SysMenu;
  92.     Menu := LoadMenu(hInstance,'FC_Menu');
  93.     end;
  94.   StJ := New(PSText,Init(@Self,id_StH,'',30,30,275,20,sr_Recessed,
  95.               dt_Left or dt_VCenter or dt_SingleLine));
  96.   StH := New(PSText,Init(@Self,id_StJ,'',30,5,275,20,sr_Recessed,
  97.               dt_Left or dt_VCenter or dt_SingleLine));
  98.   GetMem(SourceBuf,4096);
  99.   GetMem(SourceDir,fsDirectory+1);
  100.   GetMem(TargetDir,fsDirectory+1);
  101.   StrCopy(SourceBuf,'');
  102.   StrCopy(SourceDir,'');
  103.   Strcopy(TargetDir,'');
  104.     Files := New(PStrCollection,Init(10,10));
  105.   IsActive := False;
  106. end;
  107.  
  108. function TFCWindow.GetClassName:PChar;
  109. begin
  110.     GetClassName := 'FCWindow';
  111. end;
  112.  
  113. destructor TFCWindow.Done;
  114. begin
  115.     FreeMem(SourceBuf,4096);
  116.   FreeMem(SourceDir,fsDirectory+1);
  117.   FreeMem(TargetDir,fsDirectory+1);
  118.   Dispose(Files,Done);
  119.   TWindow.Done;
  120. end;
  121.  
  122. procedure TFCWindow.SetupWindow;
  123. var
  124.   SysMenu:HMenu;
  125. begin
  126.   TWindow.SetupWindow;
  127.   SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'FC_Icon'));
  128.   SetClassWord(HWindow,GCW_HBrBackground,GetStockObject(ltGray_Brush));
  129.   Sysmenu := GetSystemMenu(hWindow,false);
  130.   AppendMenu(SysMenu,MF_Separator,0,nil);
  131.   AppendMenu(Sysmenu,0,id_About,'About...');
  132.   SetHeader('');
  133. end;
  134.  
  135. procedure TFCWindow.SetHeader(Msg:PChar);
  136. var
  137.  Buf:Array[0..200] of Char;
  138.  M:Record
  139.      SC:PChar;
  140.   cFiles:Integer;
  141.  end;
  142. begin
  143.     M.SC := SourceDir;
  144.   M.cFiles := Files^.Count;
  145.   wvsprintf(Buf,'Source:%s    Count:%i',M);
  146.   StH^.SetText(Buf);
  147.   wvsprintf(Buf,'Target:%s',TargetDir);
  148.   StJ^.SetText(Buf);
  149. end;
  150.  
  151. procedure TFCWindow.CMFrom(var Msg:TMessage);
  152. const
  153.   szFilter:Array[0..8] of Char ='*.*'#0'*.*'#0#0;
  154. var
  155.     szDirName:Array[0..256] of Char;
  156.   szFile,szFileTitle:Array[0..512] of Char;
  157.   OFN:TOpenFileName;
  158.   P:PChar;
  159.   OldDir:Array[0..fsDirectory] of char;
  160.  Path,PathName:Array[0..69] of Char;
  161.  FName:Array[0..18] of Char;
  162.  pResult:PChar;
  163. begin
  164.     Files^.FreeAll;
  165.     GetCurDir(OldDir,0);
  166.     StrCopy(SourceBuf,'');
  167.   StrCopy(SourceDir,'');
  168.   OFN.lStructSize := sizeof(TOpenFileName);
  169.   OFN.hWndOwner := HWindow;
  170.   OFN.lpStrFilter := @szFilter;
  171.   OFN.lpStrCustomFilter := nil;
  172.   OFN.nMaxCustFilter := 0;
  173.   OFN.nFilterIndex := LongInt(1);
  174.   OFN.lpStrFile := SourceBuf;
  175.   OFN.nMaxFile := 4096;
  176.   OFN.lpstrfileTitle := szFileTitle;
  177.   OFN.nMaxFileTitle := sizeof(szFileTitle);
  178.   OFN.lpstrInitialDir := NIL;
  179.   OFN.lpStrTitle := 'Source Files';
  180.   OFN.flags := OFN_ALLOWMULTISELECT;
  181.   OFN.nFileOffset := 0;
  182.   OFN.nFileExtension := 0;
  183.   OFN.lpstrDefext := nil;
  184.     if GetOpenFileName(OFN)  then
  185.     GetCurDir(SourceDir,0);
  186.  
  187.     if StrLen(SourceBuf) > 0 then
  188.       begin
  189.         pResult := StrScan(SourceBuf,' ');
  190.       if pResult = NIL then                       {1 file only}
  191.           Files^.Insert(StrNew(SourceBuf))
  192.       else                                        {2 or more  }
  193.           begin
  194.         pResult := StrTok(SourceBuf,' ');          {get the path}
  195.         StrCopy(Path,pResult);
  196.         SetCurDir(Path);                          {chdir there}
  197.         pResult := StrTok(NIL,' ');               {get the 1st filename}
  198.         while pResult <> NIL do
  199.             begin
  200.           FileExpand(PathName,pResult);           {expand file name}
  201.             Files^.Insert(StrNew(PathName));        {store it in collection}
  202.             pResult := StrTok(NIL,' ');             {get next file name}
  203.             end;
  204.         end;
  205.     end;
  206.   SetHeader('');
  207. {  SetCurDir(OldDir);}
  208. end;
  209.  
  210. procedure TFCWindow.CMTo(var Msg:TMessage);
  211. const
  212.   szFilter:Array[0..8] of Char ='ALL'#0'*.*'#0#0;
  213. var
  214.     szDirName,TargetBuf:Array[0..256] of Char;
  215.   szFile,szFileTitle:Array[0..512] of Char;
  216.   OFN:TOpenFileName;
  217.   P:PChar;
  218.   OldDir:Array[0..fsDirectory] of char;
  219. begin
  220.     GetCurDir(OldDir,0);
  221.     StrCopy(TargetBuf,'');
  222.   StrCopy(TargetDir,'');
  223.   OFN.lStructSize := sizeof(TOpenFileName);
  224.   OFN.hWndOwner := HWindow;
  225.   OFN.lpStrFilter := @szFilter;
  226.   OFN.lpStrCustomFilter := nil;
  227.   OFN.nMaxCustFilter := 0;
  228.   OFN.nFilterIndex := LongInt(1);
  229.   OFN.lpStrFile := TargetBuf;
  230.   OFN.nMaxFile := sizeOf(TargetBuf);
  231.   OFN.lpstrfileTitle := szFileTitle;
  232.   OFN.nMaxFileTitle := sizeof(szFileTitle);
  233.   OFN.lpstrInitialDir := NIL;
  234.   OFN.lpStrTitle := 'Target Directory';
  235.   OFN.flags := OFN_PATHMUSTEXIST OR OFN_NOVALIDATE;
  236.   OFN.nFileOffset := 0;
  237.   OFN.nFileExtension := 0;
  238.   OFN.lpstrDefext := nil;
  239.     if GetOpenFileName(OFN)  then
  240.     GetCurDir(TargetDir,0);
  241.   SetHeader('');
  242.   SetCurDir(OldDir);
  243. end;
  244.  
  245. procedure TFCWindow.CMCopy(var Msg:TMessage);
  246. begin
  247.     if Files^.Count = 0 then
  248.     MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP)
  249.     else if StrLen(TargetDir) = 0 then
  250.     MessageBox(HWindow,'Please select target first','Now get this...',MB_ICONSTOP)
  251.   else if StrIComp(SourceDir,TargetDir) = 0 then
  252.       MessageBox(HWindow,'Source & target directories must differ!','Now get this...',MB_ICONSTOP)
  253.   else CopyMove(id_Copy);
  254. end;
  255.  
  256. procedure TFCWindow.CMMove(var Msg:TMessage);
  257. begin
  258.     if Files^.Count = 0 then
  259.     MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP)
  260.     else if StrLen(TargetDir) = 0 then
  261.     MessageBox(HWindow,'Please select target first','Now get this...',MB_ICONSTOP)
  262.   else if StrIComp(SourceDir,TargetDir) = 0 then
  263.       MessageBox(HWindow,'Source & target directories must differ!','Now get this...',MB_ICONSTOP)
  264.   else CopyMove(id_Move);
  265. end;
  266.  
  267. procedure TFCWindow.CopyMove(ActionType:Integer);
  268. const
  269.     BufLen:Integer = 16384;
  270. var
  271.  Path,Dir,Name,Ext,TPathName:Array[0..69] of Char;
  272.  FName:Array[0..18] of Char;
  273.  pResult:PChar;
  274.  Indx,Error,Dr,MoveCount:Integer;
  275.  F1,F2:File;
  276.  MsgX:Array[0..50] of Char;
  277.  Buffer:PChar;
  278.  Count,BytesRead,FileBytes:LongInt;
  279.  MsgXRec : Record
  280.      CopyCount:Integer;
  281.   Action:PChar;
  282.   TotBytes:LongInt;
  283.  end;
  284.  MsgD:TMsg;
  285.  Meter:PMeterWindow;
  286.  Pct:Integer;
  287.  OutBuf:Array[0..80] of Char;
  288. begin
  289.     Meter:=New(PMeterWindow,Init(@Self,'Copying Files...'));
  290.   Application^.MakeWindow(Meter);
  291.   Meter^.Draw(0); Pct := 0;
  292.   UpdateWindow(Meter^.HWindow);
  293.     IsActive := True;
  294.   Buffer :=MemAlloc(BufLen);
  295.   MsgXRec.CopyCount := 0;
  296.   MsgXRec.TotBytes := 0;
  297.   Dr := Ord(UpCase(TargetDir[0]));
  298.   for Indx := 0 to (Files^.Count -1) do       {copy the selected files}
  299.       begin
  300.     If (Pct < ((Indx * 100) div Files^.Count)) then
  301.         begin
  302.       Meter^.Draw(Pct);
  303.       Inc(Pct,5);
  304.       end;
  305.     pResult := Files^.At(Indx);
  306.     Assign(F1,PResult);
  307.     FileMode := 0;
  308.     {$I-}
  309.     Reset(F1,1);
  310.     {$I+}
  311.     if IOResult <> 0 then
  312.         begin
  313.       Meter^.CloseWindow;
  314.       wvsprintf(OutBuf,'Error openining file:%s',pResult);
  315.       MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
  316.       CleanUp;
  317.            FreeMem(Buffer,Buflen);
  318.       IsActive := False;
  319.         Exit;
  320.       end;
  321.     FileBytes := FileSize(F1);
  322.     if DiskFree(Dr-64) < FileBytes then
  323.         begin
  324.       Meter^.CloseWindow;
  325.       MessageBox(HWindow,'Insufficient Disk Space!','Copy/Move Aborted',MB_ICONSTOP);
  326.             CleanUp;
  327.           FreeMem(Buffer,Buflen);
  328.       IsActive := False;
  329.         Exit;
  330.       end;
  331.     Count := FileBytes;
  332.     BytesRead := 0;
  333.     FileSplit(PResult,Dir,Name,Ext);
  334.     StrCopy(TPathName,TargetDir);
  335.     if TPathName[StrLen(TPathName)-1] = '\' then
  336.         TPathName[StrLen(TPathName)-1] := #0;
  337.     StrCat(StrCat(Strcat(TPathName,'\'),Name),Ext);
  338.     Assign(F2,TPathName);
  339.         {$I-}
  340.     Rewrite(F2,1);
  341.     {$I+}
  342.     if IOResult <> 0 then
  343.         begin
  344.       Meter^.CloseWindow;
  345.       wvsprintf(OutBuf,'Error creating file:%s',TPathName);
  346.       MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
  347.       CleanUp;
  348.           FreeMem(Buffer,Buflen);
  349.       IsActive := False;
  350.         Exit;
  351.       end;
  352.     while Count > 0 do
  353.         begin
  354.         if Count > BufLen then Count := BufLen;
  355.         BlockRead(F1,Buffer^,Count);
  356.         BlockWrite(F2,Buffer^,Count);
  357.         BytesRead := BytesRead + Count;
  358.         Count:= FileBytes - BytesRead;
  359.         end    ;
  360.     Close(F1);
  361.     Close(F2);
  362.     Inc(MsgXRec.CopyCount);
  363.     MsgXRec.TotBytes := FileBytes + MsgXRec.TotBytes;
  364.     Take5;
  365.     end;
  366.   MsgXRec.Action := 'copied';
  367.   if ActionType = id_Move then
  368.       begin
  369.       for Indx := 0 to (Files^.Count -1) do       {delete the selected files}
  370.           begin
  371.         pResult := Files^.At(Indx);
  372.         Assign(F1,pResult);
  373.         {$I-}
  374.         Erase(F1);
  375.         {$I+}
  376.         if IOResult <> 0 then
  377.             begin
  378.           Meter^.CloseWindow;
  379.           wvsprintf(OutBuf,'Error erasing file:%s',pResult);
  380.           MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
  381.         Cleanup;
  382.               FreeMem(Buffer,Buflen);
  383.           IsActive := False;
  384.             Exit;
  385.           end;
  386.         Inc(MoveCount);
  387.         end;
  388.     MsgXRec.Action := 'moved'
  389.     end;
  390.   Meter^.CloseWindow;
  391.   MsgXRec.TotBytes := MsgXRec.TotBytes div 1024;
  392.   wvsprintf(MsgX,'%i Files %s / %li KB',MsgXRec);
  393.   MessageBox(HWindow,MsgX,'OM File',0);
  394.   FreeMem(Buffer,Buflen);
  395.   CleanUp;
  396.     IsActive := False;
  397. end;
  398.  
  399. procedure TFCWindow.CMDel(var Msg:TMessage);
  400. var
  401.  pResult:PChar;
  402.  Indx,Error,DelCount:Integer;
  403.  F1:File;
  404.  MsgX:Array[0..50] of Char;
  405.  OutBuf:Array[0..80] of Char;
  406.  oC:HCursor;
  407. begin
  408.     DelCount := 0;
  409.     if Files^.Count = 0 then
  410.       begin
  411.     MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP);
  412.     Exit;
  413.     end;
  414.   oC :=SetCursor(LoadCursor(0,IDC_Wait));
  415.   for Indx := 0 to (Files^.Count -1) do       {process the selected files}
  416.       begin
  417.     pResult := Files^.At(Indx);
  418.     Assign(F1,pResult);
  419.         Assign(F1,pResult);
  420.         {$I-}
  421.         Erase(F1);
  422.         {$I+}
  423.         if IOResult <> 0 then
  424.             begin
  425.           wvsprintf(OutBuf,'Error erasing file:%s',pResult);
  426.           MessageBox(HWindow,OutBuf,'Erase Aborted',MB_ICONSTOP);
  427.         CleanUp;
  428.           IsActive := False;
  429.             Exit;
  430.           end;
  431.     Inc(DelCount);
  432.     end;
  433.   SetCursor(oC);
  434.   wvsprintf(MsgX,'%i Files deleted',DelCount);
  435.   MessageBox(HWindow,MsgX,'File Delete',0);
  436.   CleanUp;
  437. end;
  438.  
  439. procedure TFCWindow.CMExxit(var Msg:TMessage);
  440. begin
  441.     CloseWindow;
  442. end;
  443.  
  444. procedure    TFCWindow.WMSysCommand(var Msg:TMessage);
  445. begin
  446.     case Msg.Wparam of
  447.         id_About:
  448.              application^.ExecDialog(New(PDialog,Init(@Self,'FC_About')));
  449.        else
  450.            DefWndProc(Msg);
  451.        end;
  452. end;
  453.  
  454. function TFCWindow.CanClose:Boolean;
  455. begin
  456.     if IsActive = True then
  457.       CanClose := False
  458.   else
  459.       CanClose := TWindow.CanClose;
  460. end;
  461.  
  462. procedure TFCWindow.CleanUp;
  463. begin
  464.   Files^.FreeAll;
  465.   StrCopy(SourceDir,'');
  466.   StrCopy(TargetDir,'');
  467.   SetHeader('');
  468. end;
  469.  
  470. end.
  471.