[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]

unit Disques;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
     FileCtrl,LZExpand,ShellAPI;

// Constants
const
     (* drive type *)
     _drive_not_exist = 255;
     _drive_floppy    = 1;
     _drive_hard      = 2;
     _drive_network   = 3;
     _drive_CDRom     = 4;
     _drive_RAM       = 5;
     (* directory option *)
     _directory_recurrent      = 1;
     _directory_not_recurrent  = 0;
     _directory_force          = 1;
     _directory_not_force      = 0;
     _directory_clear_file     = 1;
     _directory_not_clear_file = 0;
     (* file error *)
     _File_Unable_To_Delete     = 10;
     _File_Copied_Ok            = 0;
     _File_Already_Exists       = 1;
     _File_Bad_Source           = 2;
     _File_Bad_Destination      = 3;
     _File_Bad_Source_Read      = 4;
     _File_Bad_Destination_Read = 5;
     (* copy switch *)
     _File_copy_Overwrite       = 1;

// Drives
function _Drive_Type (_Drive : char) : byte;
function _Drive_As_Disk (_Drive: Char): Boolean;
function _Drive_Size (_Drive : char) : longint;
function _Drive_Free (_Drive : char) : longint;

// Directories
function _Directory_Exist (_Dir : string) : boolean;
function _Directory_Create (_Dir : string) : boolean;
function _Directory_Delete (_Dir  : string;ClearFile : byte) : boolean;
function _Directory_Delete_Tree (_Dir : string; ClearFile : byte) : boolean;
function _Directory_Rename (_Dir,_NewDir : string) : boolean;

// Files
function _File_Exist (_File : string) : boolean;
function _File_Delete (_File : string) : boolean;
function _File_Recycle (_File : string) : boolean;
function _File_Rename (_File,_NewFile : string;_Delete : byte) : boolean;
function _File_Copy_UnCompress (FromFile,ToFile : string;Switch : byte) : byte;
function _File_Copy(source,dest: String): Boolean;
function _File_Move (_Source,_Destination : string) : boolean;
function _File_Get_Attrib (_File : string) : byte;
function _File_Set_Attrib (_File : string;_Attrib : byte) : boolean;
function _File_Get_Date (_File : string) : string;
function _File_Set_Date (_File,_Date : string) : boolean;
function _File_Get_Size (_File : string) : longint;
function _File_Start (AppName,AppParams,AppDir : string) : integer;

// Miscellaneous
function _Get_WindowsDir : string;
function _Get_SystemDir : string;
function _Get_TempDir : string;
function _Get_Apps_Dir (ExeName : PChar) : string;
function _Get_Apps_Drive (ExeName : PChar) : string;
function _Get_WindowsVer : real;
function _Get_WindowsBuild : real;
function _Get_WindowsPlatform : string;
function _Get_WindowsExtra : string;

implementation


(**********)
(* drives *)
(**********)


(* type of drive *)
function _Drive_Type (_Drive : char) : byte;
var i: integer;
    c : array [0..255] of char;
