-- Page 2
--
Last updated:
02/18/2005
Below is a list of Delphi code tips that I have come across from personal experience and various newsgroups. I collect bits and pieces of code that I find very useful and place them all in one unit so they are accessed easily in other Delphi projects. You are free to download this unit here.
Download the unit containing all the
source found on these Code Tips pages by clicking on the spinning
disk on the left or here. You will need WinZip or Pkunzip to unzip the file. After
unzipping the unit to a directory of your choice, simply add it
to your project's uses clause and you're ready to use the code.
Note: all of this code has been tested and compiled in Delphi 3, 4 & 5. If you find ANY problems with compiling or running the code in your project, please let me know and I will do my best to help resolve your issue. Thanks!
This function, when passed a long path name, will convert it to a short Win3.1 style path name. For example: ExtractShortPathName('C:\This is a directory\This is a file.txt') will return 'C:\Thisis~1\Thisis~1.txt'. To extract the long path name, see ExtractLongPathName().
function
ExtractShortPathName(const FileName: string): string;
{ func
to shorten the long path name to look like Win 3.1 naming
conventions. }
{ If file doesn't exist, func will return an emtpy string.
}
var
Buffer: array[0..MAX_PATH] of Char;
begin
SetString(Result, Buffer,
GetShortPathName(PChar(FileName), Buffer,
SizeOf(Buffer)));
end;
There is no easy way to write a drive formatting function or procedure. The easiest way is to let Windows do it for you by showing the standard Windows format dialog for floppies. The dialog will be modal and displays any error or success messages, so no messages are needed to be displayed in this procedure. Call FormatFloppy(0) to format the A:\ drive or FormatFloppy(1) for the B:\ drive.
procedure
FormatFloppy(Drive: byte);
{
proc to show the standard Windows format dialog to format a }
{
floppy drive. Pass 0 for A:\ or 1 for B:\
}
type
TSHFormatDrive = function (hWnd: HWND;
Drive: Word;
fmtID: Word;
Options: Word): Longint stdcall;
var
SHFormatDrive: TSHFormatDrive;
LibHandle:
THandle;
begin
LibHandle := LoadLibrary(PChar('Shell32.dll'));
if
LibHandle <> 0 then
@SHFormatDrive := GetProcAddress(LibHandle, 'SHFormatDrive')
else
begin
MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
Exit;
end;
if @SHFormatDrive
<> nil then
SHFormatDrive(Application.Handle,
Drive, { 0 = A:\, 1 = B:\ }
$FFFF,
0);
FreeLibrary(LibHandle);
@SHFormatDrive
:= nil;
end;
To get a list of exports from a DLL, pass the DLL name and a TStrings object to ListDLLFunctions() below. Note that this does not show the parameters for each export, which you can only get from the author of the DLL. Code by Dmtiry Streblechenko.
uses ImageHlp;
procedure
ListDLLFunctions(DLLName: string; List: TStrings);
// by
Dmitry Streblechenko
type
chararr = array[0..$FFFFFF] of
char;
var
h: THandle;
i, fc: integer;
st: string;
arr: pointer;
ImageDebugInformation: PImageDebugInformation;
begin
List.Clear;
DLLName := ExpandFileName(DLLName);
if FileExists(DLLName) then
begin
h := CreateFile(PChar(DLLName),
GENERIC_READ,
FILE_SHARE_READ
or FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if h
<> INVALID_HANDLE_VALUE then
try
ImageDebugInformation
:= MapDebugInformation(h, PChar(DLLName), nil, 0);
if
ImageDebugInformation <> nil then
try
arr
:= ImageDebugInformation^.ExportedNames;
fc
:= 0;
for
i := 0 to ImageDebugInformation^.ExportedNamesSize-1
do
if
chararr(arr^)[i] = #0 then
begin
st
:= PChar(@chararr(arr^)[fc]);
if
length(st)>0 then List.Add(st);
if
(i>0) and (chararr(arr^)[i-1]=#0) then Break;
fc
:= i+1;
end;
finally
UnmapDebugInformation(ImageDebugInformation);
end;
finally
CloseHandle(h);
end;
end;
end;
A common question I've come across is how to get a screenshot in Delphi. ScreenShot() will take a shot of a box onscreen and place it in a TBitmap for you. To get the whole screen, use it like this: ScreenShot(0, 0, Screen.Width, Screen.Height, Image1.Picture.Bitmap); For just a shot of a form, do this: ScreenShot(Form1.Left, Form1.Top, Form1.Width, Form1.Height, Image1.Picture.Bitmap); Thanks to Joe C. Hecht for this code.
procedure ScreenShot(x
: integer;
y : integer; //(x, y) = Left-top coordinate
Width : integer;
Height : integer; //(Width-Height) = Bottom-Right coordinate
bm : TBitMap); //Destination
var
dc: HDC;
lpPal:
PLOGPALETTE;
begin
{test
width and height}
if ((Width
= 0) or
(Height = 0)) then
Exit;
bm.Width := Width;
bm.Height :=
Height;
{get
the screen dc}
dc := GetDc(0);
if (dc = 0)
then
Exit;
{do we have a palette
device?}
if (GetDeviceCaps(dc,
RASTERCAPS) and
RC_PALETTE = RC_PALETTE) then
begin
{allocate
memory for a logical palette}
GetMem(lpPal,
sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^,
sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)),
#0);
{fill in
the palette version}
lpPal^.palVersion := $300;
{grab
the system palette entries}
lpPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
{create
the palette}
bm.Palette := CreatePalette(lpPal^);
FreeMem(lpPal,
sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
end;
{copy from the screen
to the bitmap}
BitBlt(bm.Canvas.Handle,
0,
0,
Width,
Height,
Dc,
x,
y,
SRCCOPY);
{release the screen
dc}
ReleaseDc(0, dc);
end;
I sometimes use a "for i := 1 to 26" loop to cycle through the drives and created this function to give me the drive letter of the current i value. To get the drive number for a given drive letter, see GetDriveNumber().
function
GetDriveLetter(Drive: byte): char;
{ func
to return the drive letter. Ex: 1 = A, 2 = B, 3 = C, etc. }
begin
if (Drive
>= 1) and
(Drive <= 26) then
Result := chr(ord('A') + Drive - 1)
else
Result := ' ';
end;
Some Delphi functions use a byte variable instead of a character when dealing with drives. I created this function to give me a number equivalent of a drive (1 = A, 2 = B, etc.). To get the drive letter given a number, see GetDriveLetter().
function
GetDriveNumber(Drive: char): byte;
{ func
to return the drive number. Ex: A = 1, B = 2, C = 3, etc. }
var
DriveStr: string;
begin
DriveStr :=
UpperCase(Drive);
if
DriveStr[1] in ['A'..'Z'] then
Result := ord(DriveStr[1]) - ord('A') + 1
else
Result := 0;
end;
Here's a function to return the platform the executable was designed for (16/32 bit Windows or DOS). Read the comment for the usage. This function works as well with DLLs, COMs, and maybe others. Thanks to Peter Below for this code.
type
TExeType = (etUnknown, etDOS, etWinNE {16-bit},
etWinPE {32-bit});
TExeStrings = array[TExetype] of string[30];
function
GetExeType(const FileName: string): TExeType;
{ func to return the type of executable or dll (DOS, 16-bit, 32-bit).
}
{ Thanks to Peter Below (TeamB) <[email protected]>
for this code. }
(**************************************************************
Usage:
with OpenDialog1 do
if Execute then
begin
Label1.Caption := FileName;
Label2.Caption := ExeStrings[GetExetype(FileName)];
end;
- or -
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label3.Caption := 'Unknown file type';
etDOS : Label3.Caption := 'DOS executable';
etWinNE : {16-bit} Label3.Caption := 'Windows 16-bit
executable';
etWinPE : {32-bit} Label3.Caption := 'Windows 32-bit
executable';
end;
***************************************************************)
var
Signature,
WinHdrOffset: Word;
fexe: TFileStream;
begin
Result := etUnknown;
try
fexe := TFileStream.Create(FileName,
fmOpenRead or fmShareDenyNone);
try
fexe.ReadBuffer(Signature,
SizeOf(Signature));
if Signature
= $5A4D { 'MZ' } then
begin
Result
:= etDOS;
fexe.Seek($18,
soFromBeginning);
fexe.ReadBuffer(WinHdrOffset,
SizeOf(WinHdrOffset));
if
WinHdrOffset >= $40 then
begin
fexe.Seek($3C,
soFromBeginning);
fexe.ReadBuffer(WinHdrOffset,
SizeOf(WinHdrOffset));
fexe.Seek(WinHdrOffset,
soFrombeginning);
fexe.ReadBuffer(Signature,
SizeOf(Signature));
if
Signature = $454E { 'NE' } then
Result
:= etWinNE
else
if
Signature = $4550 { 'PE' } then
Result
:= etWinPE;
end;
end;
finally
fexe.Free;
end;
except
end;
end;
There is no one function or procedure to get extended information on the CPU. Intel supplies a CPUInfo Package that you can download and use in your application. However, the sample code is in C, and I took the liberty of creating a sample Delphi application using the package. Note: the Intel package was only designed for Intel's processors, and this sample project is designed to work on most processors (AMD, Alpha, MIPS, etc.).
Note: this project is rather old and you can get other newer libraries for CPU detection such as CarbonSoft cxCPU or MiTeC System Information Component.
Download my sample Delphi application
CPUTest (~16KB) by clicking on the spinning floppy disk on the
left or here. Tested OK in Delphi 3, 4 & 5.
Mark Horridge pointed out that my earlier GetDiskFree() function did not work on some Windows 95B/98 machines because of a buggy Windows.pas GetDiskFreeSpaceEx() function (See http://www.dataweb.nl/~r.p.sterkenburg/generated/entry0414.htm for a detailed explanation). I created this function to get the correct free disk space in bytes. You must declare the following 3 functions to override the one in Windows.pas to get the correct results.
{$DEFINE
Delphi3Below}
{$IFDEF VER130} //Delphi 5
{$UNDEF Delphi3Below}
{$ELSE}
{$IFDEF VER120} //Delphi 4
{$UNDEF Delphi3Below}
{$ENDIF}
{$ENDIF}
{$IFDEF
Delphi3Below}
function
GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceEx(lpDirectoryName: PChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
{$ELSE}
function
GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceEx(lpDirectoryName: PChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
{$ENDIF}
implementation
function
GetDiskFreeSpaceExA; external kernel32 name
'GetDiskFreeSpaceExA';
function
GetDiskFreeSpaceExW; external kernel32 name
'GetDiskFreeSpaceExW';
function
GetDiskFreeSpaceEx; external kernel32 name
'GetDiskFreeSpaceExA';
function
GetDiskFree(Drive: char): comp;
{
func to return the free space of a drive in bytes. }
var
{$IFDEF
Delphi3Below}
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes : comp;
{$ELSE}
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes : TLargeInteger;
{$ENDIF}
begin
if
GetDiskFreeSpaceEx(PChar(Drive + ':\'),
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes, @lpTotalNumberOfFreeBytes) then
Result := lpTotalNumberOfFreeBytes
else
Result := -1;
end;
I found this on the Borland Newsgroup somewhere and thought it was worth putting here. This function will return an estimated core processor speed of your PC. Read the comment to see how to use it. If you want to get into the depth of all processor information (normalized & raw frequency, model/stepping/family, type, etc.), I suggest you download Intel's CPUInfo Package or try out my CPUTest project.
{$DEFINE
Delphi3Below}
{$IFDEF VER130} //Delphi 5
{$UNDEF Delphi3Below}
{$ELSE}
{$IFDEF VER120} //Delphi 4
{$UNDEF Delphi3Below}
{$ENDIF}
{$ENDIF}
function GetCpuSpeed:
Comp;
{
Function to return the CPU clock speed only.
}
{ Usage:
MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation, [mbOk],
0); }
var
t: DWORD;
mhi, mlo, nhi,
nlo: DWORD;
t0, t1, chi, clo,
shr32: Comp;
begin
shr32 := 65536;
shr32 := shr32 *
65536;
t := GetTickCount;
while t =
GetTickCount do begin end;
asm
DB 0FH
DB 031H
mov mhi,edx
mov mlo,eax
end;
while
GetTickCount < (t + 1000) do begin end;
asm
DB 0FH
DB 031H
mov nhi,edx
mov nlo,eax
end;
chi := mhi;
{$IFDEF Delphi3Below}
if mhi < 0 then chi := chi + shr32;
{$ENDIF}
clo := mlo;
{$IFDEF Delphi3Below}
if mlo
< 0 then clo := clo + shr32;
{$ENDIF}
t0 := chi * shr32 + clo;
chi := nhi;
{$IFDEF Delphi3Below}
if nhi
< 0 then chi := chi + shr32;
{$ENDIF}
clo := nlo;
{$IFDEF Delphi3Below}
if nlo
< 0 then clo := clo + shr32;
{$ENDIF}
t1 := chi * shr32 +
clo;
Result := (t1 - t0) / 1E6;
end;
If you work with graphics, it's sometimes useful to know what color depth your user's video card is set at. I created this function to do that for me, which returns a string result. You can change the function to return an Int64 (Delphi 4/5) or Comp (Delphi 3) type instead if you need to work with the numbers.
uses
Math;
function
GetColorDepth: string;
{ func
to get the current color depth of the video card. }
var
tmpStr: string;
x: integer;
DeviceContents:
HDC;
ColorDepth:
Extended;
begin
DeviceContents :=
GetDC(0);
x :=
GetDeviceCaps(DeviceContents, BitsPixel) * GetDeviceCaps(DeviceContents,
Planes);
ColorDepth :=
Power(2, x);
ReleaseDC(0,
DeviceContents);
tmpstr := Format('%d
Colors ', [Trunc(ColorDepth)]);
case x of
1:
tmpstr := tmpstr + 'MonoChrome';
16:
tmpstr := tmpstr + 'HiColor (16 Bit)';
24:
tmpstr := tmpstr + 'TrueColor (24 Bit)';
32:
tmpstr := tmpstr + 'TrueColor (32 Bit)';
64:
tmpstr := tmpstr + 'UltraColor (64 Bit)';
end;
Result := tmpstr;
end;
Here is an example of how to get the dates of a given week number. See the comments for an example of the usage.
procedure
GetDates(iWeekNbr:
integer; var dSunday, dSaturday: TDateTime);
{ proc
to extract the week dates from Sunday to Saturday of a given week
number. }
{ Code can be modified to return Monday to Friday if needed. }
{ Example:
procedure TForm1.Button1Click(Sender: TObject);
var
Sunday, Saturday: TDateTime;
begin
GetDates(23, Sunday, Saturday);
ShowMessage(DateToStr(Sunday) + ' - ' +
DateToStr(Saturday));
end; }
var
dYear, dMonth, dDay: word;
TempDate: TDateTime;
begin
DecodeDate(now, dYear, dMonth, dDay);
{ get the date for the first day of the year. }
TempDate := EncodeDate(dYear, 1, 1);
{ get the date for the first Sunday - 1st full week }
while DayOfWeek(TempDate) <> 1 do
TempDate := TempDate + 1;
{ get the Sunday for the specified week. }
dSunday := TempDate + (7*(iWeekNbr-1));
{ get the following Saturday. }
dSaturday := dSunday + 6;
end;
Environment variables are useful to get detailed descriptions of your user's machines when they have a problem with your applications. This function can be used to retrieve the environment variables into a TStrings. Usage: drop a TMemo on the form & call the function like this: GetEnvVariables(Memo1.Lines);
procedure
GetEnvVariables(EnvList: TStrings);
{ proc
to retrieve all the environment variables }
{ and
store them in a TStrings. }
var
EnvPtr, SavePtr:
PChar;
begin
EnvPtr :=
GetEnvironmentStrings;
SavePtr := EnvPtr;
EnvList.Clear;
repeat
EnvList.Add(StrPas(EnvPtr));
inc(EnvPtr,
StrLen(EnvPtr) + 1);
until
EnvPtr^ = #0;
FreeEnvironmentStrings(SavePtr);
end;
If you work with HTML, you know that sometimes you need the HTML equivalent of a color (the hex value). GetHTMLColor2() will convert any TColor to it's HTML value. For example, GetHTMLColor2(clBlue) will return #0000FF.
function GetHTMLColor2(Value:
TColor): string;
begin
with
TRGBQuad(ColorToRGB(Value)) do
Result := '#' + IntToHex(RGB(rgbRed, rgbGreen, rgbBlue), 6);
end;
This function will return the modified date of a file in a string format. You can replace DateTimeToStr() with FormatDateTime() to format the string to your taste, or change the result to be a TDateTime instead of a string.
function
GetModifiedDate(FileToCheck: string): string;
{ Func
to return the modified date of a file. }
var
L : LongInt;
D : TDateTime;
begin
Result := '';
L := FileAge(FileToCheck);
if (L
<> -1) then
begin
D := FileDateToDateTime(L);
Result := DateTimeToStr(D);
end;
end;
Use this function to determine the serial number of the CDROM. Will only return a result if there is a CDROM in the drive.
uses MMSystem, MPlayer;
function
CDSerialNumber(CD: Char): string;
{
func to return the serial number on the CD. Works on audio
& data CDs. }
var
mp :
TMediaPlayer;
msp :
TMCI_INFO_PARMS;
MediaString : array[0..255] of
char;
ret :
longint;
begin
mp :=
TMediaPlayer.Create(nil);
try
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := CD + ':';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId,
MCI_INFO,
MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Result := StrPas(MediaString);
end
else
Result := StrPas(MediaString);
mp.Close;
Application.ProcessMessages;
finally
mp.free;
end;
end;
This procedure will list the available video modes of your primary video card. See the comment for the usage. Note that this procedure only displays the video modes and will not change the video setting.
procedure
GetVideoModes(ModeList: TStringList);
{
proc to retrieve a list of acceptable video modes of the current
video card. }
{
**********************************************
Usage:
procedure TForm1.FormCreate(Sender: TObject);
var
StrList: TStringList;
begin
StrList := TStringList.Create;
try
GetVideoModes(StrList);
Memo1.Lines := StrList;
finally
StrList.Clear;
StrList.Free;
end;
end;
************************************************
}
var
i, j:
integer;
MoreModes,
AddMode:
boolean;
dm:
TDeviceMode;
Mode: string;
begin
ModeList.Clear;
MoreModes
:= True;
Mode :=
'';
i := 0;
while
MoreModes do
begin
MoreModes := EnumDisplaySettings(nil, i, dm);
Mode := IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' +
IntToStr(dm.dmPelsWidth) + ' x ' +
IntToStr(dm.dmPelsHeight);
AddMode := True;
{
Check to make sure this mode is not already in the list. }
for j := 0 to ModeList.Count-1 do
if Mode = ModeList[j] then
AddMode := False;
if AddMode then
ModeList.Add(Mode);
inc(i);
end;
end;
To get the total size in bytes of a directory, call DirSize() below. This will return the number of bytes found for all files and subdirectories of a directory. Read the comment for the usage. To get the total size of a disk, see GetDiskSize().
{$DEFINE
Delphi3Below}
{$IFDEF VER130} //Delphi 5
{$UNDEF Delphi3Below}
{$ELSE}
{$IFDEF VER120} //Delphi 4
{$UNDEF Delphi3Below}
{$ENDIF}
{$ENDIF}
uses StdCtrls, FileCtrl;
var
{$IFDEF Delphi3Below}
TotalSize: comp;
{$ELSE}
TotalSize: Int64;
{$ENDIF}
{$IFDEF
Delphi3Below}
function DirSize(Path: string;
ScanLabel, SizeLabel: TLabel): comp;
{$ELSE}
function DirSize(Path: string;
ScanLabel, SizeLabel: TLabel): Int64;
{$ENDIF}
{ func
to return the total number of bytes found in a directory. }
{ You can pass 2 TLabels for a progress while scanning:
ScanLabel: will display the current path being
scanned
SizeLabel: will display the total size so far counted.
If you don't want to use either Labels, pass nil to
both. You
can still use returned value to read the total size.
Example:
(For Delphi 4/5)
TotalSize := 0;
Label1.Caption := IntToStr(DirSize('C:\Windows', nil,
nil)) + ' bytes';
(For Delphi 3)
TotalSize := 0;
Label1.Caption := FloatToStr(DirSize('C:\Windows',
nil, nil)) + ' bytes';
(It is a little faster this way.)
Note: you MUST initialize the global TotalSize
variable to 0 before
using this function. }
var
Res: Integer;
SR: TSearchRec;
begin
Result := TotalSize;
if Copy(Path, Length(Path), 1)
<> '\' then
Path := Path + '\';
if not
DirectoryExists(Path) then
begin
MessageDlg('Directory does
not exist: ' + Path, mtError, [mbOK], 0);
Exit;
end;
if ScanLabel <> nil
then
begin
ScanLabel.Caption := 'Scanning
' + Path;
ScanLabel.Update;
end;
Res := FindFirst(Path + '*.*', faAnyFile, SR);
try
while Res = 0 do
begin
if
(SR.Name [1] <> '.') and (SR.Name [1]
<> '..') then
begin
if
((SR.Attr and faDirectory) <> 0) then
DirSize(Path
+ SR.Name + '\', ScanLabel, SizeLabel)
else
TotalSize
:= TotalSize + SR.Size;
end;
Res := FindNext(SR);
if
SizeLabel <> nil then
begin
{$IFDEF Delphi3Below}
SizeLabel.Caption
:= 'Total size: ' + FloatToStr(TotalSize) + ' bytes';
{$ELSE}
SizeLabel.Caption
:= 'Total size: ' + IntToStr(TotalSize) + ' bytes';
{$ENDIF}
SizeLabel.Update;
end;
end;
finally
FindClose(SR);
end;
Result := TotalSize;
end;
The DiskSize() function in Delphi does not work for larger drives ( > 2GB ). Mark Horridge pointed out that my earlier GetDiskSize() function did not work on some Windows 95B/98 machines because of a buggy Windows.pas GetDiskFreeSpaceEx() function (See http://www.dataweb.nl/~r.p.sterkenburg/generated/entry0414.htm for a detailed explanation). I created this function to get the correct total disk space in bytes. You must declare the following 3 functions to override the one in Windows.pas to get the correct results. To get the total bytes of a directory, see DirSize().
{$DEFINE
Delphi3Below}
{$IFDEF VER130} //Delphi 5
{$UNDEF Delphi3Below}
{$ELSE}
{$IFDEF VER120} //Delphi 4
{$UNDEF Delphi3Below}
{$ENDIF}
{$ENDIF}
{$IFDEF
Delphi3Below}
function
GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceEx(lpDirectoryName: PChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: comp;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
{$ELSE}
function
GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
function
GetDiskFreeSpaceEx(lpDirectoryName: PChar;
var
lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes: TLargeInteger;
lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
{$ENDIF}
implementation
function
GetDiskFreeSpaceExA; external kernel32 name
'GetDiskFreeSpaceExA';
function
GetDiskFreeSpaceExW; external kernel32 name
'GetDiskFreeSpaceExW';
function
GetDiskFreeSpaceEx; external kernel32 name
'GetDiskFreeSpaceExA';
function
GetDiskSize(Drive: char): comp;
{
func to return the total size of a drive in bytes. }
var
{$IFDEF
Delphi3Below}
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes : comp;
{$ELSE}
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes : TLargeInteger;
{$ENDIF}
begin
if
GetDiskFreeSpaceEx(PChar(Drive + ':\'),
lpFreeBytesAvailableToCaller,
lpTotalNumberOfBytes, @lpTotalNumberOfFreeBytes) then
Result := lpTotalNumberOfBytes
else
Result := -1;
end;
I've seen this one asked a few times on the newsgroups: How do you get the serial number of a disk? This function shows you how to do that. It returns the same serial number as you see on the "Volume Serial Number" line when you type DIR in the DOS box.
function
GetDiskSerialNumber(Disk: char): string;
{
function to return the volume serial number of a given drive
letter. }
var
VolumeSerialNumber,
MaximumComponentLength,
FileSystemFlags: DWORD;
SerialNumber: string;
begin
if
not DiskInDrive(GetDriveNumber(Disk)) then
begin
Result := 'Invalid drive letter or no disk in drive: ' +
Uppercase(Disk) + ':\';
Exit;
end;
GetVolumeInformation(PChar(Disk + ':\'),
nil,
0,
@VolumeSerialNumber,
MaximumComponentLength,
FileSystemFlags,
nil,
0);
SerialNumber := IntToHex(HiWord(VolumeSerialNumber), 4) +
'-' +
IntToHex(LoWord(VolumeSerialNumber), 4);
Result :=
SerialNumber;
end;
-- End of Page 2 --