pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
efd629624c2070061827a607e5cf60c427276b51
lazarus-ccr/components/systools/source/windows_only/run/stsystem.pas
wp_xxyyzz 2f86a4b7f9 systools: Add windows-specific units to new package laz_systoolswin 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6148 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2018-01-17 23:58:23 +00:00

1852 lines
53 KiB
ObjectPascal
Raw Blame History

// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* SysTools: StSystem.pas 4.04 *}
{*********************************************************}
{* SysTools: Assorted system level routines *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
{$I StDefine.inc}
unit StSystem;
interface
uses
Windows, SysUtils, Classes,
{$IFDEF FPC}
FileUtil,
{$ELSE}
{$IFDEF Version6} {$WARN UNIT_PLATFORM OFF} {$ENDIF}
FileCtrl,
{$IFDEF Version6} {$WARN UNIT_PLATFORM ON} {$ENDIF}
{$ENDIF}
StConst, StBase, StUtils, StDate, StStrL;
{$IFNDEF VERSION6}
const
PathDelim = '\';
DriveDelim = ':';
PathSep = ';';
{$ENDIF VERSION6}
const
StPathDelim = PathDelim; { Delphi/Linux constant }
StPathSep = PathSep; { Delphi/Linux constant }
StDriveDelim = DriveDelim;
StDosPathDelim = '\';
StUnixPathDelim = '/';
StDosPathSep = ';';
StUnixPathSep = ':';
StDosAnyFile = '*.*';
StUnixAnyFile = '*';
StAnyFile = {$IFDEF LINUX} StUnixAnyFile; {$ELSE} StDosAnyFile; {$ENDIF}
StThisDir = '.';
StParentDir = '..';
type
DiskClass = ( Floppy360, Floppy720, Floppy12, Floppy144, OtherFloppy,
HardDisk, RamDisk, UnknownDisk, InvalidDrive, RemoteDrive, CDRomDisk );
{This enumerated type defines the nine classes of disks that can be
identified by GetDiskClass, as well as several types used as error
indications}
PMediaIDType = ^MediaIDType;
MediaIDType = packed record
{This type describes the information that DOS 4.0 or higher writes
in the boot sector of a disk when it is formatted}
InfoLevel : Word; {Reserved for future use}
SerialNumber : LongInt; {Disk serial number}
VolumeLabel : array[0..10] of Char; {Disk volume label}
FileSystemID : array[0..7] of Char; {String for internal use by the OS}
end;
TIncludeItemFunc = function (const SR : TSearchRec;
ForInclusion : Boolean; var Abort : Boolean) : Boolean;
{Function type for the routine passed to EnumerateFiles and
EnumerateDirectories. It will be called in two ways: to request
confirmation to include the entity described in SR into the
string list (ForInclusion = true); or to ask whether to recurse
into a particular subdirectory (ForInclusion = false).}
{**** Routine Declarations ****}
{CopyFile}
function CopyFile(const SrcPath, DestPath : String) : Cardinal;
{-Copy a file.}
{CreateTempFile}
function CreateTempFile(const aFolder : String;
const aPrefix : String) : String;
{-Creates a temporary file.}
{DeleteVolumeLabel}
function DeleteVolumeLabel(Drive : Char) : Cardinal;
{-Deletes an existing volume label on Drive. Returns 0 for success,
or OS error code.}
{EnumerateDirectories}
procedure EnumerateDirectories(const StartDir : String; FL : TStrings; {!!.02}
SubDirs : Boolean;
IncludeItem : TIncludeItemFunc);
{-Retrieves the complete path name of directories on requested file
system path.}
{EnumerateFiles}
procedure EnumerateFiles(const StartDir : String; FL : TStrings; {!!.02}
SubDirs : Boolean;
IncludeItem : TIncludeItemFunc);
{-Retrieves the complete path name of files in a requested file system path.}
{FileHandlesLeft}
function FileHandlesLeft(MaxHandles : Cardinal) : Cardinal;
{-Return the number of available file handles.}
{FileMatchesMask}
function FileMatchesMask(const FileName, FileMask : String ) : Boolean;
{-see if FileName matches FileMask}
{FileTimeToStDateTime}
function FileTimeToStDateTime(FileTime : LongInt) : TStDateTimeRec;
{-Converts a DOS date-time value to TStDate and TStTime values.}
{FindNthSlash}
function FindNthSlash( const Path : String; n : Integer ) : Integer;
{ return the position of the character just before the nth slash }
{FlushOsBuffers}
function FlushOsBuffers(Handle : Integer) : Boolean;
{-Flush the OS buffers for the specified file handle.}
{GetCurrentUser}
function GetCurrentUser : String;
{-Obtains current logged in username}
{GetDiskClass}
function GetDiskClass(Drive : Char) : DiskClass;
{-Return the disk class for the specified drive.}
{GetDiskInfo}
function GetDiskInfo(Drive : Char; var ClustersAvailable, TotalClusters,
BytesPerSector, SectorsPerCluster : Cardinal) : Boolean;
{-Return technical information about the specified drive.}
{GetDiskSpace}
{$IFDEF CBuilder}
function GetDiskSpace(Drive : Char;
var UserSpaceAvail : Double; {space available to user}
var TotalSpaceAvail : Double; {total space available}
var DiskSize : Double) : Boolean;{disk size}
{-Return space information about the drive.}
{$ELSE}
function GetDiskSpace(Drive : Char;
var UserSpaceAvail : Comp; {space available to user}
var TotalSpaceAvail : Comp; {total space available}
var DiskSize : Comp) : Boolean;{disk size}
{-Return space information about the drive.}
{$ENDIF}
{GetFileCreateDate}
function GetFileCreateDate(const FileName : String) :
TDateTime;
{-Obtains file system time of file creation.}
{GetFileLastAccess}
function GetFileLastAccess(const FileName : String) :
TDateTime;
{-Obtains file system time of last file access.}
{GetFileLastModify}
function GetFileLastModify(const FileName : String) :
TDateTime;
{-Obtains file system time of last file modification.}
{GetHomeFolder}
function GetHomeFolder(aForceSlash : Boolean) : String;
{-Obtains the "Home Folder" for the current user}
{$IFNDEF CBuilder}
{GetLongPath}
function GetLongPath(const APath : String) : String;
{-Returns the long filename version of a provided path.}
{$ENDIF}
{GetMachineName}
function GetMachineName : String;
{-Returns the "Machine Name" for the current computer }
{GetMediaID}
function GetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
{-Get the media information (Volume Label, Serial Number) for the specified drive}
{GetParentFolder}
function GetParentFolder(const APath : String; aForceSlash : Boolean) : String;
{-return the parent directory for the provided directory }
{GetShortPath}
function GetShortPath(const APath : String) : String;
{-Returns the short filename version of a provided path.}
{GetSystemFolder}
function GetSystemFolder(aForceSlash : Boolean) : String;
{-Returns the path to the Windows "System" folder".}
{GetTempFolder}
function GetTempFolder(aForceSlash : boolean) : String;
{-Returns the path to the system temporary folder.}
{GetWindowsFolder}
function GetWindowsFolder(aForceSlash : boolean) : String;
{-Returns the path to the main "Windows" folder.}
{GetWorkingFolder}
function GetWorkingFolder(aForceSlash : boolean) : String;
{-Returns the current working directory.}
{GlobalDateTimeToLocal}
function GlobalDateTimeToLocal(const UTC: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
{-adjusts a global date/time (UTC) to the local date/time}
{IsDirectory}
function IsDirectory(const DirName : String) : Boolean;
{-Return True if DirName is a directory.}
{IsDirectoryEmpty}
function IsDirectoryEmpty(const S : String) : Integer;
{-checks if there are any entries in the directory}
{IsDriveReady}
function IsDriveReady(Drive : Char) : Boolean;
{-determine if requested drive is accessible }
{IsFile}
function IsFile(const FileName : String) : Boolean;
{-Determines if the provided path specifies a file.}
{IsFileArchive}
function IsFileArchive(const S : String) : Integer;
{-checks if file's archive attribute is set}
{IsFileHidden}
function IsFileHidden(const S : String) : Integer;
{-checks if file's hidden attribute is set}
{IsFileReadOnly}
function IsFileReadOnly(const S : String) : Integer;
{-checks if file's readonly attribute is set}
{IsFileSystem}
function IsFileSystem(const S : String) : Integer;
{-checks if file's system attribute is set}
{LocalDateTimeToGlobal}
function LocalDateTimeToGlobal(const DT1: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
{-adjusts a local date/time to the global (UTC) date/time}
{ReadVolumeLabel}
function ReadVolumeLabel(var VolName : String; Drive : Char) : Cardinal;
{-Get the volume label for the specified drive.}
{SameFile}
function SameFile(const FilePath1, FilePath2 : String; var ErrorCode : Integer) : Boolean;
{-Return True if FilePath1 and FilePath2 refer to the same physical file.}
{SetMediaID} {!!!! does not work on NT/2000 !!!!}
function SetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
{-Set the media ID record for the specified drive.}
{SplitPath}
procedure SplitPath(const APath : String; Parts : TStrings);
{-Splits the provided path into its component sub-paths}
{StDateTimeToFileTime}
function StDateTimeToFileTime(const FileTime : TStDateTimeRec) : LongInt; {!!.02}
{-Converts an TStDate and TStTime to a DOS date-time value.}
{StDateTimeToUnixTime}
function StDateTimeToUnixTime(const DT1 : TStDateTimeRec) : Longint; {!!.02}
{-converts a TStDateTimeRec to a time in Unix base (1970)}
{UnixTimeToStDateTime}
function UnixTimeToStDateTime(UnixTime : Longint) : TStDateTimeRec;
{-converts a time in Unix base (1970) to a TStDateTimeRec}
{ValidDrive}
function ValidDrive(Drive : Char) : Boolean;
{-Determine if the drive is a valid drive.}
{WriteVolumeLabel}
function WriteVolumeLabel(const VolName : String; Drive : Char) : Cardinal;
{-Sets the volume label for the specified drive.}
(*
{$EXTERNALSYM GetLongPathNameA}
function GetLongPathNameA(lpszShortPath: PAnsiChar; lpszLongPath: PAnsiChar;
cchBuffer: DWORD): DWORD; stdcall;
{$EXTERNALSYM GetLongPathNameW}
function GetLongPathNameW(lpszShortPath: PWideChar; lpszLongPath: PWideChar;
cchBuffer: DWORD): DWORD; stdcall;
{$EXTERNALSYM GetLongPathName}
function GetLongPathName(lpszShortPath: PChar; lpszLongPath: PChar;
cchBuffer: DWORD): DWORD; stdcall;
*)
implementation
const
FILE_ANY_ACCESS = 0;
METHOD_BUFFERED = 0;
IOCTL_DISK_BASE = $00000007;
VWIN32_DIOC_DOS_IOCTL = 1;
IOCTL_DISK_GET_MEDIA_TYPES = ((IOCTL_DISK_BASE shl 16) or
(FILE_ANY_ACCESS shl 14) or ($0300 shl 2) or METHOD_BUFFERED);
procedure StChDir(const S: String); {!!.02}
{ wrapper for Delphi ChDir to handle a bug in D6}
{$IFDEF VER140}
var
Rslt : Integer;
{$ENDIF}
begin
{$IFNDEF VER140}
Chdir(S);
{$ELSE}
{$I-}
Chdir(S);
if IOResult <> 0 then begin
Rslt := GetLastError;
SetInOutRes(Rslt);
end;
{$I+}
{$ENDIF}
end;
{CopyFile}
function CopyFile(const SrcPath, DestPath : String) : Cardinal;
{-Copy the file specified by SrcPath into DestPath. DestPath must specify
a complete filename, it may not be the name of a directory without the
file portion. This a low level routine, and the input pathnames are not
checked for validity.}
const
BufferSize = 4 * 1024;
var
BytesRead, BytesWritten : LongInt;
FileDate : LongInt;
Src, Dest, Mode, SaveFAttr : Integer;
Buffer : Pointer;
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
Src := 0;
Dest := 0;
Buffer := nil;
Result := 1;
try
GetMem(Buffer, BufferSize);
Mode := FileMode and $F0;
SaveFAttr := FileGetAttr(SrcPath);
if SaveFAttr < 0 then begin
Result := 1;
Exit;
end;
Src := FileOpen(SrcPath, Mode);
if Src < 0 then begin
Result := 1; {unable to access SrcPath}
Exit;
end;
Dest := FileCreate(DestPath);
if Dest < 0 then begin
Result := 2; {unable to open DestPath}
Exit;
end;
repeat
BytesRead := FileRead(Src, Buffer^, BufferSize);
if (BytesRead = -1) then begin
Result := 3; {error reading from Src}
Exit;
end;
BytesWritten := FileWrite(Dest, Buffer^, BytesRead);
if (BytesWritten = -1) or
(BytesWritten <> BytesRead) then begin
Result := 4; {error writing to Dest}
Exit;
end;
until BytesRead < BufferSize;
FileDate := FileGetDate(Src);
if FileDate = -1 then begin
Result := 5; {error getting SrcPath's Date/Time}
Exit;
end;
FileSetDate(Dest, FileDate);
FileSetAttr(DestPath, SaveFAttr);
Result := 0;
finally
if Assigned(Buffer) then
FreeMem(Buffer, BufferSize);
if Src > 0 then FileClose(Src);
if Dest > 0 then begin
FileClose(Dest);
if Result <> 0 then SysUtils.DeleteFile(DestPath);
end;
end;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{CreateTempFile}
function CreateTempFile(const aFolder : String;
const aPrefix : String) : String;
{-Creates a temporary file.}
var
TempFileNameZ : array [0..MAX_PATH] of Char;
TempDir : String;
begin
TempDir := aFolder;
if not DirectoryExists(TempDir) then
TempDir := GetTempFolder(True);
if not DirectoryExists(TempDir) then
TempDir := GetWorkingFolder(True);
if (GetTempFileName(PChar(TempDir), PChar(aPrefix), 0,
TempFileNameZ) = 0)
then
{$IFDEF Version6}
RaiseLastOSError;
{$ELSE}
RaiseLastWin32Error;
{$ENDIF}
Result := TempFileNameZ;
end;
{DeleteVolumeLabel}
function DeleteVolumeLabel(Drive : Char) : Cardinal;
{-Deletes an existing volume label on Drive. Returns 0 for success,
or OS error code.}
var
Root : array[0..3] of Char;
begin
StrCopy(Root, '%:\');
Root[0] := Drive;
if Windows.SetVolumeLabel(Root, '') then
Result := 0
else Result := GetLastError;
end;
{EnumerateDirectories}
procedure EnumerateDirectories(const StartDir : String; FL : TStrings; {!!.02}
SubDirs : Boolean;
IncludeItem : TIncludeItemFunc);
{-Retrieves the complete path name of directories on requested file
system path.}
var
Abort : Boolean;
procedure SearchBranch;
var
SR : TSearchRec;
Error : SmallInt;
Dir : String;
begin
Error := FindFirst(StDosAnyFile, faDirectory, SR);
if Error = 0 then begin
GetDir(0, Dir);
if Dir[Length(Dir)] <> StDosPathDelim then
Dir := Dir + StDosPathDelim;
Abort := False;
while (Error = 0) and not Abort do begin
try
if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then begin
if (SR.Attr and faDirectory = faDirectory) and
(SR.Name <> StThisDir) and (SR.Name <> StParentDir) then
FL.Add(Dir + SR.Name);
end;
except
on EOutOfMemory do
raise EOutOfMemory.Create(stscSysStringListFull);
end;
Error := FindNext(SR);
end;
FindClose(SR);
end;
if not Abort and SubDirs then begin
Error := FindFirst(StDosAnyFile, faDirectory, SR);
if Error = 0 then begin
Abort := False;
while (Error = 0) and not Abort do begin
if ((SR.Attr and faDirectory = faDirectory) and
(SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
StChDir(SR.Name);
SearchBranch;
StChDir(StParentDir);
end;
end;
Error := FindNext(SR);
end;
FindClose(SR);
end;
end;
end;
var
OrgDir : String;
begin
if IsDirectory(StartDir) then
begin
GetDir(0, OrgDir);
try
StChDir(StartDir);
SearchBranch;
finally
StChDir(OrgDir);
end;
end else
raise Exception.Create(stscSysBadStartDir);
end;
{EnumerateFiles}
procedure EnumerateFiles(const StartDir : String; {!!.02}
FL : TStrings;
SubDirs : Boolean;
IncludeItem : TIncludeItemFunc);
{-Retrieves the complete path name of files in a requested file system path.}
var
Abort : Boolean;
procedure SearchBranch;
var
SR : TSearchRec;
Error : SmallInt;
Dir : String;
begin
Error := FindFirst(StDosAnyFile, faAnyFile, SR);
if Error = 0 then begin
GetDir(0, Dir);
if Dir[Length(Dir)] <> StDosPathDelim then
Dir := Dir + StDosPathDelim;
Abort := False;
while (Error = 0) and not Abort do begin
try
if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then
FL.Add(Dir + SR.Name);
except
on EOutOfMemory do
begin
raise EOutOfMemory.Create(stscSysStringListFull);
end;
end;
Error := FindNext(SR);
end;
FindClose(SR);
end;
if not Abort and SubDirs then begin
Error := FindFirst(StDosAnyFile, faAnyFile, SR);
if Error = 0 then begin
Abort := False;
while (Error = 0) and not Abort do begin
if ((SR.Attr and faDirectory = faDirectory) and
(SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
StChDir(SR.Name);
SearchBranch;
StChDir(StParentDir);
end;
end;
Error := FindNext(SR);
end;
FindClose(SR);
end;
end;
end;
var
OrgDir : String;
begin
if IsDirectory(StartDir) then
begin
GetDir(0, OrgDir);
try
StChDir(StartDir);
SearchBranch;
finally
StChDir(OrgDir);
end;
end else
raise Exception.Create(stscSysBadStartDir);
end;
{FileHandlesLeft}
{.$HINTS OFF}
function FileHandlesLeft(MaxHandles : Cardinal) : Cardinal;
{-Returns the number of available file handles. In 32-bit, this can be a
large number. Use MaxHandles to limit the number of handles counted.
The maximum is limited by HandleLimit - you can increase HandleLimit if
you wish. A temp file is required because Win95 seems to have some
limit on the number of times you can open NUL.}
const
HandleLimit = 1024;
type
PHandleArray = ^THandleArray;
THandleArray = array[0..Pred(HandleLimit)] of Integer;
var
Handles : PHandleArray;
MaxH, I : Integer;
TempPath, TempFile : PChar;
begin
Result := 0;
MaxH := MinLong(HandleLimit, MaxHandles);
TempFile := nil;
TempPath := nil;
Handles := nil;
try
TempFile := StrAlloc(MAX_PATH+1); {!!.01}
TempPath := StrAlloc(MAX_PATH+1); {!!.01}
GetMem(Handles, MaxH * SizeOf(Integer));
GetTempPath(MAX_PATH, TempPath); {!!.01}
GetTempFileName(TempPath, 'ST', 0, TempFile);
for I := 0 to Pred(MaxH) do begin
Handles^[I] := CreateFile(TempFile, 0, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_FLAG_DELETE_ON_CLOSE, 0);
if Handles^[I] <> LongInt(INVALID_HANDLE_VALUE) then
Inc(Result) else Break;
end;
for I := 0 to Pred(Result) do
FileClose(Handles^[I]);
finally
if Assigned(Handles) then
FreeMem(Handles, MaxH * SizeOf(Integer));
StrDispose(TempFile);
StrDispose(TempPath);
end;
end;
{.$HINTS ON}
{ -------------------------------------------------------------------------- }
function StPatternMatch(const Source : string; iSrc : Integer; {!!.02}
const Pattern : string; iPat : Integer ) : Boolean; {!!.02}
{ recursive routine to see if the source string matches
the pattern. Both ? and * wildcard characters are allowed.
Compares Source from iSrc to Length(Source) to
Pattern from iPat to Length(Pattern)}
var
Matched : Boolean;
k : Integer;
begin
{$R-}
if Length( Source ) = 0 then begin
Result := Length( Pattern ) = 0;
Exit;
end;
if iPat = 1 then begin
if ( CompareStr( Pattern, StDosAnyFile) = 0 ) or
( CompareStr( Pattern, StUnixAnyFile ) = 0 ) then begin
Result := True;
Exit;
end;
end;
if Length( Pattern ) = 0 then begin
Result := (Length( Source ) - iSrc + 1 = 0);
Exit;
end;
while True do begin
if ( Length( Source ) < iSrc ) and
( Length( Pattern ) < iPat ) then begin
Result := True;
Exit;
end;
if Length( Pattern ) < iPat then begin
Result := False;
Exit;
end;
if (iPat <= Length(Pattern)) and (Pattern[iPat] = '*') then begin
k := iPat;
if ( Length( Pattern ) < iPat + 1 ) then begin
Result := True;
Exit;
end;
while True do begin
Matched := StPatternMatch( Source, k, Pattern, iPat + 1 );
if Matched or ( Length( Source ) < k ) then begin
Result := Matched;
Exit;
end;
inc( k );
end;
end
else begin
if ((Pattern[iPat] = '?') and
( Length( Source ) <> iSrc - 1 ) ) or
( Pattern[iPat] = Source[iSrc] ) then begin
inc( iPat );
inc( iSrc );
end
else begin
Result := False;
Exit;
end;
end;
end;
{$R+}
end;
{FileMatchesMask}
function FileMatchesMask(const FileName, FileMask : String ) : Boolean;
{-see if FileName matches FileMask}
var
DirMatch : Boolean;
MaskDir : String;
LFN, LFM : String;
begin
LFN := UpperCase( FileName );
LFM := UpperCase( FileMask );
MaskDir := ExtractFilePath( LFN );
if MaskDir = '' then
DirMatch := True
else
DirMatch := StPatternMatch( ExtractFilePath( LFN ), 1, MaskDir, 1 );
Result := DirMatch and StPatternMatch( ExtractFileName( LFN ), 1,
ExtractFileName( LFM ), 1 );
end;
{FileTimeToStDateTime}
function FileTimeToStDateTime(FileTime : LongInt) : TStDateTimeRec;
{-Converts a DOS date-time value to TStDate and TStTime values.}
var
DDT : TDateTime;
begin
DDT := FileDateToDateTime(FileTime);
Result.D := DateTimeToStDate(DDT);
Result.T := DateTimeToStTime(DDT);
end;
{FindNthSlash}
function FindNthSlash(const Path : String; n : Integer) : Integer;
{ return the position of the character just before the nth slash }
var
i : Integer;
Len : Integer;
iSlash : Integer;
begin
Len := Length( Path );
Result := Len;
iSlash := 0;
i := 1;
while i <= Len do begin
if Path[i] = StPathDelim then begin
inc( iSlash );
if iSlash = n then begin
Result := pred( i );
break;
end;
end;
inc( i );
end;
end;
{FlushOsBuffers}
{-Flush the OS buffers for the specified file handle.}
function FlushOsBuffers(Handle : Integer) : Boolean;
{-Flush the OS's buffers for the specified file}
begin
Result := FlushFileBuffers(Handle);
if not Result then
{$IFDEF Version6}
RaiseLastOSError;
{$ELSE}
RaiseLastWin32Error;
{$ENDIF}
end;
{GetCurrentUser}
function GetCurrentUser : String;
{-Obtains current logged in username}
var
Size : DWORD;
UserNameZ : array [0..511] of Char;
begin
Size := Length(UserNameZ);
if not GetUserName(UserNameZ, Size) then
{$IFDEF Version6}
RaiseLastOSError;
{$ELSE}
RaiseLastWin32Error;
{$ENDIF}
// SetString(Result, UserNameZ, Size); {!!.02}
SetString(Result, UserNameZ, StrLen(UserNameZ)); {!!.02}
end;
{GetDiskClass}
function GetDiskClass(Drive : Char) : DiskClass;
{-Return the disk class for the specified drive.}
type
TMediaType =
( Unknown, { Format is unknown }
F5_1Pt2_512, { 5.25", 1.2MB, 512 bytes/sector }
F3_1Pt44_512, { 3.5", 1.44MB, 512 bytes/sector }
F3_2Pt88_512, { 3.5", 2.88MB, 512 bytes/sector }
F3_20Pt8_512, { 3.5", 20.8MB, 512 bytes/sector }
F3_720_512, { 3.5", 720KB, 512 bytes/sector }
F5_360_512, { 5.25", 360KB, 512 bytes/sector }
F5_320_512, { 5.25", 320KB, 512 bytes/sector }
F5_320_1024, { 5.25", 320KB, 1024 bytes/sector }
F5_180_512, { 5.25", 180KB, 512 bytes/sector }
F5_160_512, { 5.25", 160KB, 512 bytes/sector }
RemovableMedia, { Removable media other than floppy }
FixedMedia ); { Fixed hard disk media }
PDiskGeometry = ^TDiskGeometry;
TDiskGeometry = record
Cylinders1 : DWORD;
Cylinders2 : Integer;
MediaType : TMediaType;
TracksPerCylinder : DWORD;
SectorsPerTrack : DWORD;
BytesPerSector : DWORD;
end;
var
Root : array[0..3] of Char;
Root2 : array[0..6] of Char;
ReturnedByteCount,
SectorsPerCluster,
BytesPerSector,
NumberOfFreeClusters,
TotalNumberOfClusters : DWORD;
SupportedGeometry : array[1..20] of TDiskGeometry;
HDevice : THandle;
I : Integer;
VerInfo : TOSVersionInfo;
Found : Boolean;
begin
FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
Result := InvalidDrive;
Found := False;
StrCopy(Root, '%:\');
Root[0] := Drive;
case GetDriveType(Root) of
0 : Result := UnknownDisk;
1 : Result := InvalidDrive;
DRIVE_REMOVABLE :
begin
GetVersionEx(VerInfo);
if VerInfo.dwPlatformID = VER_PLATFORM_WIN32_NT then begin
StrCopy(Root2, '\\.\%:');
Root2[4] := Drive;
HDevice := CreateFile(Root2, 0, FILE_SHARE_READ,
nil, OPEN_ALWAYS, 0, 0);
if HDevice = INVALID_HANDLE_VALUE then Exit;
if not DeviceIoControl(HDevice, IOCTL_DISK_GET_MEDIA_TYPES, nil, 0,
@SupportedGeometry, SizeOf(SupportedGeometry), ReturnedByteCount, nil)
then Exit;
for I := 1 to (ReturnedByteCount div SizeOf(TDiskGeometry)) do begin
case SupportedGeometry[I].MediaType of
F5_1Pt2_512 : begin
Result := Floppy12;
Exit;
end;
F3_1Pt44_512 : begin
Result := Floppy144;
Exit;
end;
F3_720_512 : begin
Result := Floppy720;
Found := True;
end;
F5_360_512 : begin
Result := Floppy360;
Found := True;
end;
end;
end;
if Found then Exit;
Result := OtherFloppy;
end else begin
GetDiskFreeSpace(Root, SectorsPerCluster, BytesPerSector,
NumberOfFreeClusters, TotalNumberOfClusters);
case TotalNumberOfClusters of
354 : Result := Floppy360;
713,
1422 : Result := Floppy720;
2371 : Result := Floppy12;
2847 : Result := Floppy144;
else Result := OtherFloppy;
end;
end;
end;
DRIVE_FIXED : Result := HardDisk;
DRIVE_REMOTE : Result := RemoteDrive;
DRIVE_CDROM : Result := CDRomDisk;
DRIVE_RAMDISK : Result := RamDisk;
end;
end;
{GetDiskInfo}
function GetDiskInfo(Drive : Char; var ClustersAvailable, TotalClusters,
BytesPerSector, SectorsPerCluster : Cardinal) : Boolean;
{-Return technical information about the specified drive.}
var
Root : String;
begin
if Drive <> ' ' then begin
Root := Char(System.Upcase(Drive)) + ':\';
Result := GetDiskFreeSpace(PChar(Root), DWORD(SectorsPerCluster),
DWORD(BytesPerSector), DWORD(ClustersAvailable), DWORD(TotalClusters));
end else
Result := GetDiskFreeSpace(nil, DWORD(SectorsPerCluster),
DWORD(BytesPerSector), DWORD(ClustersAvailable), DWORD(TotalClusters));
end;
{GetDiskSpace}
{$IFDEF CBuilder}
function GetDiskSpace(Drive : Char;
var UserSpaceAvail : Double; {space available to user}
var TotalSpaceAvail : Double; {total space available}
var DiskSize : Double) : Boolean;{disk size}
{-Return space information about the drive.}
type
TGetDiskFreeSpace = function (Drive : PChar;
var UserFreeBytes : Comp;
var TotalBytes : Comp;
var TotalFreeBytes : Comp) : Bool; stdcall;
LH = packed record L,H : word; end;
var
UserFree, Total, Size : Comp;
VerInfo : TOSVersionInfo;
LibHandle : THandle;
GDFS : TGetDiskFreeSpace;
Root : String;
begin
Result := False;
{get the version info}
FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
VerInfo.dwOSVersionInfoSize := SizeOf(VerInfo);
if GetVersionEx(VerInfo) then begin
with VerInfo do begin
if ((dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
(LH(dwBuildNumber).L <> 1000)) or
((dwPlatformId = VER_PLATFORM_WIN32_NT) and
(dwMajorVersion >= 4)) then begin
LibHandle := LoadLibrary('KERNEL32.DLL');
try
if (LibHandle <> 0) then begin
@GDFS := GetProcAddress(LibHandle, 'GetDiskFreeSpaceEx'+{$IFDEF UNICODE}'W'{$ELSE}'A'{$ENDIF});
if Assigned(GDFS) then begin
Root := Char(Upcase(Drive)) + ':\';
if GDFS(PChar(Root), UserFree, Size, Total) then begin
UserSpaceAvail := UserFree;
DiskSize := Size;
TotalSpaceAvail := Total;
Result := true;
end;
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
end;
end;
end;
{$ELSE}
function GetDiskSpace(Drive : Char;
var UserSpaceAvail : Comp; {space available to user}
var TotalSpaceAvail : Comp; {total space available}
var DiskSize : Comp) : Boolean;{disk size}
{-Return space information about the drive.}
type
TGetDiskFreeSpace = function (Drive : PChar;
var UserFreeBytes : Comp;
var TotalBytes : Comp;
var TotalFreeBytes : Comp) : Bool; stdcall;
LH = packed record L,H : word; end;
var
CA, TC, BPS, SPC : Cardinal;
VerInfo : TOSVersionInfo;
LibHandle : THandle;
GDFS : TGetDiskFreeSpace;
Root : String;
begin
Result := false;
{get the version info}
FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
VerInfo.dwOSVersionInfoSize := SizeOf(VerInfo);
if GetVersionEx(VerInfo) then begin
with VerInfo do begin
if ((dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
(LH(dwBuildNumber).L <> 1000)) or
((dwPlatformId = VER_PLATFORM_WIN32_NT) and
(dwMajorVersion >= 4)) then begin
LibHandle := LoadLibrary('KERNEL32.DLL');
try
if (LibHandle <> 0) then begin
@GDFS := GetProcAddress(LibHandle, 'GetDiskFreeSpaceEx'+{$IFDEF UNICODE}'W'{$ELSE}'A'{$ENDIF});
if Assigned(GDFS) then begin
Root := Char(System.Upcase(Drive)) + ':\';
if GDFS(PChar(Root), UserSpaceAvail, DiskSize, TotalSpaceAvail) then
Result := true;
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
end;
end;
if not Result then begin
if GetDiskInfo(Drive, CA, TC, BPS, SPC) then begin
Result := true;
DiskSize := BPS;
DiskSize := DiskSize * SPC * TC;
TotalSpaceAvail := BPS;
TotalSpaceAvail := TotalSpaceAvail * SPC * CA;
UserSpaceAvail := TotalSpaceAvail;
end;
end;
end;
{$ENDIF}
function GetFileCreateDate(const FileName : String) :
TDateTime;
{-Obtains file system time of file creation.}
{!!.01 - Rewritten}
var
Rslt : Integer;
SR : TSearchRec;
FTime : Integer;
begin
Result := 0.0;
Rslt := FindFirst(FileName, faAnyFile, SR);
if Rslt = 0 then begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
FileTimeToDosDateTime(SR.FindData.ftCreationTime,
LongRec(FTime).Hi, LongRec(FTime).Lo);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
Result := FileDateToDateTime(FTime);
FindClose(SR);
end;
{!!.01 - End Rewritten}
end;
{GetFileLastAccess}
function GetFileLastAccess(const FileName : String) :
TDateTime;
{-Obtains file system time of last file access.}
{!!.01 - Rewritten}
var
Rslt : Integer;
SR : TSearchRec;
FTime : Integer;
begin
Result := 0.0;
Rslt := FindFirst(FileName, faAnyFile, SR);
if Rslt = 0 then begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
FileTimeToDosDateTime(SR.FindData.ftLastAccessTime,
LongRec(FTime).Hi, LongRec(FTime).Lo);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
Result := FileDateToDateTime(FTime);
FindClose(SR);
end;
{!!.01 - End Rewritten}
end;
{GetFileLastModify}
function GetFileLastModify(const FileName : String) :
TDateTime;
{-Obtains file system time of last file modification.}
{!!.01 - Rewritten}
var
Rslt : Integer;
SR : TSearchRec;
FTime : Integer;
begin
Result := 0.0;
Rslt := FindFirst(FileName, faAnyFile, SR);
if Rslt = 0 then begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
FileTimeToDosDateTime(SR.FindData.ftLastWriteTime,
LongRec(FTime).Hi, LongRec(FTime).Lo);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
Result := FileDateToDateTime(FTime);
FindClose(SR);
end;
{!!.01 - End Rewritten}
end;
{GetHomeFolder}
function GetHomeFolder(aForceSlash : boolean) : String;
{-Obtains the "Home Folder" for the current user}
var
Size : integer;
Path : String;
Buffer : PChar;
begin
Size := Windows.GetEnvironmentVariable('HOMEDRIVE', nil, 0);
GetMem(Buffer, Size * SizeOf(Char));
try
SetString(Result, Buffer, Windows.GetEnvironmentVariable('HOMEDRIVE',
Buffer, Size));
finally
FreeMem(Buffer);
end;
Size := Windows.GetEnvironmentVariable('HOMEPATH', nil, 0);
GetMem(Buffer, Size * SizeOf(Char));
try
SetString(Path, Buffer, Windows.GetEnvironmentVariable('HOMEPATH',
Buffer, Size));
finally
FreeMem(Buffer);
end;
if Path = '' then
Path := GetWorkingFolder(aForceSlash);
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Path := Path + StDosPathDelim;
if (Path[1] <> StDosPathDelim) then
Result := Result + StDosPathDelim + Path
else
Result := Result + Path;
end;
function GetLongPathName(lpszShortPath: PChar; lpszLongPath: PChar;
cchBuffer: DWORD): DWORD;
var
PathBuf : PChar;
Len, i : Integer;
FD : TWIN32FindData;
FH : THandle;
ResBuf : String;
begin
if not Assigned(lpszShortPath) then begin
SetLastError(ERROR_INVALID_PARAMETER);
Result := 0;
Exit;
end;
{ Check whether the input path is valid. }
if (GetFileAttributes(lpszShortPath) = $FFFFFFFF) then begin
Result := 0;
Exit;
end;
Len := StrLen(lpszShortPath);
PathBuf := StrAlloc(Len + 1);
try
StrCopy(PathBuf, lpszShortPath);
ResBuf := '';
i := 0;
{ Check for Drive Letter }
if (IsCharAlpha(PathBuf[0])) and (PathBuf[1] = DriveDelim) and (Len > 3) then begin
repeat
ResBuf := ResBuf + PathBuf[i];
Inc(i);
until PathBuf[i] = StPathDelim;
ResBuf := ResBuf + StPathDelim;
end;
{ Check for UNC Path }
if (PathBuf[0] = StPathDelim) and (PathBuf[1] = StPathDelim) then begin
{ extract machine name }
ResBuf := '\\';
i := 2;
repeat
ResBuf := ResBuf + PathBuf[i];
Inc(i);
until PathBuf[i] = StPathDelim;
ResBuf := ResBuf + StPathDelim;
Inc(i);
{ extract share name }
repeat
ResBuf := ResBuf + PathBuf[i];
Inc(i);
until PathBuf[i] = StPathDelim;
ResBuf := ResBuf + StPathDelim;
Inc(i);
end;
{ move past current delimiter } {!!.01}
Inc(i); {!!.01}
{ find next occurrence of path delimiter }
while i < Len do begin
if (PathBuf[i] = StPathDelim) then begin
PathBuf[i] := #0;
FH := FindFirstFile(PathBuf, FD);
if FH <> INVALID_HANDLE_VALUE then begin
ResBuf := ResBuf + StrPas(FD.cFileName) + StPathDelim;
Windows.FindClose(FH);
end;
PathBuf[i] := StPathDelim;
end;
Inc(i);
end;
{ one mo' time for the entire string: }
FH := FindFirstFile(PathBuf, FD);
if FH <> INVALID_HANDLE_VALUE then begin
ResBuf := ResBuf + StrPas(FD.cFileName);
Windows.FindClose(FH);
end;
Result := Length(ResBuf);
if Assigned(lpszLongPath) and (cchBuffer >= DWord(Length(ResBuf))) then begin
StrPCopy(lpszLongPath, ResBuf);
end;
finally
StrDispose(PathBuf);
end;
end;
{GetLongPath}
function GetLongPath(const APath : String) : String;
{-Returns the long filename version of a provided path.}
var
Size : integer;
Buffer : PChar;
begin
Buffer := nil;
Size := GetLongPathName(PChar(APath), Buffer, 0);
Buffer := StrAlloc(Size);
try
SetString(Result, Buffer, GetLongPathName(PChar(APath), Buffer, Size));
finally
if Assigned(Buffer) then
StrDispose(Buffer);
end;
end;
{GetMachineName}
function GetMachineName : String;
{-Returns the "Machine Name" for the current computer }
var
Size : DWORD;
MachineNameZ : array [0..MAX_COMPUTERNAME_LENGTH] of Char;
begin
Size := Length(MachineNameZ);
if not GetComputerName(MachineNameZ, Size) then
{$IFDEF Version6}
RaiseLastOSError;
{$ELSE}
RaiseLastWin32Error;
{$ENDIF}
// SetString(Result, MachineNameZ, Size); {!!.02}
SetString(Result, MachineNameZ, StrLen(MachineNameZ)); {!!.02}
end;
{GetMediaID}
function GetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
{-Get the media information (Volume Label, Serial Number) for the specified drive}
var
VolBuf, FSNameBuf : PChar;
VolSiz, FSNSiz : Integer;
Root : String;
SN, ML, Flags : DWORD;
begin
VolSiz := Length(MediaIDRec.VolumeLabel){ + 1}; //SZ: why +1??
FSNSiz := Length(MediaIDRec.FileSystemID){ + 1};
Root := Char(System.Upcase(Drive)) + ':\';
VolBuf := nil;
FSNameBuf := nil;
try
VolBuf := StrAlloc(VolSiz);
FSNameBuf := StrAlloc(FSNSiz);
Result := 0;
if GetVolumeInformation(PChar(Root), VolBuf, VolSiz, @SN, ML, Flags, FSNameBuf, FSNSiz) then begin
StrCopy(MediaIDRec.FileSystemID, FSNameBuf);
StrCopy(MediaIDRec.VolumeLabel, VolBuf);
MediaIDRec.SerialNumber := SN;
end else
Result := GetLastError;
finally
if Assigned(VolBuf) then
StrDispose(VolBuf);
if Assigned(FSNameBuf) then
StrDispose(FSNameBuf);
end;
end;
{!!.02 -- Added }
function StAddBackSlash(const DirName : string) : string;
{ Add a default slash to a directory name }
const
DelimSet : set of AnsiChar = [StPathDelim, ':', #0];
begin
Result := DirName;
if Length(DirName) = 0 then
Exit;
{$IFDEF UNICODE}
if not CharInSet(DirName[Length(DirName)], DelimSet) then
Result := DirName + StPathDelim;
{$ELSE}
if not (DirName[Length(DirName)] in DelimSet) then
Result := DirName + StPathDelim;
{$ENDIF}
end;
{!!.02 -- End Added }
{GetParentFolder}
function GetParentFolder(const APath : String; aForceSlash : Boolean) : String;
{-return the parent directory for the provided directory }
begin
Result := ExpandFileName(StAddBackSlash(APath) + StParentDir); {!!.02}
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Result := Result + StDosPathDelim;
end;
{GetShortPath}
function GetShortPath(const APath : String) : String;
{-Returns the short filename version of a provided path.}
var
Size : integer;
Buffer : PChar;
begin
Buffer := nil;
Size := GetShortPathName(PChar(APath), Buffer, 0);
Buffer := StrAlloc(Size);
try
SetString(Result, Buffer, GetShortPathName(PChar(APath), Buffer, Size));
finally
if Assigned(Buffer) then
StrDispose(Buffer);
end;
end;
{GetSystemFolder}
function GetSystemFolder(aForceSlash : boolean) : String;
{-Returns the path to the Windows "System" folder".}
var
Size : integer;
Buffer : PChar;
begin
Size := GetSystemDirectory(nil, 0);
Buffer := StrAlloc(Size);
try
SetString(Result, Buffer, GetSystemDirectory(Buffer, Size));
finally
StrDispose(Buffer);
end;
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Result := Result + StDosPathDelim;
end;
{GetTempFolder}
function GetTempFolder(aForceSlash : boolean) : String;
{-Returns the path to the system temporary folder.}
var
Size : integer;
Buffer : PChar;
begin
Size := GetTempPath(0, nil);
Buffer := StrAlloc(Size);
try
SetString(Result, Buffer, GetTempPath(Size, Buffer));
finally
StrDispose(Buffer);
end;
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Result := Result + StDosPathDelim;
end;
{GetWindowsFolder}
function GetWindowsFolder(aForceSlash : boolean) : String;
{-Returns the path to the main "Windows" folder.}
var
Size : integer;
Buffer : PChar;
begin
Size := GetWindowsDirectory(nil, 0);
Buffer := StrAlloc(Size);
try
SetString(Result, Buffer, GetWindowsDirectory(Buffer, Size));
finally
StrDispose(Buffer);
end;
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Result := Result + StDosPathDelim;
end;
{GetWorkingFolder}
function GetWorkingFolder(aForceSlash : boolean) : String;
{-Returns the current working directory.}
begin
Result := ExpandFileName(StThisDir);
if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
Result := Result + StDosPathDelim;
end;
{GlobalDateTimeToLocal}
function GlobalDateTimeToLocal(const UTC: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
{-adjusts a global date/time (UTC) to the local date/time}
{$IFNDEF VERSION4}
const
TIME_ZONE_ID_INVALID = DWORD($FFFFFFFF);
TIME_ZONE_ID_UNKNOWN = 0;
TIME_ZONE_ID_STANDARD = 1;
TIME_ZONE_ID_DAYLIGHT = 2;
{$ENDIF}
var
Minutes : LongInt;
TZ : TTimeZoneInformation;
begin
Minutes := (UTC.D * MinutesInDay) + (UTC.T div 60);
case GetTimeZoneInformation(TZ) of
TIME_ZONE_ID_UNKNOWN :
Minutes := Minutes - TZ.Bias;
TIME_ZONE_ID_INVALID :
Minutes := Minutes - MinOffset;
TIME_ZONE_ID_STANDARD:
Minutes := Minutes - (TZ.Bias + TZ.StandardBias);
TIME_ZONE_ID_DAYLIGHT:
Minutes := Minutes - (TZ.Bias + TZ.DaylightBias);
end;
Result.D := (Minutes div MinutesInDay);
Result.T := ((Minutes mod MinutesInDay) * SecondsInMinute) + (UTC.T mod SecondsInMinute);
end;
{IsDirectory}
function IsDirectory(const DirName : String) : Boolean;
{-Return true if DirName is a directory}
var
Attrs : DWORD; {!!.01}
begin
Result := False;
Attrs := GetFileAttributes(PChar(DirName));
if Attrs <> DWORD(-1) then {!!.01}
Result := (FILE_ATTRIBUTE_DIRECTORY and Attrs <> 0);
end;
{IsDirectoryEmpty}
function IsDirectoryEmpty(const S : String) : Integer;
{-checks if there are any entries in the directory}
var
SR : TSearchRec;
R : Integer;
DS : String;
begin
Result := 1;
if IsDirectory(S) then begin
DS := AddBackSlashL(S);
R := Abs(FindFirst(DS + StDosAnyFile, faAnyFile, SR));
if R <> 18 then begin
if (R = 0) then
repeat
if (SR.Attr and faDirectory = faDirectory) then begin
if (SR.Name <> StThisDir) and (SR.Name <> StParentDir) then begin
Result := 0;
break;
end;
end else begin
Result := 0;
break;
end;
R := Abs(FindNext(SR));
until R = 18;
end;
FindClose(SR);
end else
Result := -1;
end;
{IsDriveReady}
function IsDriveReady(Drive : Char) : Boolean;
{-determine if requested drive is accessible }
var
Root : String;
VolName : PChar;
Flags, MaxLength : DWORD;
NameSize : Integer;
begin
Result := False;
NameSize := 0;
Root := System.Upcase(Drive) + ':\' ;
VolName := StrAlloc(MAX_PATH);
try
if GetVolumeInformation(PChar(Root), VolName, MAX_PATH,
nil, MaxLength, Flags, nil, NameSize) then
Result := True;
finally
if Assigned(VolName) then
StrDispose(VolName);
end;
end;
{IsFile}
function IsFile(const FileName : String) : Boolean;
{-Determines if the provided path specifies a file.}
var
Attrs : DWORD; {!!.02}
begin
Result := False;
Attrs := GetFileAttributes(PChar(FileName));
if Attrs <> DWORD(-1) then {!!.02}
Result := (Attrs and FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY;
end;
{IsFileArchive}
function IsFileArchive(const S : String) : Integer;
{-checks if file's archive attribute is set}
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
if FileExists(S) then
Result := Integer((FileGetAttr(S) and faArchive) = faArchive)
else
Result := -1;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{IsFileHidden}
function IsFileHidden(const S : String) : Integer;
{-checks if file's hidden attribute is set}
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
if FileExists(S) then
Result := Integer((FileGetAttr(S) and faHidden) = faHidden)
else
Result := -1;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{IsFileReadOnly}
function IsFileReadOnly(const S : String) : Integer;
{-checks if file's readonly attribute is set}
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
if FileExists(S) then
Result := Integer((FileGetAttr(S) and faReadOnly) = faReadOnly)
else
Result := -1;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{IsFileSystem}
function IsFileSystem(const S : String) : Integer;
{-checks if file's system attribute is set}
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
if FileExists(S) then
Result := Integer((FileGetAttr(S) and faSysFile) = faSysFile)
else
Result := -1;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{LocalDateTimeToGlobal}
function LocalDateTimeToGlobal(const DT1: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
{-adjusts a local date/time to the global (UTC) date/time}
{$IFNDEF VERSION4}
const
TIME_ZONE_ID_INVALID = DWORD($FFFFFFFF);
TIME_ZONE_ID_UNKNOWN = 0;
TIME_ZONE_ID_STANDARD = 1;
TIME_ZONE_ID_DAYLIGHT = 2;
{$ENDIF}
var
Minutes : LongInt;
TZ : TTimeZoneInformation;
begin
Minutes := (DT1.D * MinutesInDay) + (DT1.T div 60);
case GetTimeZoneInformation(TZ) of
TIME_ZONE_ID_UNKNOWN : { Time Zone transition dates not used }
Minutes := Minutes + TZ.Bias;
TIME_ZONE_ID_INVALID :
Minutes := Minutes + MinOffset;
TIME_ZONE_ID_STANDARD:
Minutes := Minutes + (TZ.Bias + TZ.StandardBias);
TIME_ZONE_ID_DAYLIGHT:
Minutes := Minutes + (TZ.Bias + TZ.DaylightBias);
end;
Result.D := (Minutes div MinutesInDay);
Result.T := ((Minutes mod MinutesInDay) * SecondsInMinute) + (DT1.T mod SecondsInMinute);
end;
{ReadVolumeLabel}
function ReadVolumeLabel(var VolName : String; Drive : Char) : Cardinal;
{-Get the volume label for the specified drive.}
var
Root : String;
Flags, MaxLength : DWORD;
NameSize : Integer;
begin
NameSize := 0;
Root := Drive + ':\';
if Length(VolName) < 12 then
SetLength(VolName, 12);
if GetVolumeInformation(PChar(Root), PChar(VolName), Length(VolName),
nil, MaxLength, Flags, nil, NameSize)
then begin
SetLength(VolName, StrLen(PChar(VolName)));
Result := 0;
end
else begin
VolName := '';
Result := GetLastError;
end;
end;
{SameFile}
function SameFile(const FilePath1, FilePath2 : String;
var ErrorCode : Integer) : Boolean;
{-Return true if FilePath1 and FilePath2 refer to the same physical file.
Error codes:
0 - Success (no error)
1 - Invalid FilePath1
2 - Invalid FilePath2
3 - Error on FileSetAttr/FileGetAttr }
var
Attr1, Attr2, NewAttr : Integer;
function DirectoryExists(const Name : String): Boolean;
var
Code : DWORD; {!!.02}
Buf : array[0..MAX_PATH] of Char; {!!.01}
begin
StrPLCopy(Buf, Name, Length(Buf)-1);
Code := GetFileAttributes(Buf);
Result := (Code <> DWORD(-1)) and {!!.02}
(FILE_ATTRIBUTE_DIRECTORY and Code <> 0); {!!.02}
end;
begin
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
Result := False;
ErrorCode := 0;
Attr1 := FileGetAttr(FilePath1);
if Attr1 < 0 then begin
ErrorCode := 1;
Exit;
end;
Attr2 := FileGetAttr(FilePath2);
if Attr2 < 0 then begin
{leave ErrorCode at 0 if file not found but path is valid}
if not DirectoryExists(ExtractFilePath(FilePath2)) then
ErrorCode := 2;
Exit;
end;
if Attr1 <> Attr2 then
Exit;
if ((Attr1 and faArchive) = 0) then
NewAttr := Attr1 or faArchive
else
NewAttr := Attr1 and (not faArchive);
if FileSetAttr(FilePath1, NewAttr) <> 0 then begin
ErrorCode := 3;
Exit;
end;
Attr2 := FileGetAttr(FilePath2);
if Attr2 < 0 then
ErrorCode := 3;
Result := (Attr2 = NewAttr) or (Attr2 = $80);
{ If the attribute is set to $00, Win32 automatically sets it to $80. }
if FileSetAttr(FilePath1, Attr1) <> 0 then
ErrorCode := 3;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
end;
{SetMediaID} {!!!! Does not work on NT/2000 !!!!}
function SetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
{-Set the media ID record for the specified drive.}
type
DevIOCtlRegisters = record
reg_EBX : LongInt;
reg_EDX : LongInt;
reg_ECX : LongInt;
reg_EAX : LongInt;
reg_EDI : LongInt;
reg_ESI : LongInt;
reg_Flags : LongInt;
end;
var
PMid : PMediaIDType;
Regs : DevIOCtlRegisters;
CB : DWord;
HDevice : THandle;
SA : TSecurityAttributes;
begin
PMid := @MediaIDRec;
with SA do begin
nLength := SizeOf(SA);
lpSecurityDescriptor := nil;
bInheritHandle := True;
end;
with Regs do begin
reg_EAX := $440D;
reg_EBX := Ord(System.UpCase(Drive)) - (Ord('A') - 1);
reg_ECX := $0846;
reg_EDX := LongInt(PMid);
end;
HDevice := CreateFile('\\.\vwin32', GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
Pointer(@SA), OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if HDevice <> INVALID_HANDLE_VALUE then begin
if DeviceIOControl(HDevice, VWIN32_DIOC_DOS_IOCTL, Pointer(@Regs), SizeOf(Regs),
Pointer(@Regs), SizeOf(Regs), CB, nil)
then
Result := 0
else
Result := GetLastError;
CloseHandle(HDevice);
end else
Result := GetLastError;
end;
{SplitPath}
procedure SplitPath(const APath : String; Parts : TStrings);
{-Splits the provided path into its component sub-paths}
var
i : Integer;
iStart : Integer;
iStartSlash : Integer;
Path, SubPath : String;
begin
Path := APath;
if Path = '' then Exit;
if not Assigned(Parts) then Exit;
if Path[ Length( Path ) ] = StPathDelim then
Delete( Path, Length( APath ), 1 );
iStart := 1;
iStartSlash := 1;
repeat
{find the Slash at iStartSlash}
i := FindNthSlash( Path, iStartSlash );
{get the subpath}
SubPath := Copy( Path, iStart, i - iStart + 1 );
iStart := i + 2;
inc( iStartSlash );
Parts.Add( SubPath );
until ( i = Length( Path ) );
end;
{StDateTimeToFileTime}
function StDateTimeToFileTime(const FileTime : TStDateTimeRec) : LongInt; {!!.02}
{-Converts an TStDate and TStTime to a DOS date-time value.}
var
DDT : TDateTime;
begin
DDT := Int(StDateToDateTime(FileTime.D)) + Frac(StTimeToDateTime(FileTime.T));
Result := DateTimeToFileDate(DDT);
end;
{StDateTimeToUnixTime}
function StDateTimeToUnixTime(const DT1 : TStDateTimeRec) : Longint; {!!.02}
{-converts a TStDateTimeRec to a time in Unix base (1970)}
begin
Result := ((DT1.D - Date1970) * SecondsInDay) + DT1.T;
end;
{UnixTimeToStDateTime}
function UnixTimeToStDateTime(UnixTime : Longint) : TStDateTimeRec;
{-converts a time in Unix base (1970) to a TStDateTimeRec}
begin
Result.D := Date1970 + (UnixTime div SecondsInDay);
Result.T := UnixTime mod SecondsInDay;
end;
{ValidDrive}
function ValidDrive(Drive : Char) : Boolean;
{-Determine if the drive is a valid drive.}
var
DriveBits : LongInt;
DriveLtr : Char;
begin
DriveLtr := System.UpCase(Drive);
DriveBits := GetLogicalDrives shr (Ord(DriveLtr)-Ord('A'));
Result := LongFlagIsSet(DriveBits, $00000001);
end;
{WriteVolumeLabel}
function WriteVolumeLabel(const VolName : String; Drive : Char) : Cardinal;
{-Sets the volume label for the specified drive.}
var
Temp : String;
Vol : array[0..11] of Char;
Root : array[0..3] of Char;
begin
Temp := VolName;
StrCopy(Root, '%:\');
Root[0] := Drive;
if Length(Temp) > 11 then
SetLength(Temp, 11);
StrPCopy(Vol, Temp);
if Windows.SetVolumeLabel(Root, Vol) then
Result := 0
else Result := GetLastError;
end;
end.
Reference in New Issue View Git Blame Copy Permalink