begin
 _Drive := upcase (_Drive);
 if not (_Drive in ['A'..'Z']) then
  Result := _drive_not_exist
 else
 begin
  strPCopy (c,_Drive + ':\');
  i := GetDriveType (c);
  case i of
   DRIVE_REMOVABLE: result := _drive_floppy;
   DRIVE_FIXED    : result := _drive_hard;
   DRIVE_REMOTE   : result := _drive_network;
   DRIVE_CDROM    : result := _drive_CDRom;
   DRIVE_RAMDISK  : result := _drive_RAM;
  else
   result := _drive_not_exist;
  end;
 end;
end;

(* test is a disk is in drive *)
function _Drive_As_Disk (_Drive: Char): Boolean;
var ErrorMode: Word;
begin
 _Drive := UpCase(_Drive);
 if not (_Drive in ['A'..'Z']) then
 raise
  EConvertError.Create ('Not a valid drive letter');
 ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
 try
  Application.ProcessMessages;
  Result := (DiskSize ( Ord(_Drive) - Ord ('A') + 1) <> -1);
 finally
  SetErrorMode(ErrorMode);
  Application.ProcessMessages;
 end;
end;

(* size of drive *)
function _Drive_Size (_Drive : char) : longint;
var ErrorMode : word;
begin
 _Drive := upcase (_Drive);
 if not (_Drive in ['A'..'Z']) then
 raise
  EConvertError.Create ('Not a valid drive letter');
 ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
 try
  Application.ProcessMessages;
  Result := DiskSize ( Ord(_Drive) - Ord ('A') + 1);
 finally
  SetErrorMode (ErrorMode);
 end;
end;

(* free space in drive *)
function _Drive_Free (_Drive : char) : longint;
var ErrorMode : word;
begin
 _Drive := upcase (_Drive);
 if not (_Drive in ['A'..'Z']) then
 raise
  EConvertError.Create ('Not a valid drive letter');
 ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
 try
  Application.ProcessMessages;
  Result := DiskFree ( Ord(_Drive) - Ord ('A') + 1);
 finally
  SetErrorMode (ErrorMode);
 end;
end;


(***************)
(* directories *)
(***************)

(* directory exists or not *)
function _Directory_Exist (_Dir : string) : boolean;
VAR  OldMode : Word;
     OldDir  : String;
BEGIN
 Result := True;
 GetDir(0, OldDir);
 OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
 try
  try
   ChDir(_Dir);
 except
   ON EInOutError DO
    Result := False;
 end;
 finally
   ChDir(OldDir);
   SetErrorMode(OldMode);
 end;
END;

(* create a directory enven if parent does not exists *)
function _Directory_Create (_Dir : string) : boolean;
begin
 ForceDirectories(_Dir);
 Result := _Directory_Exist (_Dir);
end;

(* delete a directory *)
function _Directory_Delete (_Dir : string;ClearFile : byte) : boolean;
begin
 if _Directory_Exist (_Dir) then
  Result := RemoveDir (_Dir)
 else
  Result := false;
end;

(* delete a tree *)
function _directory_delete_tree (_Dir : string; ClearFile : byte) : boolean;
var SearchRec : TSearchRec;
    Erc : Word;
begin
 if _Directory_Exist (_Dir) then
 begin
  Try
   ChDir (_Dir);
   FindFirst('*.*',faAnyFile,SearchRec);
   Erc := 0;
   while Erc = 0 do
   begin
    if ((SearchRec.Name <> '.' ) and
       (SearchRec.Name <> '..')) then
    begin
     if (SearchRec.Attr and faDirectory > 0) then
      _Directory_Delete_Tree (SearchRec.Name,ClearFile)
     else
      if ClearFile = 1 then
       _File_Delete (SearchRec.Name);
    end;
    Erc := FindNext (SearchRec);
   end;
   FindClose (SearchRec);
   Application.ProcessMessages;
  finally
   if Length(_Dir) > 3 then
    ChDir ('..' );
   Result := RemoveDir (_Dir);
  end;
 end
 else
 (* not exists *)
  Result := false;
end;

(* Renamme a directory *)
function _Directory_Rename (_Dir,_NewDir : string) : boolean;
var SearchRec : TSearchRec;
    Erc : Word;
    f : file;
    o : string;
begin
 if _Directory_Exist (_Dir) then
 begin
  Try
   (* just name of directory *)
   o := _dir;
   Delete (o,1,2); (* remove drive and : *)
   if o [1] = '\' then delete (o,1,1); (* remove \ at begin *)
   if o [length (o)] = '\' then
    o := copy (o,1,length (o)-1); (* delete \ at end *)
   ChDir (_Dir);
   ChDir ('..');
   FindFirst('*.*',faAnyFile,SearchRec);
   Erc := 0;
   while Erc = 0 do
   begin
    if ((SearchRec.Name <> '.' ) and
       (SearchRec.Name <> '..')) then
    begin
     if (SearchRec.Attr and faDirectory > 0) then
     begin
      if SearchRec.Name = o then
      begin
       assignfile (f,SearchRec.Name);
       {$I-};
        rename (F,_NewDir);
       {I+};
       result := (ioresult = 0);
      end;
     end;
    end;
    Erc := FindNext (SearchRec);
   end;
   Application.ProcessMessages;
  finally
   if Length(_Dir) > 3 then
    ChDir ('..' );
  end;
  FindClose (SearchRec);
 end
 else
 (* not exists *)
  Result := false;
end;


(*********)
(* files *)
(*********)

(* file exists or not *)
function _File_Exist (_File : string) : boolean;
begin
 _File_Exist := FileExists(_File);
end;

(* delete a file remove -r if needed *)
function _File_Delete (_File : string) : boolean;
begin
 if FileExists (_File) then
 begin
  _File_Set_Attrib (_File,0);
  Result := DeleteFile (_File);
 end
 else
  Result := false;
end;

(* send a file to recycle *)
function _File_Recycle(_File : TFilename): boolean;
var Struct: TSHFileOpStruct;
    pFromc: array[0..255] of char;
    Resul  : integer;
begin
 if not FileExists(_File) then
 begin
  _File_Recycle := False;
  exit;
 end
 else
 begin
  fillchar(pfromc,sizeof(pfromc),0);
  StrPcopy(pfromc,expandfilename(_File)+#0#0);
  Struct.wnd := 0;
  Struct.wFunc := FO_DELETE;
  Struct.pFrom := pFromC;
  Struct.pTo   := nil;
  Struct.fFlags:= FOF_ALLOWUNDO or FOF_NOCONFIRMATION	;
  Struct.fAnyOperationsAborted := false;
  Struct.hNameMappings := nil;
  Resul := ShFileOperation(Struct);
  _File_Recycle := (Resul = 0);
 end;
end;

(* renamme a file, delete if needed *)
function _File_Rename (_File,_NewFile : string;_Delete : byte) : boolean;
var f : file;
begin
 if FileExists (_File) then
 begin
  if FileExists (_NewFile) then
  begin
   if _Delete = 0 then
    Result := false
   else
    _File_Delete (_NewFile);
  end;
  assignfile (f,_File);
  {$I-};
   Rename (f,_NewFile);
  {$I+};
  Result := (ioresult = 0);
 end
 else
  Result := false;
end;

(* copy a file *)
function _File_Copy_UnCompress (FromFile,ToFile : string;Switch : byte) : byte;
var Tmp : integer;
    FromF, ToF: file;
    NumRead, NumWritten: Word;
    iHandle : Integer;
    iNewHandle : Integer;
    iReturn : Integer;
    iLongReturn : LongInt;
    pFrom : Array[0..256] of Char;
    pTo : Array[0..256] of Char;
begin
 Tmp := 0;
 If (FileExists (ToFile)) and (Switch = 0) then
  Tmp := 1
 else
 begin
  StrPCopy( pFrom, FromFile );
  iReturn := GetExpandedName( pFrom, pTo );
  if iReturn = -1 then
   Tmp := 2
  else
  begin
   if iReturn = -2 then
    Tmp := 3
   else
   begin
    if ( StrEnd( pTo ) - pTo ) > 0 then
    begin
     ToFile := ExtractFilePath( ToFile ) +
               ExtractFileName( strPas( pTo ) );
     iHandle := FileOpen( FromFile, fmShareDenyWrite );
     LZInit (iHandle);
     if iHandle < 1 then
      Tmp := 2
     else
     begin
      iNewHandle := FileCreate( ToFile );
      if iNewHandle < 1 then
       Tmp := 3
      else
      begin
       iLongReturn := LZCopy( iHandle , iNewHandle );
       if iLongReturn = LZERROR_UNKNOWNALG then
        Tmp := 5
       else
       begin
        FileClose( iHandle );
        FileClose( iNewHandle );
        LZClose (iHandle);
       end;
      end;
     end;
    end
    else
     Tmp := 3;
   end
  end;
 end;
 _File_Copy_UnCompress := Tmp;
end;

(* just copy a file *)
function _File_Copy(source,dest: String): Boolean;
var
  fSrc,fDst,len: Integer;
  size: Longint;
  buffer: packed array [0..2047] of Byte;
begin
  if pos ('\\',source) <> 0 then delete (source,pos ('\\',source),1);
  if pos ('\\',dest) <> 0 then delete (dest,pos ('\\',dest),1);
  Result := False;
  if source <> dest then
  begin
   fSrc := FileOpen(source,fmOpenRead);
   if fSrc >= 0 then
   begin
    size := FileSeek(fSrc,0,2);
    FileSeek(fSrc,0,0);
    fDst := FileCreate(dest);
    if fDst >= 0 then begin
     while size > 0 do
     begin
       len := FileRead(fSrc,buffer,sizeof(buffer));
       FileWrite(fDst,buffer,len);
       size := size - len;
     end;
     FileSetDate(fDst,FileGetDate(fSrc));
     FileClose(fDst);
     FileSetAttr(dest,FileGetAttr(source));
     Result := True;
    end;
    FileClose(fSrc);
   end;
  end;
end;

(* move a file *)
function _File_Move (_Source,_Destination : string) : boolean;
var Tmp : boolean;
begin
 tmp := _File_Copy (_Source,_Destination);
 if Tmp = true then
  if _File_Delete (_Source) = true then
   Tmp := true
  else
   Tmp := false;
 Result := Tmp;
end;

(* Get file attributes *)
function _File_Get_Attrib (_File : string) : byte;
var Tmp : byte;
    Att : integer;
begin
 if FileExists (_File) then
 begin
  Att := FileGetAttr (_File);
  if Att <> -1 then
  begin
   Tmp := 0;
   if (Att AND faReadOnly) = faReadOnly then Tmp := Tmp + 1;
   if (Att AND faHidden) = faHidden then Tmp := Tmp + 2;
   if (Att AND faSysFile) = faSysFile then Tmp := Tmp + 4;
   if (Att AND faArchive) = faArchive then Tmp := Tmp + 8;
   Result := Tmp;
  end
  else
   Result := 255;
 end
 else
  Result := 255;
end;

(* Set file attributes *)
function _File_Set_Attrib (_File : string;_Attrib : byte) : boolean;
var Tmp : integer;
begin
 if FileExists (_File) then
 begin
  Tmp := 0;
  if _Attrib and 1 = 1 then Tmp := tmp OR faReadOnly;
  if _Attrib and 2 = 2 then Tmp := tmp OR faHidden;
  if _Attrib and 4 = 4 then Tmp := tmp OR faSysFile;
  if _Attrib and 8 = 8 then Tmp := tmp OR faArchive;
  Result := FileSetAttr (_File,Tmp) = 0;
 end
 else
  Result := false
end;

(* Get datestamp of file *)
function _File_Get_Date (_File : string) : string;
var f   : file;
    Hdl : integer;
    Tmp : string;
    Dte : integer;
    Dat : TDateTime;
begin
 Tmp := '';
 Hdl := FileOpen(_File, fmOpenRead or fmShareDenyNone);
 if Hdl > 0 then
 begin
  Dte := FileGetDate (Hdl);
  FileClose (Hdl);
  Dat := FileDateToDateTime (Dte);
  Tmp := DateToStr (Dat);
  while pos ('/',Tmp) <> 0 do delete (Tmp,pos ('/',Tmp),1);
  if length (tmp) > 6 then delete (Tmp,5,2);
 end;
 Result := Tmp;
end;

(* Set datestamp of file *)
function _File_Set_Date (_File,_Date : string) : boolean;
var f   : file;
    Hdl : integer;
    Dte : integer;
    Dat : TDateTime;
    Att : integer;
begin
 Att := _File_Get_Attrib (_File);
 if (Att AND 1) <> 1 then Att := 0
                     else _File_Set_Attrib (_File,0);
 Hdl := FileOpen(_File, fmOpenReadWrite or fmShareDenyNone);
 if Hdl > 0 then
 begin
  if length (_Date) < 8 then Insert ('19',_Date,5);
  if pos ('/',_Date) = 0 then
   _Date := copy (_Date,1,2) + '/' +
            copy (_Date,3,2) + '/' +
            copy (_Date,5,4);
  Dat := StrToDateTime (_Date);
  Dte := DateTimeToFileDate (Dat);
  Result := FileSetDate (Hdl,Dte) = 0;
  FileClose (Hdl);
  if Att <> 0 then
    _File_Set_Attrib (_File,Att);
 end
 else
 begin
  if Att <> 0 then
    _File_Set_Attrib (_File,Att);
  Result := False;
 end;
end;

(* return size of a file *)
function _File_Get_Size (_File : string) : longint;
var f: file of Byte;
    a : integer;
begin
 if FileExists (_File) then
 begin
  a := _File_Get_Attrib (_File);
  if (a AND 1) = 1 then
   _File_Set_Attrib (_File,0)
  else
   a := 0;
  AssignFile(f,_File);
  {$I-};
   Reset(f);
  {$I+};
  if ioresult = 0 then
  begin
   Result := FileSize(f);
   CloseFile(f);
   if a <> 0 then
    _File_Set_Attrib (_File,a);
  end
  else
  begin
   if a <> 0 then
    _File_Set_Attrib (_File,a);
   Result := -1;
  end;
 end
 else
  Result := -1;
end;

(* lancement d'une application *)
function _File_Start (AppName,AppParams,AppDir : string) : integer;
var Tmp : Integer;
    zFileName : array [0 .. 79] of char;
    zParams   : array [0 .. 79] of char;
    zDir      : array [0 .. 79] of Char;
begin
 Tmp := 0;
 StrPCopy (zFileName,AppName);
 StrPCopy (zParams,AppParams);
 StrPCopy (zDir,AppDir);
 Tmp := ShellExecute (0,Nil,zFileName,zParams,zDir,1);
 _File_Start := Tmp;
end;



(*****************)
(* miscellaneous *)
(*****************)

(* return Windows directory *)
function _Get_WindowsDir : string;
var Tmp : array [0 .. 255] of char;
    Ret : string;
begin
 if GetWindowsDirectory (Tmp,255) <> 0 then
 begin
  Ret := StrPas (Tmp);
  if Ret [length (Ret)] = '\' then
   Ret := copy (Ret,1,length (Ret) - 1);
  Result := Ret;
 end
 else
  Result := '';
end;

(* return Windows system directory *)
function _Get_SystemDir : string;
var Tmp : array [0 .. 255] of char;
    Ret : string;
begin
 if GetSystemDirectory (Tmp,255) <> 0 then
 begin
  Ret := StrPas (Tmp);
  if Ret [length (Ret)] = '\' then
   Ret := copy (Ret,1,length (Ret) - 1);
  Result := Ret;
 end
 else
  Result := '';
end;

(* return Windows Temp directory *)
function _Get_TempDir : string;
var Tmp : array [0 .. 255] of char;
    Ret : string;
begin
 if GetTempPath (255,Tmp) <> 0 then
 begin
  Ret := StrPas (Tmp);
  if Ret [length (Ret)] = '\' then
   Ret := copy (Ret,1,length (Ret) - 1);
  Result := Ret;
 end
 else
  Result := '';
end;

(* return application directory *)
function _Get_Apps_Dir (ExeName : PChar) : string;
var Hdl : THandle;
    Nam : PChar;
    Fil : array [0..255] of char;
    Siz : integer;
    Ret : integer;
    Pas : string;
    Pat : string [79];
begin
 Pat := '';
 Hdl := GetModuleHandle (ExeName);
 Ret := GetModuleFileName (Hdl,Fil,Siz);
 Pas := StrPas (Fil);
 Pat := ExtractFilePath (Pas);
 Delete (Pat,1,2);
 if Pat [length (Pat)] = '\' then
  Pat := copy (Pat,1,length (Pat) - 1);
 Result := Pat;
end;

(* return dirve of current application *)
function _Get_Apps_Drive (ExeName : PChar) : string;
var Hdl : THandle;
    Nam : PChar;
    Fil : array [0..255] of char;
    Siz : integer;
    Ret : integer;
    Pas : string;
    Drv : string [02];
begin
 Drv := '';
 Hdl := GetModuleHandle (ExeName);
 Ret := GetModuleFileName (Hdl,Fil,Siz);
 Pas := StrPas (Fil);
 Drv := ExtractFilePath (Pas);
 _Get_Apps_Drive := Drv;
end;

(* return windows version as a real *)
function _Get_WindowsVer : real;
var tempo   : string;
    Temp    : real;
    err     : integer;
    struct  : TOSVersionInfo;
begin
 struct.dwOSVersionInfoSize := sizeof (Struct);
 struct.dwMajorVersion := 0;
 struct.dwMinorVersion := 0;
 GetVersionEx (Struct);
 Tempo  := inttostr (Struct.dwMajorVersion) + '.' + inttostr (Struct.dwMinorVersion);
 val (tempo,temp,err);
 Result := Temp;
end;

(* return type of platform *)
function _Get_WindowsPlatform : string;
var tempo   : string;
    Temp    : string;
    err     : integer;
    struct  : TOSVersionInfo;
begin
 struct.dwOSVersionInfoSize := sizeof (Struct);
 struct.dwPlatformId := 0;
 GetVersionEx (Struct);
 case struct.dwPlatformid of
  ver_platform_win32s : temp := 'Win32S';
  ver_platform_win32_windows : temp := 'Win32';
  ver_platform_win32_nt : temp := 'WinNT';
 end;
 Result := Temp;
end;

(* get extra information *)
function _Get_WindowsExtra : string;
var tempo   : string;
    Temp    : string;
    err     : integer;
    struct  : TOSVersionInfo;
begin
 struct.dwOSVersionInfoSize := sizeof (Struct);
 struct.dwMajorVersion := 0;
 struct.dwMinorVersion := 0;
 struct.dwBuildNumber := 0;
 struct.dwPlatformId := 0;
 GetVersionEx (Struct);
 Temp := '';
 Temp := strPas (Struct.szCSDVersion);
 Result := Temp;
end;

(* return windows build as a real *)
function _Get_WindowsBuild : real;
var tempo   : string;
    Temp    : real;
    err     : integer;
    struct  : TOSVersionInfo;
begin
 struct.dwOSVersionInfoSize := sizeof (Struct);
 struct.dwBuildNumber := 0;
 GetVersionEx (Struct);
 tempo := inttostr (struct.dwBuildNumber AND $0000FFFF);
 val (tempo,temp,err);
 Result := Temp;
end;

begin
end.

[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]