2011. március 23., szerda
Black-Box Miscellaneous Functions and Procedures
Problem/Question/Abstract:
This is a Black-Box Miscellaneous Library that I have built up over the years (from Turbo Pascal 2.0 days). I have
posted it to this program as many of my components and classes make use of calls to this library. The functions and procedures are too numerous to document here, but they are self explanatory enough. Peruse the source code and I am sure you find something of interest.
Answer:
unit General;
interface
uses Windows, SysUtils, Forms, Dialogs, DBTables, BDE, Classes, DB,
Controls, Registry, Printers, Graphics, DBGrids, ShellAPI,
WinSock, Grids, Math, StdCtrls, NB30, JPEG, Menus,
WinSvc, ComCtrls, ShlObj, Messages, StrUtils;
const CrLf = #13#10; // Carriage Return / Linefeed pair
// Keyboard Char Constants
KY_TAB = #9;
KY_ENTER = #13;
KY_NONE = #0;
KY_BACKSPACE = #8;
KY_COPYRIGHT = #169; // Type ALT 0169 to get ©
KY_REGISTERED = #174; // Type ALT 0174 to get ®
// Extra VK constants missing from Delphi's Windows API interface
VK_NULL = 0;
VK_SEMICOLON = 186;
VK_EQUAL = 187;
VK_COMMA = 188;
VK_MINUS = 189;
VK_PERIOD = 190;
VK_SLASH = 191;
VK_BACKQUOTE = 192;
VK_LEFTBRACKET = 219;
VK_BBACKSLASH = 220;
VK_RIGHTBRACKET = 221;
VK_QUOTE = 222;
// Conts for 0 and 1 for GetDriveType()
DRIVE_UNKNOWN = 0;
DRIVE_UNASSIGNED = 1;
// Range limits on int type vars
MAXSMALLINT = high(smallint);
MINSMALLINT = low(smallint);
MINWORD = low(word);
MAXSHORTINT = high(shortint);
MINSHORTINT = low(shortint);
MAXBYTE = high(byte);
MINBYTE = low(byte);
MAXLONGWORD = high(longword);
MINLONGWORD = low(longword);
MAXSTRING = high(integer);
// Characters that are invalid for file names
INVALID_FILE_CHARS = ['\','/','*','?','<','>','|'];
type
// General usage types
EApplicationFail = class(Exception);
float = double;
TSex = (sxUnknown,sxMale,sxFemale);
TSqlRunMode = (sqlOpen,sqlOpenTerminate,sqlExec,sqlExecTerminate);
TJustifyMenuMode = (jsmRight,jsmLeft,jsmToggle);
TCharTypes = (chAlpha,chDigit,chHex,chUpper,chLower,chWhitespace,
chPunctuation,chSign,chAnsi,chControl,chOperator);
TCharTypesSet = set of TCharTypes;
TCpuFeature = (cpuNoCPUID,cpuNonIntel,cpuOnChipFPU,
cpuVirtualModeExtensions,cpuDebuggingExtensions,
cpuPageSizeExtensions,cpuTimeStampCounter,
cpuModelSpecificRegisters,cpuPhysicalAddressExtensions,
cpuMachineCheckExtensions,cpuCMPXCHG8B,cpuOnChipAPIC,
cpuFastSystemCall,cpuMemoryRangeRegisters,cpuPageGlobalEnable,
cpuMachineCheckArchitecture,cpuConditionalMoveInstruction,
cpuPageAttributeTable,cpu32bitPageSzExtension,
cpuProcessorSerialNum,cpuMMXTechnology,cpuFastFloatingPoint,
cpuSIMDExtensions);
TCpuFeatures = set of TCpuFeature;
function BDEinstalled(TerminateOnErr : boolean = false;
ShowErrorDlg : boolean = false;
InfoList : TStrings = nil) : string;
function CopyFrom(const S : string; StartPos : integer) : string;
function DefaultMessagingProfile : string;
function DeleteTree(const SrcPath : string) : boolean;
function FontInstalled(Const FontName : string) : boolean;
function Darker(Color : TColor; Percent : integer) : TColor;
function MixColors(C1,C2 : TColor) : TColor;
function Lighter(Color : TColor; Percent : integer) : TColor;
function ContrastColor(Color : TColor) : TColor;
function GetDAOversion : integer; overload;
function GetDAOversion(SList : TStrings) : integer; overload;
function StuffStr(const SrcStr,DestStr : string; Position : integer) : string;
function BrowseFolder(const title : string;Flags : longword = 0) : string;
function ServiceStart(aMachine,aServiceName : string) : boolean;
function ServiceStop(aMachine,aServiceName : string) : boolean;
function ServiceGetStatus(sMachine, sService: string ): DWord;
function ServiceGetStatusName(sMachine,sService: string ): string;
function WinCalcValue : string;
function MemCompare(P1,P2 : pointer; Len : integer) : integer;
function SearchTree(StartDir,FileToFind : string;
out FileNamePath : string) : boolean;
function StrInList(const SrcStr : string; List : TStrings) : boolean;
function AndEqual(Value,AndValue : longword) : boolean;
function BiosDate : string;
function BiosID : string;
function toString(Value : Variant) : string;
function IntToBase(Value : integer; Base : byte;Digits : byte = 0): string;
function BaseToint(Value : string; Base : byte) : integer;
function StartsWith(const SourceStr,TargetStr : string;
IgnoreCase : boolean = false) : boolean;
function EndsWith(const SourceStr,TargetStr : string;
IgnoreCase : boolean = false) : boolean;
function GetOSName : string;
function NetFindNextUnmapped : char;
function NetMappedName(LocalDrive : char) : string;
function NetUnMapDrive(LocalDrive : char) : dword;
function NetMapDrive(LocalDrive : char; const RemoteDrivePath : string;
UserName : string = ''; Password : string = '') : dword;
function GetLastWinErr(ShowDialog : boolean = true;
ErrNum : integer = 0) : string;
function GetMACAddress: string;
function GetParamVal(const TaggedParm : string;
IgnoreCase : boolean = true) : string;
function GetCpuSerialNum : string;
function StrToSex(SexStr : string) : TSex;
function SexToStr(Sex : TSex) : string;
function StrToFileName(const FileName : string; ReplaceInvalidWith : char = '_') : string;
function RoundIt(Value : extended; Decimals : integer = 2) : extended;
function Sign(Value : extended) : integer;
function LastChar(StrVar : string) : char;
function IsNullStr(const StrVar : string) : boolean;
function PosEx(const SubStr,TargetS : string; StartPos : integer = 1;
IgnoreCase : boolean = false) : integer;
function PosCount(const SubStr,TargetS : string; CountIndex : integer = 1) : integer;
function DeskTopLVhandle : THandle;
function CharTypeSet(Ch : char) : TCharTypesSet;
function NumToLetters(Number : extended; Currency : string = 'Rands';
Cents : string = 'Cents') : string;
function Discount(Value : double; PercentDisc : double) : double; overload;
function Discount(Value : double; PercentDisc : double;
out DiscAmnt : double) : double; overload;
function MarkUp(Value : double; PercentMarkup : double) : double; overload;
function MarkUp(Value : double; PercentMarkup : double;
out MarkupAmnt : double) : double; overload;
function GPpercent(Cost,Sell : double) : double; overload;
function GPpercent(Cost,Sell : double;
out MarkupPercent : double) : double; overload;
function IntToBin(IValue : Int64; NumBits : word = 64) : string;
function BinToInt(BinStr : string) : Int64;
function HexToInt(HexStr : string) : Int64;
function CPUSpeed : integer;
function MyIPAddress : string;
function DateStamp : string;
function FmtStrToInt(IntString : string) : integer;
function FmtStrToIntDef(IntString : string; DefValue : integer) : integer;
function FmtStrToFloat(FloatString : string) : extended;
function StrZero(Value : integer; Len : byte) : string;
function Pad(const S : string; L : byte; FillChar : char = ' ') : string;
function PadL(const S : string; L : byte; FillChar : char = ' ') : string;
function PadR(const S : string; L : byte; FillChar : char = ' ') : string;
function Space(N : byte) : string;
function Replicate(C : char; L : word) :string;
function Proper(StrVar : string) :string;
function Zdiv(N1,N2 : integer) : integer; overload;
function Zdiv(N1,N2 : extended) : extended; overload;
function Empty(const Arg : array of const) : boolean;
function AlphaOnly(StrVar : string) : string;
function NumericOnly(StrVar : string) : string;
function FileInUse(FileName : string) : boolean;
function GetLogonName(UCase : boolean = true) : string;
function GetDomainName(User : string = '') : string;
function GetDiskSerialNum(DriveLetter : char; HexValue : boolean = false) : string;
function GetExePath : string;
function GetExeName : string;
function GetExeFile : string;
function GetAliasPath(Aname : string) : string;
function ExtractCommaDelim(var Source : string) : string;
function ExtractField(var Source : string; Delimiter : string) : string; overload;
function ExtractField(StrList : TStrings; const Source : string; Delimiter : string) : string; overload;
function StripParen(const StrVar : string) : string;
function WinExecWait(const ChangeDir : string; const ExecutableFile : string;
Params : string = ''; WindowStyle : LongWord = SW_SHOWNORMAL) : boolean;
function FileVersion(const FileName : string = '') : string;
function FileVersionInfo(const FieldName : string; const FileName : string = '') : string;
function FileVersionLanguage(const FileName : string = '') : string;
function UnixPathToDosPath(FName : string) : string;
function DosPathToUnixPath(FName : string) : string;
function EnCryptString(StrVar : string; EncryptKey : string = '') : string;
function DeCryptString(StrVar : string; EncryptKey : string = '') : string;
function CharCount(SearchChar : char; Buffer : string) : integer;
function RPos(SubStr : string; S : string) : integer;
function GetUniqueFileName : string;
function IsNetworked : boolean;
function CheckBackSlash(Path : string; MustHave : boolean = true) : string;
function ConfirmDlg(MessageStr : string; DoBeep : boolean = true) : boolean;
function DateToStr4(TargetDate : TDateTime) : string;
function StrToDate4(DateStr : string; ErrMessage : boolean = true) : TDateTime;
function StrToDateTime4(const DateTimeStr : string) : TDateTime;
function StrToDateTime(DateStr : string) : TDateTime;
function DateToStr(TargetDate : TDateTime) : string;
function StrToDate(DateStr : string) : TDateTime;
function IsDefaultPrinter(Showmessage : boolean = true) : boolean; overload;
function IsDefaultPrinter(out DefaultPrinterName : string;
Showmessage : boolean = true) : boolean; overload;
function FontStyleToInt(FS : TFontStyles) : integer;
function IntToFontStyle(Num : integer) : TFontStyles;
function WindowsDir : string;
function WindowsSystemDir : string;
function ComputerName : string;
function GetFileTimes(FileName : string;
out Created : TDateTime;
out Modified : TDateTime;
out Accessed : TDateTime) : boolean;
function CopyPdxTable(SrcTable,DstTable : string;
out ErrMess : string;
Overwrite : boolean = true) : boolean;
function iif(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Char): Char; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: extended): extended; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload;
function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;
function BitIsSet(WordValue : word; BitNum : word) : boolean; overload;
function BitIsSet(WordValue : word; BitNums : array of word) : boolean; overload;
procedure LoadCLSID(StringList : TStrings; Separator : char = '*';
IncludeVersionIndependent : boolean = true);
procedure StrGridToHTML(const FileName : string; StrGrid : TStringGrid;
const Heading : string = '';
TextColor : TColor = clBlack;
TableBgColor : TColor = clAqua);
procedure StrGridToRTF(const Filename : string; SG : TStringGrid);
procedure DisableTaskManager(const State : boolean);
procedure DisableLockWorkStation(const State : boolean);
procedure DisableChangePassword(const State : boolean);
procedure DisableLogoff(const State : boolean);
procedure DisableShutdown(const State : boolean);
procedure DisableRegistryTools(const State : boolean);
procedure DisableScreenSaver(const State : boolean);
procedure SetScreenSaverTimeOut(const TimeMilSec : integer);
procedure PrintStrGrid(StringGrid : TStringGrid; ShowSetupDialog : boolean = true);
procedure SetCheckBoxCheck(cb : TCheckBox; Checked : boolean);
procedure GoURL(const WebUrl : string);
procedure SetTrackbarNarrow(TB : TTrackBar);
procedure CpyRecByName(Src,Dst : TDataSet);
procedure CpyRecByNum(Src,Dst : TDataSet);
procedure NetDomainList(StringList : TStrings);
procedure SetBit(var WordValue : word; BitNum : word); overload;
procedure SetBit(var WordValue : word; BitNums : array of word); overload;
procedure ClearBit(var WordValue : word; BitNum : word); overload;
procedure ClearBit(var WordValue : word; BitNums : array of word); overload;
procedure ToggleBit(var WordValue : word; BitNum : word); overload;
procedure ToggleBit(var WordValue : word; BitNums : array of word); overload;
procedure CreateTreeMenus(Path : string; Menu : TMainMenu;
Root : TMenuItem; ListImage : TImageList );
procedure JustifyMenuItem(Menu : TMainMenu; MenuItem : TMenuItem;
Justify : TJustifyMenuMode = jsmRight);
procedure ScreenShot(X1,X2,Y1,Y2 : integer; BMap : TBitMap); overload;
procedure ScreenShot(BMap : TBitMap); overload;
procedure ScreenShot(X1,X2,Y1,Y2 : integer; JMap : TJPEGImage); overload;
procedure ScreenShot(JMap : TJPEGImage); overload;
procedure AllowMultiline(theControl : TWinControl);
procedure ShredFile(const FileName : string);
procedure QueryToStrGrid(Query : TQuery; StrGrid : TStringGrid; Titles : boolean = true);
procedure GetScreenXY(TargetControl : TControl; out X : integer;
out Y : integer);
procedure VarToStr(var Source; Count : integer; out StrVar : string;
ReplaceChar0With : char = #0);
procedure StrToVar(const StrVar : string; out UtypedVar);
procedure SetLastChar(var StrVar : string; CharValue : char);
procedure GetWindowsList(TS : TStrings);
procedure SwapMem(var Source,Dest; Len : integer);
procedure StringScan(const Buffer : string; const Mask : string; LinesList : TStrings);
procedure ErrorDlg(MessageStr : string; DoBeep : boolean = true);
procedure InfoDlg(MessageStr : string; DoBeep : boolean = true);
procedure WarningDlg(MessageStr : string; DoBeep : boolean = true);
procedure SetMaxSize(Form : TForm);
procedure HaltApplication(UserMessage : string; ShowMessage : boolean = false);
procedure Delay(ms : longword);
procedure LoadGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
procedure SaveGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
procedure SetAutoStart(AppTitleKey : string; Status : boolean = true);
procedure RemoveFormCaption(Form : TForm);
procedure SortStr(var StrVar : string);
procedure ReplaceChars(var StrVar : string; ThisChar,WithChar : char;
IgnoreCase : boolean = false);
procedure IncLimit(var X : longint; Limit : longint;
RollOverVal : longint = 0; IncBy : longint = 1);
procedure DecLimit(var X : longint; Limit : longint;
RollUnderVal : longint = 0; DecBy : longint = -1);
procedure TextOutAngle(ParentCanvas : TCanvas;
X,Y : integer;
const FontName : string;
FontSize,Angle : integer;
const Txt : string;
Color : TColor = clBlack;
Transparent : boolean = true);
procedure AnimateShowWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
procedure AnimateHideWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
procedure DisableKeyboard;
procedure EnableKeyboard;
{ ======================================================================== }
implementation
const ENCRYPT_KEY = 'Put some string Here That is Meaningfull';
// Win ver constants
cOsUnknown : integer = -1;
cOsWin95 : integer = 0;
cOsWin98 : integer = 1;
cOsWin98SE : integer = 2;
cOsWinME : integer = 3;
cOsWinNT : integer = 4;
cOsWin2000 : integer = 5;
cOsWhistler : integer = 6;
var oldHook : HHook; // Used by keyboard enable/disable
// Keyboard intercept routine
function KeyBoardHook(Code : integer; wParam : word; lParam: longint) : longint;
begin
if (Code < 0) then
Result := CallNextHookEx(oldHook,Code,wParam,lParam)
else
Result := 1;
end;
procedure DisableKeyboard;
begin
oldHook := SetWindowsHookEx(WH_KEYBOARD,@KeyBoardHook,HInstance,0);
end;
procedure EnableKeyboard;
begin
if (oldHook <> 0) then begin
UnhookWindowshookEx(oldHook);
oldHook := 0;
end;
end;
// =============================================
// Simple password encode/decode routines
// Changed to EncryptString and DecryptString
// was .....
// function EncodePassword(Pass : string) : string;
// function DecodePassword(Pass : string) : string;
// =============================================
function EnCryptString(StrVar : string; EncryptKey : string = '') : string;
var Cmd,Key : string;
i,KIdx : integer;
Ch : byte;
begin
Cmd := StringOfChar(' ',length(StrVar));
KIdx := 1;
if EncryptKey = '' then Key := ENCRYPT_KEY else Key := EncryptKey;
for i := 1 to length(StrVar) do begin
Ch := byte(StrVar[i]) xor byte(Key[KIdx]);
if Ch = 0 then Ch := 255;
Cmd[i] := char(Ch);
inc(KIdx);
if KIdx > length(Key) then KIdx := 1;
end;
Result := Cmd;
end;
function DeCryptString(StrVar : string; EncryptKey : string = '') : string;
var Cmd,Key : string;
Ch : byte;
i,KIdx : integer;
begin
Cmd := StringOfChar(' ',length(StrVar));
KIdx := 1;
if EncryptKey = '' then Key := ENCRYPT_KEY else Key := EncryptKey;
for i := 1 to length(StrVar) do begin
Ch := byte(StrVar[i]);
if Ch = 255 then Ch := 0;
Cmd[i] := char(Ch xor byte(Key[KIdx]));
inc(KIdx);
if KIdx > length(Key) then KIdx := 1;
end;
Result := Cmd;
end;
// ===================================
// Convert a string to a TSex var
// ===================================
function StrToSex(SexStr : string) : TSex;
var BChar : char;
Cmd : TSex;
begin
Cmd := sxUnknown;
if (length(SexStr) > 0) then begin
BChar := UpCase(SexStr[1]);
case BChar of
'M' : Cmd := sxMale;
'F' : Cmd := sxFemale;
end;
end;
Result := Cmd;
end;
// ==================================
// Convert a TSex var to a string
// ==================================
function SexToStr(Sex : TSex) : string;
var Cmd : string;
begin
Cmd := 'Unknown';
case Sex of
sxMale : Cmd := 'Male';
sxFemale : Cmd := 'Female';
end;
Result := Cmd;
end;
// ===============================================
// Convert a string to a valid file name
// Invalid chars are replaced by ReplaceWith
// Default replace char is UNDER_LINE
// ===============================================
function StrToFileName(const FileName : string;
ReplaceInvalidWith : char = '_') : string;
var Cmd : string;
i : integer;
begin
Cmd := FileName;
for i := 1 to length(FileName) do
if Cmd[i] in INVALID_FILE_CHARS then
Cmd[i] := ReplaceInvalidWith;
Result := Cmd;
end;
// ===================================
// Return Count of a char in a string
// ===================================
function CharCount(SearchChar : char; Buffer : string) : integer;
var C,i : integer;
begin
C := 0;
if length(Buffer) > 0 then
for i := 1 to length(Buffer) do
if Buffer[i] = SearchChar then inc(C);
Result := C;
end;
// ====================================================
// Str to Numeric Functions same as Delphi's StrToInt,
// StrToIntDef,StrToFloat.
// allows formatted strings eg. 9,143,654
// ====================================================
function FmtStrToInt(IntString : string) : integer;
var i : byte;
s : string;
sign : integer;
begin
s := '';
sign := 1;
for i := 1 to length(IntString) do begin
if IntString[i] = '-' then sign := -1;
if IntString[i] in ['0'..'9'] then s := s + IntString[i];
end;
Result := StrToInt(s) * sign;
end;
function FmtStrToIntDef(IntString : string; DefValue : integer) : integer;
var i : byte;
s : string;
sign,v : integer;
begin
s := '';
sign := 1;
for i := 1 to length(IntString) do begin
if IntString[i] = '-' then sign := -1;
if IntString[i] in ['0'..'9'] then s := s + IntString[i];
end;
try
v := StrToInt(s) * sign;
except
v := DefValue;
end;
Result := v;
end;
function FmtStrToFloat(FloatString : string) : extended;
var i : byte;
s : string;
sign : extended;
begin
s := '';
sign := 1.0;
for i := 1 to length(FloatString) do begin
if FloatString[i] = '-' then sign := -1.0;
if FloatString[i] in ['0'..'9','.'] then s := s + FloatString[i];
end;
try
Result := StrToFloat(s) * sign;
except
Result := 0;
end;
end;
{ ===================================== }
{ Execute a program like WINEXE() }
{ But WAIT for the program to terminate }
{ before returning to the calling app }
{ Returns true or false. }
{ ===================================== }
function WinExecWait(const ChangeDir : string;
const ExecutableFile : string;
Params : string = '';
WindowStyle : LongWord = SW_SHOWNORMAL) : boolean;
var p : TProcessInformation;
s : TStartupInfo;
PParams : PChar;
Cmd : boolean;
CDir : string;
begin
CDir := GetCurrentDir;
s.cb := SizeOf(TStartupInfo);
s.wShowWindow := WindowStyle;
s.lpDesktop := nil;
s.dwFlags := STARTF_USESHOWWINDOW;
s.lpReserved := nil;
s.lpTitle := nil;
s.cbReserved2 := 0;
s.lpReserved2 := nil;
if trim(ChangeDir) <> '' then SetCurrentDir(ChangeDir);
if trim(Params) = '' then
PParams := PChar(ExecutableFile)
else begin
// if Params[1] <> ' ' then Params := ' ' + Params; W2000 ???
if Params[1] <> ' ' then Params := '"' + ExecutableFile + '" ' + Params ;
PParams := PChar(Params);
end;
// Following does not work in W2000
// if CreateProcess(PChar(ExecutableFile),PParams,nil,nil,true,0,nil,nil,s,p) then begin
if CreateProcess(nil,PParams,nil,nil,true,0,nil,nil,s,p) then begin
WaitForSingleObject(p.hProcess,INFINITE);
CloseHandle(p.hProcess);
CloseHandle(p.hThread);
Cmd := true;
end
else
Cmd := false;
SetCurrentDir(CDir);
Result := Cmd;
end;
{ ============================== }
{ Convert Unix Path to Dos Path }
{ and vice-versa }
{ ============================== }
function UnixPathToDosPath(FName : string) : string;
var i : integer;
begin
for i := 1 to length(FName) do if FName[i] = '/' then FName[i] := '\';
Result := FName;
end;
function DosPathToUnixPath(FName : string) : string;
var i : integer;
begin
for i := 1 to length(FName) do if FName[i] = '\' then FName[i] := '/';
Result := FName;
end;
// =============================================================
// Return the file version of a
// Win32 executable file. See FileVersionInfo for additional }
// =============================================================
function FileVersion(const FileName : string = '') : string;
var V1,V2,V3,V4 : word;
VerInfoSize, VerValueSize, Dummy : DWORD;
VerInfo : Pointer;
VerValue : PVSFixedFileInfo;
FName : string;
begin
try
if FileName = '' then
FName := GetExePath + GetExeFile
else
FName := trim(FileName);
VerInfoSize := GetFileVersionInfoSize(PChar(FName), Dummy);
GetMem(VerInfo, VerInfoSize);
try
GetFileVersionInfo(PChar(FName), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
finally
FreeMem(VerInfo, VerInfoSize);
end;
Result := IntToStr(V1) + '.' + IntToStr(V2) + '.' +
IntToStr(V3) + '.' + IntToStr(V4);
except
Result := '';
end;
end;
// =================================================================
// Get info form file version eg. "Comments", "ProductName" etc.
// See Project/Options/Version Info for available Fields
// =================================================================
function FileVersionInfo(const FieldName : string;
const FileName : string = '') : string;
var VerInfoSize,VerValueSize,Dummy : DWORD;
Lang : string;
VerInfo : Pointer;
VerValue : ^word;
VerChar : PChar;
FName : string;
begin
VerChar := nil;
try
if FileName = '' then
FName := GetExePath + GetExeFile
else
FName := trim(FileName);
VerInfoSize := GetFileVersionInfoSize(PChar(FName),Dummy);
GetMem(VerInfo,VerInfoSize);
try
GetFileVersionInfo(PChar(FName),0,VerInfoSize,VerInfo);
VerQueryValue(VerInfo,'\VarFileInfo\Translation',
Pointer(VerValue),VerValueSize);
Lang := IntToHex(VerValue^,4);
inc(VerValue);
Lang := Lang + IntToHex(VerValue^,4);
VerQueryValue(VerInfo,PChar('\StringFileInfo\' + Lang + '\' + FieldName),
Pointer(VerChar),VerValueSize);
if VerChar <> nil then begin
Result := VerChar;
SetLength(Result,StrLen(PChar(Result)))
end
else
Result := '';
finally
FreeMem(VerInfo,VerInfoSize);
end;
except
Result := '';
end;
end;
function FileVersionLanguage(const FileName : string = '') : string;
var VerInfoSize,VerValueSize,Dummy : DWORD;
VerInfo : Pointer;
Lang : string;
VerValue : ^DWORD;
FName : string;
begin
SetLength(Lang,257);
try
if FileName = '' then
FName := GetExePath + GetExeFile
else
FName := trim(FileName);
VerInfoSize := GetFileVersionInfoSize(PChar(FName),Dummy);
GetMem(VerInfo,VerInfoSize);
try
GetFileVersionInfo(PChar(FName),0,VerInfoSize,VerInfo);
VerQueryValue(VerInfo,'\VarFileInfo\Translation',
Pointer(VerValue),VerValueSize);
VerLanguageName(VerValue^,PChar(Lang),256);
Result := Lang;
SetLength(Result,StrLen(PChar(Result)))
finally
FreeMem(VerInfo,VerInfoSize);
end;
except
Result := '';
end;
end;
{ ==================================== }
{ Return a string with it's }
{ Parenthesis stripped. }
{ eg. "Freddy" will return Freddy }
{ [Koos] will return Koos }
{ ==================================== }
function StripParen(const StrVar : string) : string;
begin
Result := copy(StrVar,2,length(StrVar)-2);
end;
{ ==================================== }
{ Return a boolean of state of file }
{ false = File is NOT open on network }
{ true = file is open on network }
{ ==================================== }
function FileInUse(FileName : string) : boolean;
var F : file;
IsInUse : boolean;
begin
AssignFile(F,FileName);
try
Reset(F);
CloseFile(F);
IsInUse := false;
except
IsInUse := true;
end;
Result := IsInUse;
end;
// =================================================
// Return true/false if string is in string list
// =================================================
function StrInList(const SrcStr : string; List : TStrings) : boolean;
var Cmd : boolean;
i : integer;
CmpStr : string;
begin
Cmd := false;
CmpStr := UpperCase(trim(SrcStr));
for i := 0 to List.Count - 1 do begin
if CmpStr = Uppercase(trim(List[i])) then begin
Cmd := true;
break;
end;
end;
Result := Cmd;
end;
{ =========================== }
{ Return a string of N spaces }
{ =========================== }
function Space(N : byte) : string;
begin
Space := StringOfChar(' ',N);
end;
{ ========================================== }
{ Replicate returns a string of C that is }
{ L characters long. OBSOLETE }
{ Use StringofChar instead !!!!!!!
{ ========================================== }
function Replicate(C : char; L : word) :string;
begin
Result := StringOfChar(C,L);
end;
{ =================================================== }
{ Returns a string left padded with zeros for L bytes }
{ =================================================== }
function StrZero(Value : integer; Len : byte) : string;
begin
Result := FormatFloat(StringOfChar('0',Len),Value);
end;
{ ======================================= }
{ Right justify a string an pad remaining }
{ space with blanks or truncate if < L }
{ ======================================= }
function PadR(const S : string; L : byte; FillChar : char = ' ') : string;
begin
Result := Pad(S,L,FillChar);
end;
function Pad(const S : string; L : byte; FillChar : char = ' ') : string;
var Cmd : string;
begin
Cmd := trim(S);
if L < length(Cmd) then
Cmd := Copy(Cmd,1,L)
else
Cmd := Cmd + StringOfChar(FillChar,L - length(Cmd));
Result := Cmd;
end;
{ ====================================== }
{ Right justify a string }
{ ====================================== }
function PadL(const S : string; L : byte; FillChar : char = ' ') : string;
var Cmd : string;
begin
Cmd := trim(S);
if L < length(Cmd) then
Cmd := Copy(Cmd,1,L)
else
Cmd := StringOfChar(FillChar,L - length(S)) + S;
Result := Cmd;
end;
// =====================================
// Like copy, but does not need LEN
// =====================================
function CopyFrom(const S : string; StartPos : integer) : string;
begin
Result := copy(S,StartPos,MAXSTRING);
end;
{ ==================================== }
{ Return a proper name from a var }
{ ==================================== }
function Proper(StrVar : string) :string;
var Upit : boolean;
RetStr : string;
I,Olen : word;
S : string[1];
begin
Upit := true;
RetStr := '';
Olen := length(StrVar);
StrVar := trim(Lowercase(StrVar));
for I := 1 to length(StrVar) do begin
S := copy(StrVar,I,1);
if Upit or (S = ' ') or (S = '.') then begin
S := upcase(S[1]);
Upit := (S = ' ') or (S = '.');
end;
RetStr := RetStr + S;
end;
Result := Pad(RetStr,Olen);
end;
{ =================================== }
{ Eliminate DIVIDE by zero error }
{ of two reals. }
{ Zdiv returns 0 if divisor is zero }
{ Overload to accomodate int and real }
{ =================================== }
function Zdiv(N1,N2 : extended) : extended; overload;
var Cmd : extended;
begin
Cmd := 0.00;
if N2 <> 0.0 then Cmd := N1 / N2;
Result := Cmd;
end;
function Zdiv(N1,N2 : integer) : integer; overload;
var Cmd : integer;
begin
Cmd := 0;
if N2 <> 0 then Cmd := N1 div N2;
Result := Cmd;
end;
{ ================================ }
{ Return true if var type is empty }
{ param passed as [Xvar] }
{ ================================ }
function Empty(const Arg : array of const) : boolean;
begin
Result := false;
case Arg[0].VType of
vtInteger : if Arg[0].VInteger = 0 then Result := true;
vtBoolean : if not Arg[0].VBoolean then Result := true;
vtChar : if Arg[0].VChar in [#0,#32] then Result := true;
vtExtended : if abs(Arg[0].VExtended^) < 0.000001 then Result := true;
vtString : if trim(Arg[0].VString^) = '' then Result := true;
vtPointer : if Arg[0].VPointer = nil then Result := true;
vtPchar : if trim(StrPas(Arg[0].VPchar)) = '' then Result := true;
else
MessageBeep(MB_ICONHAND);
if MessageDlg(' BAD PARAMETER' + CrLf + CrLf +
'Invalid Type Sent To FUNCTION EMPTY( [ Xvar ] )' + CrLf +
CrLf + ' INTEGER,BOOLEAN,CHAR,EXTENDED' + CrLf +
' STRING,POINTER or PCHAR Expected' + CrLf
,mtError,[mbAbort,mbIgnore],0) = 3 then
Application.Terminate;
end;
end;
// ==============================================================
// Same as Borland POS() except returns POS of LAST occurance
// ==============================================================
function RPos(SubStr : string; S : string) : integer;
var i : integer;
begin
SubStr := ReverseString(SubStr);
S := ReverseString(S);
i := pos(SubStr,S);
if i <> 0 then i := (length(S) + 1) - (i + length(SubStr) - 1);
Result := i;
end;
{ ================================================= }
{ Return Alpha Characters only from a passed string }
{ ================================================= }
function AlphaOnly(StrVar : string) : string;
var RetStr : string;
i : integer;
begin
RetStr := '';
for i := 1 to length(StrVar) do
if StrVar[i] in ['A'..'Z','a'..'z'] then RetStr := RetStr + StrVar[i];
Result := RetStr;
end;
{ =================================================== }
{ Return Numeric Characters only from a passed string }
{ =================================================== }
function NumericOnly(StrVar : string) : string;
var RetStr : string;
i : integer;
begin
RetStr := '';
for I := 1 to length(StrVar) do
if StrVar[i] in ['0'..'9'] then RetStr := RetStr + StrVar[i];
Result := RetStr;
end;
// =============================
// Return Windows Logon Name
// =============================
function GetLogonName(UCase : boolean = true) : string; platform;
var Count : DWORD;
begin
Count := 257;
SetLength(Result,Count);
{$WARNINGS OFF}
Win32Check(GetUserName(PChar(Result),Count));
SetLength(Result,StrLen(PChar(Result)));
{$WARNINGS ON}
if UCase then Result := UpperCase(Result);
end;
function GetDomainName(User : string = '') : string; platform;
var Count1,Count2 : DWORD;
Sd : PSecurityDescriptor;
Snu : SID_Name_Use;
begin
Sd := nil;
Snu := SIDTypeUser;
Count1 := 0;
Count2 := 0;
if trim(User) = '' then User := GetLogonName(false);
{$WARNINGS OFF}
LookupAccountName(nil,PChar(User),Sd,Count1,PChar(Result),Count2,Snu);
SetLength(Result,Count2 + 1);
Sd := AllocMem(Count1);
try
if LookupAccountName(nil,PChar(User),Sd,Count1,PChar(Result),Count2,Snu) then
SetLength(Result,StrLen(PChar(Result)))
else
Result := '';
finally
FreeMem(Sd);
end;
{$WARNINGS ON}
end;
// =====================================
// Get the serial number from hard disk
// =====================================
function GetDiskSerialNum(DriveLetter : char; HexValue : boolean = false) : string;
var VolumeSerialNumber : DWORD;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
Cmd : string;
begin
Cmd := '';
try
GetVolumeInformation(PChar(DriveLetter + ':\'),
nil, 0, @VolumeSerialNumber,
MaximumComponentLength, FileSystemFlags,
nil, 0);
if HexValue then
Cmd := IntToHex(HiWord(VolumeSerialNumber), 4) +
'-' + IntToHex(LoWord(VolumeSerialNumber), 4)
else
Cmd := IntToStr(VolumeSerialNumber);
except end;
Result := Cmd;
end;
// ========================
// Various Program Paths
// ========================
function GetExePath : string;
begin
Result := ExtractFilePath(Application.ExeName);
end;
function GetExeFile : string;
begin
Result := ExtractFileName(Application.ExeName);
end;
function GetExeName : string;
var ExName : string;
begin
ExName := ExtractFileName(Application.ExeName);
Result := copy(ExName,1,pos('.',ExName)-1);
end;
function GetAliasPath(Aname : string) : string;
var i : integer;
L : TStringList;
Cmd : string;
begin
Cmd := '';
L := TStringList.Create;
Session.GetAliasParams(Aname,L);
for i := 0 to L.Count-1 do
if uppercase(copy(L[i],1,5)) = 'PATH=' then
Cmd := copy(L[i],6,length(L[i])) + '\';
L.Free;
Result := Cmd;
end;
{ ================================================================= }
{ Extracts a field from a string delimited by "Delimeter" }
{ The source string is returned with the field and delim removed }
{ ================================================================= }
function ExtractField(var Source : string; Delimiter : string) : string;
var Cmd : string;
L,P : integer;
begin
P := pos(Delimiter,Source);
if P = 0 then begin
Cmd := Source;
Source := '';
end
else begin
Cmd := '';
L := length(Source);
Cmd := copy(Source,1,P - 1);
L := L - (length(Cmd) + 1);
Source := copy(Source,P + 1,L);
end;
Result := Cmd;
end;
// Similar - but sets a string list
function ExtractField(StrList : TStrings; const Source : string;
Delimiter : string) : string; overload;
var S : string;
begin
StrList.Clear;
S := Source;
while S <> '' do begin
StrList.Add(ExtractField(S,'|'));
end;
end;
// ============================================================
// Returns a string list of lines sepparated by delimiters
// Similar to BAAN string.scan
// eg. StringScan(Buffer,'|||%|',StrLst)
// =============================================================
procedure StringScan(const Buffer : string; const Mask : string;
LinesList : TStrings);
var i : integer;
MainLine : string;
begin
LinesList.Clear;
MainLine := Buffer;
for i := 1 to length(Mask) do LinesList.Add(ExtractField(MainLine,Mask[i]));
LinesList.Add(MainLine);
end;
// =============================================================
// Insert and delete into a string starting at position
// =============================================================
function StuffStr(const SrcStr,DestStr : string; Position : integer) : string;
var Cmd : string;
begin
Cmd := DestStr;
Delete(Cmd,Position,length(SrcStr));
Insert(SrcStr,Cmd,Position);
Result := Cmd;
end;
{ ================================================================= }
{ Extracts a field from a string comma delimited and }
{ enclosed with quotes "" }
{ ================================================================= }
function ExtractCommaDelim(var Source : string) : string;
var Cmd : string;
L,i : integer;
begin
Cmd := '';
i := 2;
L := length(Source);
if (trim(Source) <> '') and (Source[1] = '"') then begin // Quotes
while (Source[i] <> '"') and (i <= L) do inc(i);
if Source[i] = '"' then begin
Cmd := StripParen(copy(Source,1,i));
Delete(Source,1,i+1); // Remove Field and comma
end;
end
else
if (trim(Source) <> '') and (Source[1] <> '"') then begin // Integer
while (Source[i] <> ',') and (i <= L) do inc(i);
Cmd := copy(Source,1,i-1);
Delete(Source,1,i); // Remove Field and comma
end;
Result := Cmd;
end;
// ====================================================
// Return a unique filename in Default TEMP Directory
// File is Created and Closed 0 bytes in length
// ====================================================
function GetUniqueFileName : string;
var Cmd : string;
TempPath : string;
begin
SetLength(Cmd,257);
SetLength(TempPath,257);
GetTempPath(257,PChar(TempPath));
GetTempFileName(PChar(TempPath),'Mah',0,PChar(Cmd));
if pos(#0, Cmd) > 0 then Cmd := copy(Cmd, 1, pos(#0, Cmd) - 1);
Result := Cmd;
end;
// ===============================================
// Return a sortable date/time string of NOW
// in format YYYY/MM/DD-HH:NN:SS:ZZZ
// ===============================================
function DateStamp : string;
begin
Result := FormatDateTime('yyyy/mm/dd hh:nn:ss:zzz',Now);
end;
{ ======================================== }
{ This is a FAST swap routine that swaps }
{ the contents of any 2 variables. }
{ The variables may be of any type but }
{ the sizeof the VAR must be passed in Len }
{ the variable L. ASSEMBLER }
{ ======================================== }
procedure SwapMem(var Source,Dest; Len : integer);
begin
asm
push edi
push esi
mov esi,Source
mov edi,Dest
mov ecx,Len
cld
@1:
mov al,[edi]
xchg [esi],al
inc si
stosb
loop @1
pop esi
pop edi
end;
end;
// ======================================
// Return true if attached to a network
// ======================================
function IsNetworked : boolean;
begin
Result := (GetSystemMetrics(SM_NETWORK) and 1 = 1);
end;
// ======================================
// Various Error Message Dialog boxes
// Short cuts of MessageDlg()
// ======================================
procedure ErrorDlg(MessageStr : string; DoBeep : boolean = true);
begin
if DoBeep then MessageBeep(MB_ICONHAND);
MessageDlg(MessageStr,mtError,[mbOk],0);
end;
procedure InfoDlg(MessageStr : string; DoBeep : boolean = true);
begin
if DoBeep then MessageBeep(MB_ICONEXCLAMATION);
MessageDlg(MessageStr,mtInformation,[mbOk],0);
end;
function ConfirmDlg(MessageStr : string; DoBeep : boolean = true) : boolean;
begin
if DoBeep then MessageBeep(MB_ICONQUESTION);
Result := (MessageDlg(MessageStr,mtConfirmation,[mbYes,mbNo],0) = mrYes);
end;
procedure WarningDlg(MessageStr : string; DoBeep : boolean = true);
begin
if DoBeep then MessageBeep(MB_ICONASTERISK);
MessageDlg(MessageStr,mtWarning,[mbOk],0);
end;
// =================================================
// Set Maximum form size without covering task bar
// =================================================
procedure SetMaxSize(Form : TForm);
var h : THandle;
r : TRect;
begin
h := FindWindow('Shell_TrayWnd',nil);
if h <> 0 then begin
GetWindowRect(h,r);
if r.Bottom - r.Top <= 6 then
Form.SetBounds(0,0,Screen.Width,Screen.Height)
else
if r.Left > 0 then
Form.setBounds(0,0,r.Left,Screen.Height)
else
if r.Right < Screen.Width - 10 then
Form.SetBounds(r.Right,0,Screen.Width - r.Right,Screen.Height)
else
if r.Bottom < Screen.Height - 10 then
Form.SetBounds(0,r.Bottom,Screen.Width,Screen.Height - r.Bottom)
else
Form.SetBounds(0,0,Screen.Width,r.Top)
end
else
Form.SetBounds(0,0,Screen.Width,Screen.Height);
end;
// ====================================================
// Strip or add backslash to directory path
// See includetrailingbackslash()
// ====================================================
function CheckBackSlash(Path : string; MustHave : boolean = true) : string;
begin
Path := trim(Path);
if MustHave and (length(Path) > 0) and (Path[length(Path)] <> '\') then
Path := Path + '\';
if not MustHave and (length(Path) > 0) and (Path[length(Path)] = '\') then
delete(Path,length(Path),1);
Result := Path;
end;
// =====================================
// Graceful application termination
// Cannot use halt in OnShow of Form
// =====================================
procedure HaltApplication(UserMessage : string; ShowMessage : boolean = false);
begin
if ShowMessage then ErrorDlg(UserMessage);
Application.Terminate;
Raise EApplicationFail.Create(UserMessage);
end;
// ======================================================================
// Date functions to overcome Borland's standard StrTodate() and
// DateToStr(), which require and return dates in format DD/MM/YY
// These functions workd the same but require and return dates in
// with 4 digit year in format DD/MM/YYYY
// ======================================================================
function DateToStr4(TargetDate : TDateTime) : string;
var yyyy,mm,dd : word;
begin
DecodeDate(Targetdate,yyyy,mm,dd);
Result := FormatFloat('00',dd) + '/' +
FormatFloat('00',mm) + '/' +
FormatFloat('0000',yyyy);
end;
function StrToDate4(DateStr : string; ErrMessage : boolean = true) : TDateTime;
var yyyy,mm,dd : word;
Cmd : TDateTime;
begin
try
dd := StrToIntDef(copy(DateStr,1,2),0);
mm := StrToIntDef(copy(DateStr,4,2),0);
yyyy := StrToIntDef(copy(DateStr,7,4),0);
Cmd := EncodeDate(yyyy,mm,dd);
except
on E:Exception do begin
if ErrMessage then MessageDlg(E.Message,mtError,[mbOk],0);
Cmd := 0.0;
end;
end;
Result := Cmd;
end;
// ====================================
// Convert string to a TDateTime
// Format dd/mm/yyyy hh:nn:ss
// hh:nn:ss is optional
// ====================================
function StrToDateTime4(const DateTimeStr : string) : TDateTime;
var yyyy,mm,dd,hh,nn,ss : word;
S : string;
P : integer;
Cmd : TDateTime;
begin
Cmd := 0.0;
hh := 0;
nn := 0;
ss := 0;
if length(DateTimeStr) > 0 then begin
S := DateTimeStr;
P := pos('/',S);
dd := StrToIntDef(copy(S,1,P - 1),0);
S := copy(S,P + 1,18);
P := pos('/',S);
mm := StrToIntDef(copy(S,1,P - 1),0);
S := copy(S,P + 1,18);
P := pos(' ',S);
if P = 0 then
yyyy := StrToIntDef(S,0)
else begin
yyyy := StrToIntDef(copy(S,1,P - 1),0);
S := copy(S,P + 1,18);
P := pos(':',S);
if P = 0 then
hh := StrToIntDef(S,0)
else begin
hh := StrToIntDef(copy(S,1,P - 1),0);
S := copy(S,P + 1,18);
P := pos(':',S);
if P = 0 then
nn := StrToIntDef(S,0)
else begin
nn := StrToIntDef(copy(S,1,P - 1),0);
S := copy(S,P + 1,18);
ss := StrToIntDef(S,0);
end;
end;
end;
try
Cmd := EncodeDate(yyyy,mm,dd) + EncodeTime(hh,nn,ss,0);
except
on E: Exception do begin
MessageDlg(E.Message,mtError,[mbOk],0);
Cmd := 0.0;
end;
end;
end;
Result := Cmd;
end;
// Override and Warn if using standard Delphi functions
function DateToStr(TargetDate : TDateTime) : string;
begin
InfoDlg('Rather use DateToStr4()'#13'It is NOT dependant on ShortDateFormat'+
#13'and uses fixed format DD/MM/YYYY');
Result := '**/**/****';
end;
function StrToDate(DateStr : string) : TDateTime;
begin
InfoDlg('Rather use StrToDate4()'#13'It is NOT dependant on ShortDateFormat'+
#13'and uses fixed format DD/MM/YYYY');
Result := 0;
end;
function StrToDateTime(DateStr : string) : TDateTime;
begin
InfoDlg('Rather use StrToDateTime4()'#13'It is NOT dependant on ShortDateFormat'+
#13'and uses fixed format DD/MM/YYYY HH:NN:SS');
Result := 0;
end;
// ===========================================
// Check if a default printer is installed
// ===========================================
function IsDefaultPrinter(Showmessage : boolean = true) : boolean; overload;
var FDevice,FDriver,FPort : array [0..254] of char;
FHandle : THandle;
CurrentPrinterName : string;
Cmd : boolean;
begin
Cmd := false;
try
if Printer.Handle <> 0 then begin
Printer.GetPrinter(FDevice,FDriver,FPort,FHandle);
CurrentPrinterName := FDevice;
if CurrentPrinterName <> '' then
Cmd := true
else begin
Cmd := false;
if ShowMessage then ErrorDlg('No Default Printer is Defined');
end;
end;
except
if ShowMessage then ErrorDlg('Cannot Open Default Printer');
Cmd := false;
end;
Result := Cmd;
end;
function IsDefaultPrinter(out DefaultPrinterName : string;
Showmessage : boolean = true) : boolean; overload;
var FDevice,FDriver,FPort : array [0..254] of char;
FHandle : THandle;
CurrentPrinterName : string;
Cmd : boolean;
begin
Cmd := false;
try
if Printer.Handle <> 0 then begin
Printer.GetPrinter(FDevice,FDriver,FPort,FHandle);
CurrentPrinterName := FDevice;
DefaultPrinterName := CurrentPrinterName;
if CurrentPrinterName <> '' then
Cmd := true
else begin
Cmd := false;
if ShowMessage then ErrorDlg('No Default Printer is Defined');
end;
end;
except
if ShowMessage then ErrorDlg('Cannot Open Default Printer');
Cmd := false;
end;
Result := Cmd;
end;
// ============================
// Delay for X miliseconds
// 1000 ms = 1 second
// ============================
procedure Delay(ms : longword);
var TheTime : longword;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do Application.ProcessMessages;
end;
// ===============================
// Convert Fontstyles to Integer
// ===============================
function FontStyleToInt(FS : TFontStyles) : integer;
var Cmd : integer;
begin
Cmd := 0;
if fsBold in FS then inc(Cmd);
if fsItalic in FS then inc(Cmd,2);
if fsUnderline in FS then inc(Cmd,4);
if fsStrikeOut in FS then inc(Cmd,8);
Result := Cmd;
end;
// ==========================================
// Is a font installed in the system ?
// ==========================================
function FontInstalled(const FontName : string) : boolean;
begin
Result := Screen.Fonts.IndexOf(FontName) > 0;
end;
// ===============================
// Convert Integer to TFontstyles
// ===============================
function IntToFontStyle(Num : integer) : TFontStyles;
var Cmd : TFontStyles;
begin
Cmd := [];
if (Num and 1) = 1 then Include(Cmd,fsBold);
if (Num and 2) = 2 then Include(Cmd,fsItalic);
if (Num and 4) = 4 then Include(Cmd,fsUnderline);
if (Num and 8) = 8 then Include(Cmd,fsStrikeout);
Result := Cmd;
end;
// ==========================================
// Get windows directorys
// ==========================================
(*
function WindowsDir : string;
var Dir : PChar;
WDir : string;
begin
GetMem(Dir,MAX_PATH);
GetWindowsDirectory(Dir,MAX_PATH);
WDir := string(Dir);
FreeMem(Dir);
if WDir[length(WDir)] <> '\' then WDir := WDir + '\';
Result := WDir;
end;
*)
function WindowsDir : string;
begin
SetLength(Result,255);
GetWindowsDirectory(PChar(Result),255);
SetLength(Result,StrLen(PChar(Result)));
end;
(*
function WindowsSystemDir : string;
var Dir : PChar;
WDir : string;
begin
GetMem(Dir,MAX_PATH);
GetSystemDirectory(Dir,MAX_PATH);
WDir := string(Dir);
FreeMem(Dir);
if WDir[length(WDir)] <> '\' then WDir := WDir + '\';
Result := WDir;
end;
*)
function WindowsSystemDir : string;
begin
SetLength(Result,255);
GetSystemDirectory(PChar(Result),255);
SetLength(Result,StrLen(PChar(Result)));
end;
function ComputerName : string; platform;
var Count : DWORD;
begin
Count := MAX_COMPUTERNAME_LENGTH + 1;
SetLength(Result,Count);
Win32Check(GetComputerName(PChar(Result),Count));
Setlength(Result,StrLen(PChar(Result)));
end;
// ================================================
// Load and Save TDBGrid Col settings from a file
// ================================================
procedure LoadGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
var FName : string;
begin
if DefaultToExePath then
FName := GetExePath + FileName
else
FName := FileName;
try
Grid.Columns.LoadFromFile(FileName);
except end;
end;
procedure SaveGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
var FName : string;
begin
if DefaultToExePath then
FName := GetExePath + FileName
else
FName := FileName;
try
Grid.Columns.SaveToFile(FileName);
except end;
end;
// ================================================================
// Return the three dates (Created,Modified,Accessed
// of a given filename. Returns FALSE if file cannot
// be found or permissions denied. Results are returned
// in TdateTime OUT parameters
// ================================================================
function GetFileTimes(FileName : string;
out Created : TDateTime;
out Modified : TDateTime;
out Accessed : TDateTime) : boolean;
var FileHandle : integer;
Cmd : boolean;
FTimeC,FTimeA,FTimeM : TFileTime;
LTime : TFileTime;
STime : TSystemTime;
begin
FileHandle := FileOpen(FileName,fmShareDenyNone);
Created := 0.0;
Modified := 0.0;
Accessed := 0.0;
if FileHandle < 0 then
Cmd := false
else begin
Cmd := true;
GetFileTime(FileHandle,@FTimeC,@FTimeA,@FTimeM);
FileClose(FileHandle);
// Created
FileTimeToLocalFileTime(FTimeC,LTime);
if FileTimeToSystemTime(LTime,STime) then begin
Created := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
Created := Created + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
end;
// Accessed
FileTimeToLocalFileTime(FTimeA,LTime);
if FileTimeToSystemTime(LTime,STime) then begin
Accessed := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
Accessed := Accessed + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
end;
// Modified
FileTimeToLocalFileTime(FTimeM,LTime);
if FileTimeToSystemTime(LTime,STime) then begin
Modified := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
Modified := Modified + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
end;
end;
Result := Cmd;
end;
// =========================================
// Get IP address of current machine
//==========================================
function MyIPAddress : string;
type TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
Cmd : string;
I : integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
Cmd := '';
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if (phe <> nil) then begin
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do begin
Cmd := StrPas(inet_ntoa(pptr^[I]^));
inc(I);
end;
WSACleanup;
end;
Result := Cmd;
end;
// ======================================
// Calculate the CPU speed in mhz
// ======================================
function CPUSpeed : integer;
const DELAYTIME = 500; // measure time in ms
var TimerHi,TimerLo: DWORD;
PriorityClass,Priority : integer;
begin
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess,REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh // rdtsc
mov TimerLo,eax
mov TimerHi,edx
end;
Sleep(DelayTime);
asm
dw 310Fh // rdtsc
sub eax,TimerLo
sbb edx,TimerHi
mov TimerLo,eax
mov TimerHi,edx
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := round(TimerLo / (1000.0 * DelayTime));
end;
// =================================================================
// Add/Delete currently running program to the AUTORUN
// section of the registry (W2000 should be OK)
// =================================================================
procedure SetAutoStart(AppTitleKey : string; Status : boolean = true);
const RUNKEY = '\Software\Microsoft\Windows\CurrentVersion\Run';
var WinReg : TRegistry;
begin
WinReg := TRegistry.Create;
try
WinReg.RootKey := HKEY_LOCAL_MACHINE;
if WinReg.OpenKey(RUNKEY,false) then begin
case Status of
false : WinReg.DeleteValue(AppTitleKey);
true : WinReg.WriteString(AppTitleKey,ParamStr(0));
end;
end;
finally
WinReg.Free;
end;
end;
// ========================================
// Remove the caption bar of a form.
// Normally called in OnCreate event
// ========================================
procedure RemoveFormCaption(Form : TForm);
begin
SetWindowLong(Form.Handle,GWL_STYLE,
GetWindowLong(Form.Handle,GWL_STYLE) AND NOT WS_CAPTION);
Form.ClientHeight := Form.Height;
Form.Refresh;
end;
// ===========================================
// Hex and Binary functions DELPHI forgot
// ===========================================
{ ===================================== }
{ Convert a HexString value to an Int64 }
{ Note : Last Char can be 'H' for Hex }
{ eg. '00123h' or '00123H' }
{ ===================================== }
function HexToInt(HexStr : string) : Int64;
var Cmd : Int64;
i : byte;
begin
HexStr := trim(HexStr);
if HexStr = '' then HexStr := '0';
HexStr := UpperCase(HexStr);
if HexStr[length(HexStr)] = 'H' then Delete(HexStr,length(HexStr),1);
Cmd := 0;
for i := 1 to length(HexStr) do begin
Cmd := Cmd shl 4;
if HexStr[i] in ['0'..'9'] then
Cmd := Cmd + (byte(HexStr[i]) - 48)
else
if HexStr[i] in ['A'..'F'] then
Cmd := Cmd + (byte(HexStr[i]) - 55)
else begin
Cmd := 0;
break;
end;
end;
Result := Cmd;
end;
{ ============================================== }
{ Convert an Int64 value to a binary string }
{ NumBits can be 64,32,16,8 to indicate the }
{ return value is to be Int64,DWord,Word }
{ or Byte respectively (default = 64) }
{ NumBits normally are only required for }
{ negative input values }
{ ============================================== }
function IntToBin(IValue : Int64; NumBits : word = 64) : string;
var Cmd : string;
begin
Cmd := '';
case NumBits of
32 : IValue := dword(IValue);
16 : IValue := word(IValue);
8 : IValue := byte(IValue);
end;
while IValue <> 0 do begin
Cmd := char(48 + (IValue and 1)) + Cmd;
IValue := IValue shr 1;
end;
if Cmd = '' then Cmd := '0';
Result := Cmd;
end;
{ ============================================== }
{ Convert a bit binary string to an Int64 value }
{ Note : Last Char can be 'B' for Binary }
{ eg. '001011b' or '001011B' }
{ ============================================== }
function BinToInt(BinStr : string) : Int64;
var i : byte;
Cmd : Int64;
begin
BinStr := trim(BinStr);
if BinStr = '' then BinStr := '0';
BinStr := UpperCase(BinStr);
if BinStr[length(BinStr)] = 'B' then Delete(BinStr,length(BinStr),1);
Cmd := 0;
for i := 1 to length(BinStr) do begin
if not (BinStr[i] in ['0','1']) then begin
Cmd := 0;
Break;
end;
Cmd := (Cmd shl 1) + (byte(BinStr[i]) and 1) ;
end;
Result := Cmd;
end;
// =======================================
// Generic integer to base conversions
// =======================================
const B36 : PChar = ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ');
function IntToBase(Value : integer; Base : byte;
Digits : byte = 0): string;
var Cmd : string;
begin
Cmd := '';
repeat
Cmd := B36[Value mod Base] + Cmd;
Value := Value div Base;
until (Value div Base = 0);
Cmd := B36[Value mod Base] + Cmd;
while length(Cmd) < Digits do Cmd := '0' + Cmd;
Result := Cmd;
end;
function BaseToint(Value : string; Base : byte) : integer;
var i : byte;
Cmd : integer;
begin
Cmd := 0;
for i := 1 to length(Value) do begin
if (pos(Value[i],B36)-1) < Base then
Cmd := Cmd * Base + (pos(Value[i], B36)-1)
else begin
Cmd := 0;
break;
end;
end;
Result := Cmd;
end;
// ================================
// Sales functions
// ================================
{ ===================================== }
{ Discount a Value by PercentDiscount% }
{ 2 Overloaded versions }
{ One returns the actual disc amount }
{ ===================================== }
function Discount(Value : double; PercentDisc : double) : double; overload;
begin
Result := (Value * (100.0 - PercentDisc)) * 0.01;
end;
function Discount(Value : double; PercentDisc : double;
out DiscAmnt : double) : double; overload;
var Cmd : double;
begin
Cmd := (Value * (100.0 - PercentDisc)) * 0.01;
DiscAmnt := Value - Cmd;
Result := Cmd;
end;
{ ===================================== }
{ Markup a Value by PercentMarkup% }
{ 2 Overloaded versions }
{ One returns the actual markup amount }
{ ===================================== }
function MarkUp(Value : double; PercentMarkup : double) : double; overload;
begin
Result := Value * (1.0 + (PercentMarkup * 0.01));
end;
function MarkUp(Value : double; PercentMarkup : double;
out MarkupAmnt : double) : double; overload;
var Cmd : double;
begin
Cmd := Value * (1.0 + (PercentMarkup * 0.01));
MarkupAmnt := Value * (PercentMarkup * 0.01);
Result := Cmd;
end;
{ ==================================== }
{ Returns the GP% of a selling and }
{ cost price. }
{ ==================================== }
function GPpercent(Cost,Sell : double) : double; overload;
var Cmd : double;
begin
if Sell < 0.0001 then
Cmd := 0.0
else
Cmd := (1.0 - (Cost / Sell)) * 100.0;
Result := Cmd;
end;
function GPpercent(Cost,Sell : double;
out MarkupPercent : double) : double; overload;
var Cmd : double;
begin
MarkupPercent := 0;
if Sell < 0.0001 then
Cmd := 0.0
else begin
Cmd := (1.0 - (Cost / Sell)) * 100.0;
if Cost > 0.0001 then
MarkUpPercent := ((Sell - Cost) / Cost) * 100.0;
end;
Result := Cmd;
end;
// ========================================
// Return X,Y SCREEN coords of a control
// ========================================
procedure GetScreenXY(TargetControl : TControl; out X : integer;
out Y : integer);
var P : TPoint;
begin
P.x := TargetControl.Left;
P.y := TargetControl.Top;
P := TargetControl.Parent.ClientToScreen(P);
X := P.x;
Y := P.y;
end;
// ===============================================
// Convert a number to an English Sentence
// ===============================================
function NumToLetters(Number : extended; Currency : string = 'Rands';
Cents : string = 'Cents') : string;
const MaxAmt = 4294967295.99;
NumArr : array [1..19] of string[9] =
('One','Two','Three','Four','Five','Six','Seven',
'Eight','Nine','Ten','Eleven','Twelve',
'Thirteen','Fourteen','Fifteen','Sixteen',
'Seventeen','Eighteen','Nineteen');
TenArr : array [1..9] of string[7] =
('Ten','Twenty','Thirty','Forty','Fifty',
'Sixty','Seventy','Eighty','Ninety');
var Cmd : string;
Decimals : extended;
function RecurseNumber(N : longword) : string;
begin
case N of
1..19 : Result := NumArr[N];
20..99 : Result := TenArr[N div 10] +
' ' + RecurseNumber(N mod 10);
100..999 : Result := NumArr[N div 100] +
' Hundred ' +
RecurseNumber(N mod 100);
1000..999999 : Result := RecurseNumber(N div 1000) +
' Thousand ' +
RecurseNumber(N mod 1000);
1000000..999999999 : Result := RecurseNumber(N div 1000000) +
' Million ' +
RecurseNumber(N mod 1000000);
1000000000..4294967295 : Result := RecurseNumber(N div 1000000000) +
' Billion ' +
RecurseNumber(N mod 1000000000);
end;
end;
begin
Cmd := '';
if (Number < 0.00) or (Number > MaxAmt) then
MessageDlg('NumToLetters() - Number out of range',mtError,[mbOk],0)
else begin
Decimals := Frac(Number) * 100.9;
if (Number >= 1.00) then begin
Cmd := RecurseNumber(Round(Int(Number))) + ' ' + Currency;
Cmd := Cmd + ' + ' + FormatFloat('00',Decimals) + ' ' + Cents;
end
else
if Decimals > 0.00 then
Cmd := RecurseNumber(Round(Decimals)) + ' ' + Cents
else
Cmd := 'Zero ' + Currency + ' Zero ' + Cents;
end;
Result := Cmd;
end;
// =============================================
// Return a set describing char attributes
// =============================================
function CharTypeSet(Ch : char) : TCharTypesSet;
const
CHARS_ALPHA = ['a'..'z','A'..'Z'];
CHARS_UPPER = ['A'..'Z'];
CHARS_LOWER = ['a'..'z'];
CHARS_DIGIT = ['0'..'9'];
CHARS_HEX = ['0'..'9','A'..'F','a'..'f'];
CHARS_WHITE = [#9..#13,' '];
CHARS_PUNCT = ['!','"','''','(',')',',','.',';',':','?','[',']'];
CHARS_SIGN = ['+','-'];
CHARS_ANSI = [#0..#127];
CHARS_CONTROL = [#0..#31];
CHARS_OPERATOR = ['+','-','*','/','^'];
var Cmd : TCharTypesSet;
begin
Cmd := [];
if Ch in CHARS_ALPHA then Include(Cmd,chAlpha);
if Ch in CHARS_DIGIT then Include(Cmd,chDigit);
if Ch in CHARS_HEX then Include(Cmd,chHex);
if Ch in CHARS_UPPER then Include(Cmd,chUpper);
if Ch in CHARS_LOWER then Include(Cmd,chLower);
if Ch in CHARS_WHITE then Include(Cmd,chWhitespace);
if Ch in CHARS_PUNCT then Include(Cmd,chPunctuation);
if Ch in CHARS_SIGN then Include(Cmd,chSign);
if Ch in CHARS_ANSI then Include(Cmd,chAnsi);
if Ch in CHARS_CONTROL then Include(Cmd,chControl);
if Ch in CHARS_OPERATOR then Include(Cmd,chOperator);
Result := Cmd;
end;
// =============================================================================
// One line if .. then .. else statements
// like Clipper iif()
// =============================================================================
function iif(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: char): char; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: integer): integer; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: cardinal): cardinal; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: extended): extended; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: boolean): boolean; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: pointer): pointer; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
function iif(const Condition: Boolean; const TruePart, FalsePart: int64): int64; overload;
begin
if Condition then
Result := TruePart
else
Result := FalsePart;
end;
// =========================================================
// Return Handle to Desktop ListView
// eg. SendMessage(DeskTopLVhandle,LVM_ALIGN,LVA_ALIGNLEFT)
// =========================================================
function DeskTopLVhandle : THandle;
var S : string;
LVH : THandle;
begin
LVH := FindWindow('ProgMan',nil);
LVH := GetWindow(LVH,GW_CHILD);
LVH := GetWindow(LVH,GW_CHILD);
SetLength(S,40);
GetClassName(LVH,PChar(S),39);
if PChar(S) <> 'SysListView32' then LVH := 0;
Result := LVH;
end;
// ===========================================
// Load a stringlist with all window titles
// ===========================================
var XTS : TStrings;
procedure GetWindowsList(TS : TStrings);
function EnumWindowsCode(Wnd : hWnd; Form : TForm) : Boolean; Export; StdCall;
var Buffer : array[0..99] of char;
begin
GetWindowText(Wnd,Buffer,100);
if StrLen(Buffer) <> 0 then XTS.Add(StrPas(Buffer));
Result := true;
end;
begin
TS.Clear;
XTS := TS;
EnumWindows(@EnumWindowsCode,0);
end;
// ================================
// JAVA like toString functions
// ================================
function toString(Value : Variant): string;
begin
case TVarData(Value).VType of
varSmallInt,
varInteger : Result := IntToStr(Value);
varSingle,
varDouble,
varCurrency : Result := FloatToStr(Value);
varDate : Result := FormatDateTime('dd/mm/yyyy', Value);
varBoolean : if Value then Result := 'T' else Result := 'F';
varString : Result := Value;
else
Result := '';
end;
end;
// =============================================================================
// PosEx - Same as standard Pos function, except that you also
// can specify the start position, and ignore the case.
// =============================================================================
function PosEx(const SubStr,TargetS : string;
StartPos : integer = 1;
IgnoreCase : boolean = false) : integer;
var Cmd : integer;
begin
if StartPos < 1 then StartPos := 1;
if StartPos = 1 then begin
if IgnoreCase then
Cmd := Pos(UpperCase(SubStr),UpperCase(TargetS))
else
Cmd := Pos(SubStr,TargetS);
end
else begin
if IgnoreCase then
Cmd := Pos(UpperCase(SubStr),UpperCase(Copy(TargetS,StartPos,Length(TargetS))))
else
Cmd := Pos(SubStr,Copy(TargetS,StartPos,Length(TargetS)));
if Cmd > 0 then Cmd := Cmd + StartPos - 1;
end;
Result := Cmd;
end;
// =============================================================================
// PosCount - Same as standard Pos function, except that you also
// can specify the index occurance of the string;
// =============================================================================
function PosCount(const SubStr,TargetS : string; CountIndex : integer = 1) : integer;
var i,Cmd,P : integer;
begin
if CountIndex < 1 then CountIndex := 1;
Cmd := 0;
for i := 1 to CountIndex do begin
P := pos(SubStr,copy(TargetS,Cmd + 1,MAX_PATH));
if (P = 0) then begin
Cmd := 0;
break;
end
else
Cmd := Cmd + P;
end;
Result := Cmd;
end;
// ==========================================================
// Misc String functions
// ==========================================================
function IsNullStr(const StrVar : string) : boolean;
begin
Result := length(StrVar) = 0;
end;
function LastChar(StrVar : string) : char;
var Cmd : char;
begin
Cmd := #0;
if length(StrVar) > 0 then Cmd := StrVar[length(StrVar)];
Result := Cmd;
end;
procedure SetLastChar(var StrVar : string; CharValue : char);
begin
if length(StrVar) > 0 then StrVar[length(StrVar)] := CharValue;
end;
procedure SortStr(var StrVar : string);
var S : string;
procedure QuickSort(L, R: integer);
var I,J : integer;
c : char;
begin
repeat
I := L;
J := R;
c := S[(L + R) shr 1];
repeat
while S[I] < c do inc(I);
while S[J] > c do dec(J);
if I <= J then begin
SwapMem(S[I],S[J],1);
inc(I);
dec(J);
end;
until I > J;
if L < J then QuickSort(L,J);
L := I;
until I >= R;
end;
begin
S := StrVar;
if length(StrVar) > 1 then begin
QuickSort(1,length(StrVar));
StrVar := S;
end;
end;
procedure ReplaceChars(var StrVar : string; ThisChar,WithChar : char;
IgnoreCase : boolean = false);
var i : integer;
begin
for i := 1 to length(StrVar) do begin
if IgnoreCase then begin
if UpCase(StrVar[i]) = UpCase(ThisChar) then StrVar[i] := WithChar;
end
else
if StrVar[i] = ThisChar then StrVar[i] := WithChar;
end;
end;
procedure VarToStr(var Source; Count : integer; out StrVar : string;
ReplaceChar0With : char = #0);
var Cmd : string;
i : integer;
begin
SetLength(Cmd,Count);
FillChar(Cmd,0,SizeOf(Cmd));
move(Source,Cmd[1],Count);
for i := 1 to Count do if Cmd[i] = #0 then
Cmd[i] := ReplaceChar0With;
StrVar := Cmd;
end;
procedure StrToVar(const StrVar : string; out UtypedVar);
begin
try move(StrVar[1],UTypedVar,length(StrVar)); except end;
end;
function StartsWith(const SourceStr,TargetStr : string;
IgnoreCase : boolean = false) : boolean;
begin
if not IgnoreCase then
Result := (copy(TargetStr,1,length(SourceStr)) = SourceStr)
else
Result := (copy(UpperCase(TargetStr),1,length(SourceStr)) = UpperCase(SourceStr));
end;
function EndsWith(const SourceStr,TargetStr : string;
IgnoreCase : boolean = false) : boolean;
begin
if not IgnoreCase then
Result := (copy(TargetStr,length(TargetStr) - length(SourceStr) + 1,MAXINT) = SourceStr)
else
Result := (copy(UpperCase(TargetStr),length(TargetStr) - length(SourceStr) + 1,MAXINT) = UpperCase(SourceStr));
end;
// ==========================================
// Inc and Dec value with limit rollover
// ==========================================
procedure IncLimit(var X : longint; Limit : longint;
RollOverVal : longint = 0; IncBy : longint = 1);
var XVal : longint;
begin
XVal := X;
if XVal = Limit then
XVal := RollOverVal
else
inc(XVal,IncBy);
X := XVal;
end;
procedure DecLimit(var X : longint; Limit : longint;
RollUnderVal : longint = 0; DecBy : longint = -1);
var XVal : longint;
begin
XVal := X;
if XVal = Limit then
XVal := RollUnderVal
else
dec(XVal,DecBy);
X := XVal;
end;
// ==================================================
// Populate a string grid from an open query
// ==================================================
procedure QueryToStrGrid(Query : TQuery; StrGrid : TStringGrid; Titles : boolean = true);
var mCol,mLin,FntWidth : integer;
begin
FntWidth := StrGrid.Font.Size;
Query.First;
if not Query.Eof then begin
StrGrid.ColCount := Query.FieldCount;
StrGrid.RowCount := Query.RecordCount + iif(Titles,1,0);
StrGrid.FixedCols := 0;
StrGrid.FixedRows := iif(Titles,1,0);
if Titles then for mCol := 0 To Query.FieldCount - 1 do
StrGrid.Cells[mCol,0] := Query.Fields[mCol].FieldName;
mLin := 0;
while not Query.Eof do begin
for mCol := 0 To Query.FieldCount - 1 do begin
StrGrid.Cells[mCol,mLin + StrGrid.FixedRows] :=
Query.Fields[mCol].AsString;
StrGrid.ColWidths[mCol] := Query.Fields[mCol].DisplayWidth * FntWidth;
end;
Query.Next;
inc(mLin);
end;
end;
end;
// =============================================
// Copy String Grid to RTF Word Doc
// =============================================
procedure WriteToStream(var Stream : TStream; s : string);
begin
Stream.Write(PChar(s)^,Length(s));
end;
function Text2Rtf(s : string) : string;
var s2 : string;
i : integer;
begin
s2 := '';
i := 1;
while i <= length(s) do begin
case byte(s[i]) of
92 : s2 := s2 + '\\';
123 : s2 := s2 + '\{';
125 : s2 := s2 + '\}';
128..255 : s2 := s2 + '\''' + IntToHex(byte(s[i]),2);
else s2 := s2 +s [i];
end;//
inc(i);
end;
Result := s2;
end;
procedure StrGridToRTF(const Filename : string; SG : TStringGrid);
var St : TStream;
f,r,CellWidth,CellPos : integer;
begin
St := TFileStream.Create(Filename,fmCreate);
try
//RTF header
WriteToStream(St,'{\rtf1\ansi\deff0\deflang1033');
WriteToStream(St,'{\fonttbl{\f0\fnil\fcharset1{\*\fname Arial;}Arial;}}');
WriteToStream(St,'\viewscale100\uc1\pard\f0\fs20\par');
CellWidth := 2988;
//Writing Grid Data
for r := 0 to SG.RowCount-1 do begin
WriteToStream(St,'{\trowd\trgaph70\trleft0\trrh230');
CellPos := CellWidth;
for f := 0 to SG.ColCount-1 do begin
WriteToStream(St,'\clvertalt\clbrdrt\brdrs\brdrw10');
WriteToStream(St,'\clbrdrl\brdrs\brdrw10');
WriteToStream(St,'\clbrdrb\brdrs\brdrw10');
WriteToStream(St,'\clbrdrr\brdrs\brdrw10');
WriteToStream(St,'\cellx'+inttostr(cellpos));
CellPos := CellPos + CellWidth;
end;
for f := 0 to SG.ColCount-1 do
WriteToStream(St,'\pard\plain\fs20\intbl ' + Text2Rtf(SG.Cells[f,r])+'\cell ');
WriteToStream(St,'\row }');
end;
//End of RTF file
WriteToStream(St,'\par }');
finally
if Assigned(St) then St.Free;
end;
end;
procedure StrGridToHTML(const FileName : string; StrGrid : TStringGrid;
const Heading : string = '';
TextColor : TColor = clBlack;
TableBgColor : TColor = clAqua);
var Txt : TextFile;
i,ii : integer;
BgColor,TxColor : string;
begin
// Convert TColor to HTML Hex Color
BgColor := IntToHex(GetRValue(TableBgColor),2) +
IntToHex(GetGValue(TableBgColor),2) +
IntToHex(GetBValue(TableBgColor),2);
TxColor := IntToHex(GetRValue(TextColor),2) +
IntToHex(GetGValue(TextColor),2) +
IntToHex(GetBValue(TextColor),2);
// Create output file
AssignFile(Txt,FileName);
Rewrite(Txt);
// HTML Header Info
WriteLn(Txt,'<HTML>');
WriteLn(Txt,'<HEAD>');
WriteLn(Txt,'<TITLE>' + ExtractFileName(FileName) + '</TITLE>');
WriteLn(Txt,'</HEAD>');
WriteLn(Txt);
WriteLn(Txt,'<BODY TEXT=#' + TxColor + ' BGCOLOR=#CCCCCC>');
WriteLn(Txt,'<H1>' + Heading + '</H1>');
WriteLn(Txt,'<TABLE WIDTH=100% CELLPADDING=2 CELLSPACING=2 ' +
'BGCOLOR=#' + BgColor + ' BORDER=1>');
// Column Descriptions
WriteLn(Txt,' <TR>');
for i := 0 to StrGrid.ColCount - 1 do
WriteLn(Txt,' <TH>' + StrGrid.Cells[i,0] + '</TH>');
WriteLn(Txt,' </TR>');
// Write out the Grid Data
for i := 1 to StrGrid.RowCount - 1 do begin
WriteLn(Txt,' <TR>');
for ii := 0 to StrGrid.ColCount - 1 do
WriteLn(Txt,' <TD>' + StrGrid.Cells[ii,i] + '</TD>');
WriteLn(Txt,' </TR>');
end;
// Footer
WriteLn(Txt,'</TABLE>');
WriteLn(Txt,'<P>');
WriteLn(Txt,'<H3>' + IntToStr(StrGrid.ColCount) + ' Rows</H3>');
WriteLn(Txt,'</BODY>');
WriteLn(Txt,'</HTML>');
CloseFile(Txt);
end;
// ============================================
// Overwrite file with char 0 and delete
// recovery is impossible
// ============================================
procedure ShredFile(const FileName : string);
const BUFFSIZE = $FFFE;
var Fle : file;
Buffer : pointer;
FSize : integer;
begin
GetMem(Buffer,BUFFSIZE);
FillChar(Buffer^,BUFFSIZE,0);
AssignFile(Fle,FileName);
try
Reset(Fle,1);
FSize := FileSize(Fle);
while FSize > 0 do begin
BlockWrite(Fle,Buffer^,min(FSize,BUFFSIZE));
dec(FSize,BUFFSIZE);
end;
CloseFile(Fle);
DeleteFile(FileName);
except end;
FreeMem(Buffer);
end;
// ============================================================
// Returns -1, or 1 according to the sign of the argument
// Zero returns 1
// ============================================================
function Sign(Value : extended) : integer;
var Cmd : integer;
begin
if Value < 0.0 then Cmd := -1 else Cmd := 1;
Result := Cmd;
end;
// =======================================
// Better Rounder ie. 10's,100's etc
// =======================================
function RoundIt(Value : extended; Decimals : integer = 2) : extended;
var Nominator : extended;
begin
Nominator := Power(10,Decimals);
Result := Round(Value * Nominator) / Nominator;
end;
// ========================================================================
// This will copy a Paradox or dBase table from one directory to another.
// Note that this does not use BDE aliases. It would be possible to do that
// by declaring parameters for the source and destination databases,
// respectively.
// ========================================================================
function CopyPdxTable(SrcTable,DstTable : string; out ErrMess : string;
Overwrite : boolean = true) : boolean;
var DB : TDatabase;
STbl,DTbl : string;
Cmd : boolean;
begin
Cmd := false;
ErrMess := '';
if (ExtractFilePath(SrcTable) = '') then
STbl := ExtractFilePath(Application.EXEName) + SrcTable
else
STbl := SrcTable;
if (ExtractFilePath(DstTable) = '') then
DTbl := ExtractFilePath(Application.EXEName) + DstTable
else
DTbl := DstTable;
if FileExists(STbl) then begin
DB := TDatabase.Create(nil);
with DB do begin
Connected := False;
DatabaseName := ExtractFilePath(SrcTable);
DriverName := 'STANDARD';
Connected := True;
end;
try
Check(DBICopyTable(DB.Handle,Overwrite,PChar(STbl),nil,PChar(DTbl)));
Cmd := true;
except
on E: Exception do ErrMess := 'CopyPdxTable() - ' + E.Message;
end;
DB.Free;
end
else
ErrMess := 'CopyPdxTable() - Table does not Exist.';
Result := Cmd;
end;
// ===================================================
// Get INTEL chip features using CPUID call
// ===================================================
function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;
const
FPU_FLAG = $0001;
VME_FLAG = $0002;
DE_FLAG = $0004;
PSE_FLAG = $0008;
TSC_FLAG = $0010;
MSR_FLAG = $0020;
PAE_FLAG = $0040;
MCE_FLAG = $0080;
CX8_FLAG = $0100;
APIC_FLAG = $0200;
SEP_FLAG = $0800;
MTRR_FLAG = $1000;
PGE_FLAG = $2000;
MCA_FLAG = $4000;
CMOV_FLAG = $8000;
PAT_FLAG = $10000;
PSE36_FLAG = $20000;
PSNUM_FLAG = $40000;
MMX_FLAG = $800000;
FXSR_FLAG = $1000000;
SIMD_FLAG = $2000000;
var IsIntel : boolean;
VendorID : array [0..12] of char;
IntelID : array [0..12] of char;
FeaturesFlag,CpuSignature : DWord;
Temp : DWord;
Cmd : TCpuFeatures;
CpuType : byte;
// Local routine to add to List and Return SET
procedure CheckFeature(FeatureFlag : DWord;
const Item : string;
cpuFeatureType : TCpuFeature);
begin
if FeaturesFlag and FeatureFlag = FeatureFlag then begin
if FeatureList <> nil then FeatureList.Add(Item);
include(Cmd,cpuFeatureType);
end;
end;
begin
Cmd := [];
if FeatureList <> nil then FeatureList.Clear;
IsIntel := false;
IntelId := 'GenuineIntel'#0;
VendorID := '------------'#0;
try
asm
// Determine Intel CPUID support.
push ebx
push esi
push edi
mov eax,0 // Set up for CPUID instruction
db 00fh // CPUID - Get Vendor and check INTEL
db 0a2h
mov dword ptr VendorId,ebx
mov dword ptr VendorId[+4],edx
mov dword ptr VendorId[+8],ecx
cmp dword ptr IntelId,ebx // Check if it is INTEL
jne @@EndCPUID
cmp dword ptr IntelId[+4],edx
jne @@EndCPUID
cmp dword ptr IntelId[+8],ecx
jne @@EndCPUID // Not an Intel processor
mov byte ptr IsIntel,1 // Set IsIntel to true
cmp eax,1 // Ensure 1 is valid input for CPUID
jl @@EndCPUID // Else jump to end
mov eax,1
db 00fh // CPUID - Get features,family.model etc.
db 0a2h
mov CpuSignature,eax
mov FeaturesFlag,edx
shr eax,8 // Isolate family
and eax,0fh
mov byte ptr CpuType,al // Set cputype with family
@@EndCPUID :
pop edi // Restore registers
pop esi
pop ebx
end;
// Check Features Mask if Intel
if IsIntel then begin
if FeatureList <> nil then begin
FeatureList.Add('CPU Family ' + IntToStr(CpuType));
Temp := (CpuSignature shr 4) and $0f;
FeatureList.Add('CPU Model ' + IntToStr(Temp));
Temp := CpuSignature and $0f;
FeatureList.Add('CPU Stepping ' + IntToStr(Temp));
end;
CheckFeature(FPU_FLAG,'On-Chip FPU',cpuOnChipFPU);
CheckFeature(VME_FLAG,'VirtualMode Extensions',cpuVirtualModeExtensions);
CheckFeature(DE_FLAG,'Debugging Extensions',cpuDebuggingExtensions);
CheckFeature(PSE_FLAG,'Page Size Extensions',cpuPageSizeExtensions);
CheckFeature(TSC_FLAG,'Time Stamp Counter',cpuTimeStampCounter);
CheckFeature(MSR_FLAG,'Model Specific Registers',cpuModelSpecificRegisters);
CheckFeature(PAE_FLAG,'Physical Address Extensions',cpuPhysicalAddressExtensions);
CheckFeature(MCE_FLAG,'Machine Check Extensions',cpuMachineCheckExtensions);
CheckFeature(CX8_FLAG,'CMPXCHG8B Instruction',cpuCMPXCHG8B);
CheckFeature(APIC_FLAG,'On Chip APIC',cpuOnChipAPIC);
CheckFeature(SEP_FLAG,'Fast System Call',cpuFastSystemCall);
CheckFeature(MTRR_FLAG,'Memory Type Range Registers',cpuMemoryRangeRegisters);
CheckFeature(PGE_FLAG,'Page Global Enable',cpuPageGlobalEnable);
CheckFeature(MCA_FLAG,'Machine Check Architecture',cpuMachineCheckArchitecture);
CheckFeature(CMOV_FLAG,'Conditional Move Instruction',cpuConditionalMoveInstruction);
CheckFeature(PAT_FLAG,'Page Attribute Table',cpuPageAttributeTable);
CheckFeature(PSE36_FLAG,'32 Bit Page Size Extension',cpu32BitPageSzExtension);
CheckFeature(PSNUM_FLAG,'Processor Serial Number',cpuProcessorSerialNum);
CheckFeature(MMX_FLAG,'Intel MMX Technology',cpuMMXTechnology);
CheckFeature(FXSR_FLAG,'Fast Floating Point Save and Restore',cpuFastFloatingPoint);
CheckFeature(SIMD_FLAG,'Streaming SIMD Extensions',cpuSIMDExtensions);
end
else begin
if FeatureList <> nil then FeatureList.Add('Non-Intel or >486 Chip - Features Unknown');
include(Cmd,cpuNonIntel);
end;
except
if FeatureList <> nil then FeatureList.Add('No CPUID Support');
include(Cmd,cpuNoCPUID);
end;
Result := Cmd;
end;
// =======================================
// Get serial num - 486 non-Intel ?????
// =======================================
function GetCpuSerialNum : string;
var dw1,dw2,dw3 : DWORD;
begin
asm
push ebx
push esi
push edi
xor eax,eax
db 00fh // CPUID
db 0a2h
mov eax,1
db 00fh // CPUID
db 0a2h
mov dw3,eax
mov eax,3
db 00fh // CPUID
db 0a2h
mov dw2,edx
mov dw1,ecx
pop edi
pop esi
pop ebx
end;
Result := IntToHex(HiWord(dw3),4) + '-' +
IntToHex(LoWord(dw3),4) + '-' +
IntToHex(HiWord(dw2),4) + '-' +
IntToHex(LoWord(dw2),4) + '-' +
IntToHex(HiWord(dw1),4) + '-' +
IntToHex(LoWord(dw1),4);
end;
// ==============================================
// Get a list of computer names on network
// and return in string list
// ==============================================
procedure NetDomainList(StringList : TStrings);
const MAXENTRIES = 200;
type TBuffer = array [1..MAXENTRIES] of TNetResource;
PTBuffer = ^TBuffer;
var EHandle1,EHandle2 : THandle;
MaxItems1,MaxItems2,
BufLen : longword;
Buffer1,Buffer2 : PTBuffer;
Network : TNetResource;
i,ii : longword;
Loop1,Loop2 : longword;
begin
StringList.Clear;
GetMem(Buffer1,SizeOf(TBuffer));
GetMem(Buffer2,SizeOf(TBuffer));
FillChar(Network,SizeOf(Network),0);
Network.dwScope := RESOURCE_GLOBALNET;
Network.dwType := RESOURCETYPE_DISK;
Network.dwUsage := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,0,
@Network,EHandle1) = NO_ERROR then begin
repeat
MaxItems1 := MAXENTRIES;
BufLen := SizeOf(TBuffer);
Loop1 := WNetEnumResource(EHandle1,MaxItems1,Buffer1,BufLen);
if Loop1 = NO_ERROR then begin
// Process array of TNetResource
for i := 1 to MaxItems1 do begin
if WNetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,0,
@Buffer1^[i],EHandle2) = NO_ERROR then begin
repeat
MaxItems2 := MAXENTRIES;
BufLen := SizeOf(TBuffer);
Loop2 := WNetEnumResource(EHandle2,MaxItems2,Buffer2,BufLen);
if Loop2 = NO_ERROR then
for ii := 1 to MaxItems2 do StringList.Add(Buffer2^[ii].lpRemoteName);
until Loop2 = ERROR_NO_MORE_ITEMS;
WNetCloseEnum(EHandle2);
end;
end;
end;
until Loop1 = ERROR_NO_MORE_ITEMS;
FreeMem(Buffer1);
FreeMem(Buffer2);
WNetCloseEnum(EHandle1);
end;
end;
function GetParamVal(const TaggedParm : string;
IgnoreCase : boolean = true) : string;
var Cmd : string;
i,Len : integer;
Comp1,Comp2 : string;
begin
Cmd := '';
Comp1 := TaggedParm + '=';
if IgnoreCase then Comp1 := UpperCase(Comp1);
Len := length(Comp1);
for i := 1 to ParamCount do begin
Comp2 := copy(ParamStr(i),1,Len);
if IgnoreCase then Comp2 := UpperCase(Comp2);
if (Comp1 = Comp2) then begin
Cmd := trim(copy(ParamStr(i),Len + 1,length(ParamStr(i))));
break;
end;
end;
Result := UpperCase(Cmd);
end;
// ================================
// Return computer mac address
// ================================
function GetMACAddress: string;
var AdapterList : TLanaEnum;
NCB : TNCB;
function GetAdapterInfo(Lana : Char): String;
var Adapter : TAdapterStatus;
Cmd : string;
begin
FillChar(NCB,SizeOf(NCB),0);
NCB.ncb_command := Char(NCBRESET);
NCB.ncb_lana_num := Lana;
if Netbios(@NCB) <> Char(NRC_GOODRET) then
Cmd := 'mac not found'
else begin
FillChar(NCB,SizeOf(NCB),0);
NCB.ncb_command := Char(NCBASTAT);
NCB.ncb_lana_num := Lana;
NCB.ncb_callname := '*';
FillChar(Adapter,SizeOf(Adapter),0);
NCB.ncb_buffer := @Adapter;
NCB.ncb_length := SizeOf(Adapter);
NetBios(@NCB);
// Win 98 fails even tho card is there
// if Netbios(@NCB) <> Char(NRC_GOODRET) then begin
// Result := 'mac not found';
// Exit;
// end;
Cmd := IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[5]), 2);
end;
Result := Cmd;
end;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBENUM);
NCB.ncb_buffer := @AdapterList;
NCB.ncb_length := SizeOf(AdapterList);
Netbios(@NCB);
if Byte(AdapterList.length) > 0 then
Result := GetAdapterInfo(AdapterList.lana[0])
else
Result := 'mac not found';
end;
// =====================================================
// Allow for multi-line captions in win controls
// Call first and the set caption programatically
// =====================================================
procedure AllowMultiline(theControl : TWinControl);
var dwStyle : longint;
begin
dwStyle := GetWindowLong(theControl.handle, GWL_STYLE) or BS_MULTILINE;
SetWindowLong(theControl.Handle, GWL_STYLE, dwStyle);
end;
// ======================================================
// Get windows error as a text message
// Option show error dialog
// Option error number - default = 0 (GetLastError)
// ======================================================
function GetLastWinErr(ShowDialog : boolean = true;
ErrNum : integer = 0) : string;
var Cmd : string;
Err : integer;
begin
if ErrNum <> 0 then
Err := ErrNum
else
Err := GetLastError;
Cmd := SysErrorMessage(Err);
if ShowDialog then
MessageDlg('Windows Error ' + IntToStr(Err) + #13#10 + Cmd,
mtError,[mbOk],0);
Result := Cmd;
end;
// ================================================================
// Map network drive eg. NetMapDrive('G','\\pgbbxb1\col1\data');
// returns NO_ERROR or win error number . use GetLastWinErr
// ================================================================
function NetMapDrive(LocalDrive : char; const RemoteDrivePath : string;
UserName : string = ''; Password : string = '') : dword;
var NetResource : TNetResource;
LocalD : string;
PcUserName,PcPassword : PChar;
begin
PcUserName := nil;
PcPassword := nil;
LocalD := LocalDrive + ':';
NetResource.dwType := RESOURCETYPE_DISK;
NetResource.lpLocalName := PChar(LocalD);
NetResource.lpRemoteName := PChar(RemoteDrivepath);
NetResource.lpProvider := '';
if UserName <> '' then PcUserName := PChar(UserName);
if Password <> '' then PcPassword := PChar(Password);
Result := WNetAddConnection2(NetResource,PcPassword,PcUserName,CONNECT_UPDATE_PROFILE);
end;
function NetUnMapDrive(LocalDrive : char) : dword;
var LocalD : string;
begin
LocalD := UpCase(LocalDrive) + ':';
Result := WNetCancelConnection2(PChar(LocalD),CONNECT_UPDATE_PROFILE,true);
end;
// ==============================
// Null string = NOT MAPPED
// ==============================
function NetMappedName(LocalDrive : char) : string;
var BuffLen : DWORD;
LocalID : string;
begin
Result := ' ';
LocalID := LocalDrive + ':';
BuffLen := MAX_PATH;
SetLength(Result,BuffLen);
WNetGetConnection(PChar(LocalID),PChar(Result),BuffLen);
SetLength(Result,StrLen(PChar(Result)));
Result := trim(Result);
end;
// ==================================
// Exclude A and B drives
// '' = No Maps Available
// ==================================
function NetFindNextUnmapped : char;
var i : integer;
Drive : char;
DrivePath : string;
begin
Drive := #0;
for i := 3 to 26 do begin
DrivePath := char(i + 64) + ':';
if GetDriveType(PChar(DrivePath)) = 1 then begin
Drive := char(i + 64);
NetUnMapDrive(Drive);
break;
end;
end;
Result := Drive;
end;
// ===================================
// Get windows os/type
// ===================================
function GetOSName : string;
var osVerInfo : TOSVersionInfo;
majorVer, minorVer : integer;
OsCode : integer;
begin
OsVerInfo.dwOsVersionInfoSize := SizeOf(TOsVersionInfo);
if GetVersionEx(OsVerInfo) then begin
majorVer := OsVerInfo.dwMajorVersion;
minorVer := OsVerInfo.dwMinorVersion;
case (OsVerInfo.dwPlatformId) of
VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
begin
if (majorVer <= 4) then
OsCode := cOsWinNT
else
if ((majorVer = 5) and (minorVer= 0)) then
OsCode := cOsWin2000
else
if ((majorVer = 5) and (minorVer = 1)) then
OsCode := cOsWhistler
else
OsCode := cOsUnknown;
end;
VER_PLATFORM_WIN32_WINDOWS : { Windows 9x/ME }
begin
if ((majorVer = 4) and (minorVer = 0)) then
OsCode := cOsWin95
else if ((majorVer = 4) and (minorVer = 10)) then begin
if (OsVerInfo.szCSDVersion[ 1 ] = 'A') then
OsCode := cOsWin98SE
else
OsCode := cOsWin98;
end else if (( majorVer = 4) and (minorVer = 90)) then
OsCode := cOsWinME
else
OsCode := cOsUnknown;
end;
else
OsCode := cOsUnknown;
end;
end else
OsCode := cOsUnknown;
if (OSCode = cOsUnknown) then
Result := '(Unkown O/S)'
else if (OSCode = cOsWin95) then
Result := 'Windows 95'
else if (OSCode = cOsWin98) then
Result := 'Windows 98'
else if (OSCode = cOsWin98SE) then
Result := 'Windows 98 2nd Edition'
else if ( OSCode = cOsWinME ) then
Result := 'Windows Millennium'
else if ( OSCode = cOsWinNT ) then
Result := 'Windows NT'
else if ( OSCode = cOsWin2000 ) Then
Result := 'Windows 2000 / NT 5'
else
Result := 'Microsoft Windows';
end;
// ===============================================
// Screen shot routines BMP and JPEG support
// ===============================================
procedure ScreenShotPrim(x : integer; y : integer;
Width : integer; Height : integer;
BMap : TBitMap);
var dc : HDC;
lpPal : PLOGPALETTE;
begin
if ((Width = 0) or (Height = 0)) then exit;
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
GetMem(lpPal,SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
FillChar(lpPal^,SizeOf(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)),#0);
lpPal^.palVersion := $300;
lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then BMap.Palette := CreatePalette(lpPal^);
FreeMem(lpPal,SizeOf(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
// copy from the screen to the bitmap
BitBlt(BMap.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
ReleaseDc(0,dc);
end;
procedure ScreenShot(X1,X2,Y1,Y2 : integer; BMap : TBitMap); overload;
begin
BMap.Width := X2 - X1;
BMap.Height := Y2 - Y1;
ScreenShotPrim(X1,Y1,BMap.Width,BMap.Height,BMap);
end;
procedure ScreenShot(BMap : TBitMap); overload;
begin
BMap.Width := Screen.Width;
BMap.Height := Screen.Height;
ScreenShotPrim(0,0,BMap.Width,BMap.Height,BMap);
end;
procedure ScreenShot(X1,X2,Y1,Y2 : integer; JMap : TJPEGImage); overload;
var BMap : TBitMap;
begin
BMap := TBitMap.Create;
BMap.Width := X2 - X1;
BMap.Height := Y2 - Y1;
ScreenShotPrim(X1,Y1,BMap.Width,BMap.Height,BMap);
JMap.Assign(BMap);
BMap.Free;
end;
procedure ScreenShot(JMap : TJPEGImage); overload;
var BMap : TBitMap;
begin
BMap := TBitMap.Create;
BMap.Width := Screen.Width;
BMap.Height := Screen.Height;
ScreenShotPrim(0,0,BMap.Width,BMap.Height,BMap);
JMap.Assign(BMap);
BMap.Free;
end;
// =========================
// Justify menu item
// =========================
procedure JustifyMenuItem(Menu : TMainMenu; MenuItem : TMenuItem;
Justify : TJustifyMenuMode = jsmRight);
var ItemInfo : TMenuItemInfo;
Buffer : array[0..80] of char;
begin
ItemInfo.cbSize := SizeOf(TMenuItemInfo);
ItemInfo.fMask := MIIM_TYPE;
ItemInfo.dwTypeData := Buffer;
ItemInfo.cch := SizeOf(Buffer);
GetMenuItemInfo(Menu.Handle,MenuItem.Command,false,ItemInfo);
case Justify of
jsmRight : ItemInfo.fType := ItemInfo.fType or MFT_RIGHTJUSTIFY;
jsmLeft : ItemInfo.fType := ItemInfo.fType and not MFT_RIGHTJUSTIFY;
jsmToggle : ItemInfo.fType := ItemInfo.fType xor MFT_RIGHTJUSTIFY;
end;
SetMenuItemInfo(Menu.Handle,MenuItem.Command,false,ItemInfo);
DrawMenuBar(Menu.WindowHandle);
end;
// ==========================================
// Create a tree menu into a TmenuItem
// ==========================================
const FEX = '.DOC.EXE.COM.HLP.INI.INF.TXT.BAT.DLL.SYS.VBX.OCX.VXD.FON.TTF.FOT';
procedure CreateTreeMenus(Path : string; Menu : TMainMenu;
Root : TMenuItem; ListImage : TImageList );
type pHIcon = ^HIcon;
var SR : TSearchRec;
Result : integer;
Item : TMenuItem;
SmallIcon : HIcon;
IconA : TIcon;
BitMapA : TBitMap;
Indice : integer;
IconOk : boolean;
procedure GetAssociatedIcon(FileName : TFilename;
pLargeIcon, PSmallIcon : pHIcon );
var IconIndex : word;
FileExt,FileType : string;
Reg : TRegistry;
p : integer;
p1,p2 : PChar;
begin
IconIndex := 0;
FileExt := UpperCase(ExtractFileExt(FileName));
if (((FileExt <> '.EXE' ) and (FileExt <> '.ICO')) or
(not(FileExists(FileName)))) then begin
Reg := NIL;
try
Reg := TRegistry.Create(KEY_QUERY_VALUE);
Reg.RootKey := HKEY_CLASSES_ROOT;
if (FileExt = '.EXE') then FileExt := '.COM';
if (Reg.OpenKeyReadOnly(FileExt)) then
try FileType := Reg.ReadString('');
finally Reg.CloseKey; end;
if ((FileType <> '' ) and
Reg.OpenKeyReadOnly(FileType + '\DefaultIcon')) then
try FileName := Reg.ReadString('');
finally Reg.CloseKey; end;
finally
Reg.Free;
end;
if (FileName <> '') then begin;
p1 := PChar(FileName);
p2 := StrRScan(p1,',');
if (p2 <> NIL) then begin
p := p2 - p1 + 1;
IconIndex := StrToInt(copy(FileName,p + 1,Length(FileName) - p ));
SetLength(FileName,p - 1);
end;
IconOk := (ExtractIconEx(PChar(FileName),IconIndex,PLargeIcon^,PSmallIcon^,1) <> 1);
end
else
IconOk := true;
end;
if IconOk then begin
try FileName := WindowsSystemDir + 'SHELL32.DLL';
except FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL'; end;
case pos(FileExt,FEX) of
1 : IconIndex := 1;
5,9 : IconIndex := 2;
13 : IconIndex := 23;
17,21 : IconIndex := 63;
25 : IconIndex := 64;
29 : IconIndex := 65;
33,37,41,45,49 : IconIndex := 66;
53 : IconIndex := 67;
57 : IconIndex := 68;
61 : IconIndex := 69;
else
IconIndex := 0;
end;
if ((ExtractIconEx(PChar(FileName),IconIndex,PLargeIcon^,
PSmallIcon^,1) <> 1 )) then begin
if (PLargeIcon <> NIL) then PLargeIcon^ := 0;
if (PSmallIcon <> NIL) then PSmallIcon^ := 0;
end;
end;
end;
begin
Menu.Images := ListImage;
if (Path[Length(Path)] <> '\' ) then Path := Path + '\';
Result := FindFirst(Path + '*.*',faDirectory,SR);
while (Result = 0) do begin
if (((SR.Attr and faDirectory ) <> 0) and (SR.Name <> '.')
and (SR.Name <> '..')) then begin
Item := TMenuItem.Create(Menu);
Item.Caption := SR.Name;
Item.ImageIndex := 0;
Root.Add(Item);
CreateTreeMenus(Path + SR.Name,Menu,Item,ListImage);
end;
if (((SR.Attr and faAnyFile) <> 0) and (SR.Name <> '.')
and (SR.Name <> '..' )) then begin
Item := TMenuItem.Create(Menu);
Item.Caption := SR.Name;
GetAssociatedIcon(sr.Name,NIL,@SmallIcon);
IconA := TIcon.Create;
IconA.Handle := SmallIcon;
BitMapA := TBitMap.Create;
BitMapA.Width := IconA.Width;
BitMapA.Height := IconA.Height;
BitMapA.Canvas.Draw(0,0,IconA );
BitMapA.TransparentMode := tmAuto;
Indice := ListImage.Add(BitMapA,NIL);
Item.ImageIndex := Indice;
Root.Add(Item);
IconA.Free;
BitMapA.Free;
end;
Result := FindNext( SR );
end;
try FindClose( SR ); except end;
end;
// ================================================
// Bios Information 95/98 and 2000/NT compatible
// ================================================
function BiosDate : string;
var Cmd : string;
WinReg : TRegistry;
begin
WinReg := nil;
Cmd := '????????';
try
// Win 9x
SetString(Cmd,PChar(Ptr($FFFF5)),10);
except
// Win 2000/NT
try
WinReg := TRegistry.Create;
WinReg.RootKey := HKEY_LOCAL_MACHINE;
if WinReg.OpenKeyReadOnly('\HARDWARE\DESCRIPTION\System') then
Cmd := WinReg.ReadString('SystemBiosDate');
finally
WinReg.Free;
end;
end;
Result := Cmd;
end;
function BiosID : string;
var Cmd : string;
Buffer : PChar;
WinReg : TRegistry;
begin
WinReg := nil;
Cmd := '????????';
try
// Win 9x
SetString(Cmd,PChar(Ptr($F0000)),$2000);
except
// Win 2000/NT
try
WinReg := TRegistry.Create;
WinReg.RootKey := HKEY_LOCAL_MACHINE;
if WinReg.OpenKeyReadOnly('\HARDWARE\DESCRIPTION\System') then begin
GetMem(Buffer,$2000);
WinReg.ReadBinaryData('SystemBiosVersion',Buffer^,$2000);
Cmd := WinReg.ReadString('Identifier') + ' ' + Buffer;
FreeMem(Buffer);
end;
finally
WinReg.Free;
end;
end;
Result := Cmd;
end;
// ==============================
// Bit manipulation routines
// ==============================
const BitValArr : array [0..15] of word = (1,2,4,8,16,32,64,128,256,512,1024,
2048,4096,8192,16384,32768);
procedure SetBit(var WordValue : word; BitNum : word); overload;
begin
WordValue := WordValue or BitValArr[BitNum];
end;
procedure SetBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
BitVals := 0;
for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
WordValue := WordValue or BitVals;
end;
procedure ClearBit(var WordValue : word; BitNum : word); overload;
begin
WordValue := (WordValue or BitValArr[BitNum]) xor BitValArr[BitNum];
end;
procedure ClearBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
BitVals := 0;
for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
WordValue := (WordValue or BitVals) xor BitVals;
end;
procedure ToggleBit(var WordValue : word; BitNum : word); overload;
begin
WordValue := WordValue xor BitValArr[BitNum];
end;
procedure ToggleBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
BitVals := 0;
for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
WordValue := WordValue xor BitVals;
end;
function BitIsSet(WordValue : word; BitNum : word) : boolean; overload;
begin
Result := (WordValue and BitValArr[BitNum] = BitValArr[BitNum]);
end;
function BitIsSet(WordValue : word; BitNums : array of word) : boolean; overload;
var BitVals,i : word;
begin
BitVals := 0;
for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
Result := (WordValue and BitVals = BitVals);
end;
function AndEqual(Value,AndValue : longword) : boolean;
begin
Result := (Value and AndValue) = AndValue;
end;
// ====================================
// TDataset Record copy routines
// ====================================
procedure CpyRecByName(Src,Dst : TDataSet);
var i : integer;
SField,DField : TField;
begin
for i :=0 to Src.FieldCount - 1 do begin
SField := Src.Fields[i];
DField := Dst.FindField(SField.FieldName);
if (DField <> nil) and
(DField.FieldKind = fkData) and not
DField.ReadOnly then begin
if (SField.DataType = ftString) or
(SField.DataType <> DField.DataType) then
DField.AsString := SField.AsString
else
DField.Assign(SField);
end;
end;
end;
procedure CpyRecByNum(Src,Dst : TDataSet);
var i : integer;
begin
for i :=0 to Src.FieldCount - 1 do begin
try
Dst.Fields[i].Value := Src.Fields[i].Value;
except
Dst.Fields[i].Assign(Src.Fields[i]);
end;
end;
end;
// ================================
// Recursive Search Tree for a file
// ================================
function SearchTree(StartDir,FileToFind : string;
out FileNamePath : string) : boolean; platform;
var Cmd : boolean;
// Recursive Dir Search
procedure SearchDir(DirPath : string);
var SearchRec : TSearchRec;
begin
DirPath := IncludeTrailingBackSlash(DirPath);
if FindFirst(DirPath + '*.*',faAnyFile,SearchRec) = 0 then begin
if Uppercase(SearchRec.Name) = FileToFind then begin
Cmd := true;
FileNamePath := DirPath + SearchRec.Name;
end
else begin
while not Cmd and (FindNext(SearchRec) = 0) do begin
if UpperCase(SearchRec.Name) = FileToFind then begin
Cmd := true;
FileNamePath := DirPath + SearchRec.Name;
end
else
if (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') and
((SearchRec.Attr and faDirectory) = faDirectory) then
SearchDir(DirPath + SearchRec.Name);
end;
end;
FindClose(SearchRec);
end;
end;
// SearchTree
begin
Screen.Cursor := crHourGlass;
FileToFind := Uppercase(FileToFind);
FileNamePath := '';
Cmd := false;
SearchDir(StartDir);
Screen.Cursor := crDefault;
Result := Cmd;
end;
// ==================================================
// compares memory 0=equal -1=P1<P2 1=P1>P2
// ==================================================
function MemCompare(P1,P2 : pointer; Len : integer) : integer;
var Cmd,i : integer;
B1,B2 : ^byte;
begin
Cmd := 0;
B1 := P1;
B2 := P2;
for i := 0 to Len do begin
if B1^ < B2^ then begin
Cmd := -1;
break;
end;
if B1^ > B2^ then begin
Cmd := 1;
break;
end;
inc(B1);
inc(B2);
end;
Result := Cmd;
end;
// ===========================================
// Retieve Text from Win Calculator
// Useful ??? - but interesting
// ===========================================
var ObjHnd : THandle;
function WinCalcProc(ChildWnd : THandle; lParam : integer): bool; stdcall;
var Nme : array[0..127] of char;
begin
GetClassName(ChildWnd,Nme,SizeOf(Nme));
Result := (Nme <> 'Static');
if not Result then ObjHnd := ChildWnd;
end;
function WinCalcValue : string;
var WndCalc : THandle;
CalcStr : string;
Txt : array[0..127] of char;
begin
ObjHnd := 0;
CalcStr := 'No Calc Avail';
WndCalc := FindWindow('SciCalc',nil);
if WndCalc <> 0 then begin
EnumChildWindows(WndCalc,@WinCalcProc,0);
if (ObjHnd <> 0) then begin
GetWindowText(ObjHnd,Txt,SizeOf(Txt));
CalcStr := Txt;
end;
end;
Result := CalcStr;
end;
// ==========================================================
// Service Routines
// aMachine is UNC path or local machine if left empty
// ==========================================================
function ServiceStart(aMachine,aServiceName : string) : boolean;
var h_manager,h_svc: SC_Handle;
svc_status: TServiceStatus;
Temp: PChar;
dwCheckPoint: DWord;
begin
svc_status.dwCurrentState := 1;
h_manager := OpenSCManager(PChar(aMachine), nil,SC_MANAGER_CONNECT);
if h_manager > 0 then begin
h_svc := OpenService(h_manager, PChar(aServiceName),
SERVICE_START or SERVICE_QUERY_STATUS);
if h_svc > 0 then begin
temp := nil;
if (StartService(h_svc,0,temp)) then
if (QueryServiceStatus(h_svc,svc_status)) then begin
while (SERVICE_RUNNING <> svc_status.dwCurrentState) do begin
dwCheckPoint := svc_status.dwCheckPoint;
Sleep(svc_status.dwWaitHint);
if (not QueryServiceStatus(h_svc,svc_status)) then break;
if (svc_status.dwCheckPoint < dwCheckPoint) then begin
// QueryServiceStatus didn't increment dwCheckPoint
break;
end;
end;
end;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := (SERVICE_RUNNING = svc_status.dwCurrentState);
end;
function ServiceStop(aMachine,aServiceName : string) : boolean;
var h_manager,h_svc : SC_Handle;
svc_status : TServiceStatus;
dwCheckPoint : DWord;
begin
h_manager:=OpenSCManager(PChar(aMachine),nil,SC_MANAGER_CONNECT);
if h_manager > 0 then begin
h_svc := OpenService(h_manager,PChar(aServiceName),
SERVICE_STOP or SERVICE_QUERY_STATUS);
if h_svc > 0 then begin
if(ControlService(h_svc,SERVICE_CONTROL_STOP,svc_status)) then begin
if(QueryServiceStatus(h_svc,svc_status))then begin
while(SERVICE_STOPPED <> svc_status.dwCurrentState)do begin
dwCheckPoint := svc_status.dwCheckPoint;
Sleep(svc_status.dwWaitHint);
if(not QueryServiceStatus(h_svc,svc_status))then begin
// couldn't check status
break;
end;
if(svc_status.dwCheckPoint < dwCheckPoint)then break;
end;
end;
end;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := (SERVICE_STOPPED = svc_status.dwCurrentState);
end;
// ================================
// Status Constants
// SERVICE_STOPPED
// SERVICE_RUNNING
// SERVICE_PAUSED
// SERVICE_START_PENDING
// SERVICE_STOP_PENDING
// SERVICE_CONTINUE_PENDING
// SERVICE_PAUSE_PENDING
// =================================
function ServiceGetStatus(sMachine, sService: string ): DWord;
var h_manager,h_svc : SC_Handle;
service_status : TServiceStatus;
hStat : DWord;
begin
hStat := 0;
h_manager := OpenSCManager(PChar(sMachine) ,nil,SC_MANAGER_CONNECT);
if h_manager > 0 then begin
h_svc := OpenService(h_manager,PChar(sService),SERVICE_QUERY_STATUS);
if h_svc > 0 then begin
if(QueryServiceStatus(h_svc, service_status)) then
hStat := service_status.dwCurrentState;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := hStat;
end;
function ServiceGetStatusName(sMachine,sService: string ): string;
var Cmd : string;
Status : DWord;
begin
Status := ServiceGetStatus(sMachine,sService);
case Status of
SERVICE_STOPPED : Cmd := 'STOPPED';
SERVICE_RUNNING : Cmd := 'RUNNING';
SERVICE_PAUSED : Cmd := 'PAUSED';
SERVICE_START_PENDING : Cmd := 'STARTING';
SERVICE_STOP_PENDING : Cmd := 'STOPPING';
SERVICE_CONTINUE_PENDING : Cmd := 'RESUMING';
SERVICE_PAUSE_PENDING : Cmd := 'PAUSING';
else
Cmd := 'UNKNOWN STATE';
end;
Result := Cmd;
end;
// ===================================================
// Change Track Bar to emulate narrow W200 style
// ===================================================
procedure SetTrackbarNarrow(TB : TTrackBar);
var H : integer;
begin
H := GetWindowLong(TB.Handle,GWL_STYLE);
SetWindowLong(TB.Handle,GWL_STYLE,H xor $20);
end;
// =============================================================================
// Pop up the standard 'Browse for computer' dialog box
// Flags combination of
// BIF_BROWSEFORCOMPUTER Only computers else OK button is grayed.
// BIF_BROWSEFORPRINTER Only printers else OK button is grayed.
// BIF_DONTGOBELOWDOMAIN Don't include network folders below the domain level.
// BIF_RETURNFSANCESTORS Only file system ancestors else OK button is grayed.
// BIF_RETURNONLYFSDIRS Only file system dirs else OK button is grayed.
// ==================================================================
function BrowseFolder(const title : string;
Flags : longword = 0) : string;
var BrowseInfo : TBrowseInfo;
IDRoot : PItemIDList;
Path : array[0..MAX_PATH] of char;
begin
// Get the Item ID for Network Neighborhood
SHGetSpecialFolderLocation(0,CSIDL_NETWORK,IDRoot);
ZeroMemory(@BrowseInfo,SizeOf(TBrowseInfo));
ZeroMemory(@path,MAX_PATH);
BrowseInfo.hwndOwner := 0;
BrowseInfo.pidlRoot := IDRoot;
BrowseInfo.lpszTitle := PChar(title);
BrowseInfo.pszDisplayName := @path;
BrowseInfo.ulFlags := Flags;
// Show the browse dialog, get the Item ID for the selected item and convert it to a path
SHBrowseForFolder(BrowseInfo);
Result := path;
end;
// ==============================
// Execute browser at URL
// ==============================
procedure GoURL(const WebUrl : string);
begin
ShellExecute(Application.Handle,'open',PChar(WebUrl),nil,nil,SW_NORMAL);
end;
// =============================================================
// Change a checbox state without triggerring OnCheck Event
// =============================================================
procedure SetCheckBoxCheck(cb : TCheckBox; Checked : boolean);
begin
cb.Perform(BM_SETCHECK,byte(Checked),0);
end;
// ==================================================================
// Draw text at ANGLE rotation
// ==================================================================
procedure TextOutAngle(ParentCanvas : TCanvas;
X,Y : integer;
const FontName : string;
FontSize,Angle : integer;
const Txt : string;
Color : TColor = clBlack;
Transparent : boolean = true);
var lf : TLogFont;
tf : TFont;
begin
with ParentCanvas do begin
if Transparent then
SetBKMode(ParentCanvas.Handle,Windows.TRANSPARENT)
else
SetBKMode(ParentCanvas.Handle,Windows.OPAQUE);
Font.Name := FontName;
Font.Size := FontSize;
Font.Color := Color;
tf := TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle, SizeOf(lf),@lf);
lf.lfEscapement := Angle * 10;
lf.lfOrientation := Angle * 10;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(X,Y,Txt);
end;
end;
(* =============================================================================
AnimateShowWin() - Use in Form.FormCreate()
AnimateHideWin() - Use in Form.FormClose()
dwFlags can be:
AW_SLIDE Uses slide animation. By default, roll animation is used.
This flag is ignored when used with AW_CENTER.
AW_BLEND Uses a fade effect. This flag can be used only if hwnd
is a top-level window.
AW_CENTER Makes the window appear to collapse inward if AW_HIDE is used
or expand outward if the AW_HIDE is not used.
AW_HOR_POSITIVE Animates the window from left to right. This flag can be
used with roll or slide animation. It is ignored when
used with AW_CENTER or AW_BLEND.
AW_HOR_NEGATIVE Animates the window from right to left. This flag can be used
with roll or slide animation. It is ignored when used with
AW_CENTER or AW_BLEND.
AW_VER_POSITIVE Animates the window from top to bottom. This flag can be used
with roll or slide animation. It is ignored when used with
AW_CENTER or AW_BLEND.
AW_VER_NEGATIVE Animates the window from bottom to top. This flag can be used
with roll or slide animation. It is ignored when used with
AW_CENTER or AW_BLEND.
Following are used internally by AnimateWin()
AW_ACTIVATE Activates the window. Do not use this value with AW_HIDE.
AW_HIDE Hides the window. By default, the window is shown.
*)
procedure AnimateWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD);
type
TAnimFunc = function(a : THandle; b,c : DWORD) : boolean; stdcall;
var Dll : integer;
AnimFunc : TAnimFunc;
begin
Dll := LoadLibrary('user32.dll');
if (Dll <> 0) then begin
AnimFunc := GetProcAddress(Dll,'AnimateWindow');
if (@AnimFunc <> nil) then AnimFunc(Form.Handle,dwTime,dwFlags);
Form.Invalidate;
FreeLibrary(Dll);
end;
end;
procedure AnimateShowWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
begin
AnimateWin(Form,dwFlags or AW_ACTIVATE,dwTime);
end;
procedure AnimateHideWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
begin
AnimateWin(Form,dwFlags or AW_HIDE,dwTime);
end;
// =============================================================================
// Print a string grid
// internal functions
// =============================================================================
procedure PrtStrGrid_SetColumnWidth(SG : TStringGrid; Cols : TList;
var Margins : TRect;
var Spacing : integer);
var i,k,w : integer;
begin
Printer.Canvas.Font.Style := [ fsBold ];
for i := 0 to pred(SG.ColCount) do
Cols.Add(Pointer(Printer.Canvas.TextWidth(SG.cells[i,0])));
Printer.Canvas.Font.Style := [];
for i := 1 to pred(SG.RowCount) do begin
for k := 0 to pred(SG.ColCount) do begin
w := Printer.Canvas.TextWidth(SG.Cells[k,i]);
if w > integer(Cols[k]) then Cols[k] := pointer(w);
end;
end;
w := 2 * Printer.Canvas.Font.PixelsPerInch div 3;
Margins := Rect(w,w,Printer.PageWidth - w,Printer.PageHeight - w);
Spacing := Printer.Canvas.Font.PixelsPerInch div 10;
w := 0;
for i := 0 to pred(Cols.Count) do
w := w + integer(Cols[i]) + Spacing;
w := w - Spacing;
if w > (Margins.Right - Margins.Left ) then begin
w := w - (Margins.Right - Margins.Left );
Cols[Cols.Count - 2] := pointer(integer(Cols[Cols.Count - 2]) - w);
end;
w := 0;
for i := 0 to pred(Cols.Count) do
w := w + integer(Cols[i]) + Spacing;
Margins.Right := w - Spacing + Margins.Left;
end;
procedure PrtStrGrid_DoLine(LineNo: integer;
SG : TStringGrid;
Cols : TList;
var Margins : TRect;
var Spacing : integer;
var y : integer);
var x,n,th : integer;
r : TRect;
begin
if length(SG.cells[1,LineNo]) <> 0 then begin
x := Margins.Left;
th := Printer.Canvas.TextHeight('�y');
for n := 0 to pred(Cols.Count) do begin
r := Rect(0,0,integer(Cols[n]),th);
OffsetRect(r,x,y);
Printer.Canvas.TextRect(r,x,y,SG.cells[n,lineno]);
x := r.Right + Spacing;
end; { for }
inc(y,th);
end;
end;
procedure PrtStrGrid_DoHeader(SG : TStringGrid;
Cols : TList;
var Margins : TRect;
var Spacing : integer;
var y : integer);
begin
y := Margins.Top;
Printer.Canvas.Font.Style := [fsBold];
PrtStrGrid_DoLine(0,SG,Cols,Margins,Spacing,y);
Printer.Canvas.Pen.Width := Printer.Canvas.Font.PixelsPerInch div 72;
Printer.Canvas.Pen.Color := clBlack;
Printer.Canvas.MoveTo(Margins.Left,y);
Printer.Canvas.Lineto(Margins.Right,y);
inc(y,2 * Printer.Canvas.Pen.Width);
Printer.Canvas.Font.Style := [ ];
end;
procedure PrtStrGrid_DoPrint(SG : TStringGrid;Cols : TList;
var Margins : TRect;
var Spacing : integer);
var i,y : integer;
begin
y:= 0;
for i := 1 to pred(SG.RowCount ) do begin
Application.ProcessMessages;
if y = 0 then PrtStrGrid_DoHeader(SG,Cols,Margins,Spacing,y);
PrtStrGrid_DoLine(i,SG,Cols,Margins,Spacing,y);
if y >= Margins.Bottom then begin
Printer.NewPage;
y := 0;
end;
end;
end;
// =============================================================================
// Print String Grid
// Public Library Call
// =============================================================================
procedure PrintStrGrid(StringGrid : TStringGrid; ShowSetupDialog : boolean = true);
var Margins : TRect;
Spacing : integer;
Cols : TList;
Setup : TPrinterSetupDialog;
CanPrint : boolean;
begin
Setup := nil;
CanPrint := true;
if ShowSetupDialog then begin
Setup := TPrinterSetupDialog.Create(nil);
CanPrint := Setup.Execute;
end;
if CanPrint then begin
Cols := TList.Create;
if Printer.Printing then printer.abort;
Printer.BeginDoc;
try
try
Printer.Canvas.Font.PixelsPerInch :=
GetDeviceCaps(Printer.Handle,logPixelsY);
Printer.Canvas.Font.Assign(StringGrid.font);
Printer.Canvas.Font.Color := clBlack;
Printer.Canvas.Pen.Color := clBlack;
PrtStrGrid_SetColumnWidth(StringGrid,Cols,Margins,Spacing);
Application.ProcessMessages;
PrtStrGrid_DoPrint(StringGrid,Cols,Margins,Spacing);
except
on E : Exception do ErrorDlg(E.Message);
end;
finally
if ShowSetupDialog then Setup.Free;
Cols.Free;
Printer.EndDoc;
end;
end;
end;
// ================================================================
// Check for BDE installed and Version
// ================================================================
function BDEinstalled(TerminateOnErr : boolean = false;
ShowErrorDlg : boolean = false;
InfoList : TStrings = nil) : string;
var RetVal : string;
BdeVer : SYSVersion;
M,D,H,N,S : word;
Y : smallint;
begin
RetVal := '';
try
Check(DbiGetSysVersion(BdeVer));
if (InfoList <> nil) then begin
InfoList.Clear;
InfoList.Add('ENGINE VERSION = ' + IntToStr(BdeVer.iVersion));
InfoList.Add('INTERFACE LEVEL = ' + IntToStr(BdeVer.iIntfLevel));
DbiDateDecode(BdeVer.DateVer,M,D,Y);
InfoList.Add('VERSION DATE = ' + FormatFloat('00',D) + '/' +
FormatFloat('00',M) + '/' +
FormatFloat('0000',Y));
DbiTimeDecode(BdeVer.TimeVer,H,N,S);
InfoList.Add('VERSION TIME = ' + FormatFloat('00',H) + ':' +
FormatFloat('00',N) + ':' +
FormatFloat('00',S div 1000));
end;
RetVal := IntToStr(BdeVer.iVersion);
except
RetVal := '';
if ShowErrorDlg then ErrorDlg('Borland Databse Engine (BDE)' + CrLf +
'is NOT Installed');
if TerminateOnErr then HaltApplication('');
end;
Result := RetVal;
end;
// ======================================
// Return Highest DAO installed
// ======================================
function GetDAOversion : integer; overload;
var Path : string;
Cmd,ThisVer : integer;
DirInfo : TSearchRec;
begin
Cmd := 0;
Path := ExtractFileDrive(WindowsDir) + '\Program Files\Common Files\' +
'Microsoft Shared\DAO\dao*.dll';
if FindFirst(Path,faAnyFile,DirInfo) = 0 then begin
ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
if ThisVer > Cmd then Cmd := ThisVer;
while FindNext(DirInfo) = 0 do begin
ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
if ThisVer > Cmd then Cmd := ThisVer;
end;
FindClose(DirInfo);
end;
Result := Cmd;
end;
function GetDAOversion(SList : TStrings) : integer; overload;
var Path : string;
Cmd,ThisVer : integer;
DirInfo : TSearchRec;
begin
SList.Clear;
Cmd := 0;
Path := ExtractFileDrive(WindowsDir) + '\Program Files\Common Files\' +
'Microsoft Shared\DAO\dao*.dll';
if FindFirst(Path,faAnyFile,DirInfo) = 0 then begin
ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
SList.Add(FormatFloat('0.00',ThisVer / 100.0));
if ThisVer > Cmd then Cmd := ThisVer;
while FindNext(DirInfo) = 0 do begin
ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
SList.Add(FormatFloat('0.00',ThisVer / 100.0));
if ThisVer > Cmd then Cmd := ThisVer;
end;
FindClose(DirInfo);
end;
Result := Cmd;
end;
// ========================================================
// Enable/Disable w2000 task manager from popping up
// ========================================================
procedure DisableTaskManager(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
true) then
Reg.WriteInteger('DisableTaskMgr',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Lock Computer
// ========================================================
procedure DisableLockWorkStation(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
true) then
Reg.WriteInteger('DisableLockWorkstation',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Change Password
// ========================================================
procedure DisableChangePassword(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
true) then
Reg.WriteInteger('DisableChangePassword',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Logoff
// ========================================================
procedure DisableLogoff(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
true) then
Reg.WriteInteger('NoLogoff',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Shutdown
// ========================================================
procedure DisableShutDown(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
true) then
Reg.WriteInteger('NoClose',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Registry Tools
// ========================================================
procedure DisableRegistryTools(const State : boolean);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
true) then
Reg.WriteInteger('DisableRegistryTools',integer(State));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Set Screen Saver Timeout
// ========================================================
procedure SetScreenSaverTimeOut(const TimeMilSec : integer);
var Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Policies\Microsoft\Windows\Control Panel\Desktop',
true) then
Reg.WriteString('ScreenSaveTimeOut',IntToStr(TimeMilSec));
finally
Reg.CloseKey;
Reg.Free;
end;
end;
// ========================================================
// Enable/Disable w2000 Screen Saver
// ========================================================
procedure DisableScreenSaver(const State : boolean);
begin
if State = True then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,0,nil,0);
if State = False then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,1,nil,0);
end;
// =================================================================
// Set a string list to GUID desc + Separator + OLE Class name
// =================================================================
procedure LoadCLSID(StringList : TStrings; Separator : char = '*';
IncludeVersionIndependent : boolean = true);
const REGKEY = 'Software\Classes\CLSID';
var WinReg : TRegistry;
KeyNames,SubKeyNames : TStringList;
i : integer;
KeyDesc : string;
ProgID,VersID : boolean;
begin
StringList.Clear;
KeyNames := TStringList.Create;
SubKeyNames := TStringList.Create;
WinReg := TRegistry.Create;
WinReg.RootKey := HKEY_LOCAL_MACHINE;
if WinReg.OpenKey(REGKEY,false) then begin
WinReg.GetKeyNames(KeyNames);
WinReg.CloseKey;
// Traverse list of GUID numbers eg. {00000106-0000-0010-8000-00AA006D2EA4}
for i := 1 to KeyNames.Count - 1 do begin
if WinReg.OpenKey(REGKEY + '\' + KeyNames[i],false) then begin
// Set which keys are available
ProgID := WinReg.KeyExists('ProgID');
VersID := WinReg.KeyExists('VersionIndependentProgID');
// "ProgID" Key
if ProgID then begin
KeyDesc := WinReg.ReadString(''); // Read (Default) value
if trim(KeyDesc) = '' then KeyDesc := KeyNames[i];
WinReg.CloseKey;
if WinReg.OpenKey(REGKEY + '\' + KeyNames[i] +
'\ProgID',false) then begin
StringList.Add(KeyDesc + Separator + WinReg.ReadString(''));
WinReg.CloseKey;
// "Version Independent" Key if present and requested
if IncludeVersionIndependent and VersID then begin
KeyDesc := KeyDesc + ' [Version Independent]';
if WinReg.OpenKey(REGKEY + '\' + KeyNames[i] +
'\VersionIndependentProgID',false) then begin
StringList.Add(KeyDesc + Separator + WinReg.ReadString(''));
WinReg.CloseKey;
end;
end;
end;
end
else
WinReg.CloseKey;
end;
end;
end;
WinReg.Free;
SubKeyNames.Free;
KeyNames.Free;
end;
// ===========================================
// Delete a dir tree and all children
// ===========================================
function DeleteTree(const SrcPath : string) : boolean;
var FileOpStruct : TShFileOpStruct;
begin
FileOpStruct.Wnd := Application.Handle;
FileOpStruct.wFunc := FO_DELETE;
FileOpStruct.pFrom := PChar(SrcPath);
FileOpStruct.pTo := nil;
FileOpStruct.fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
FileOpStruct.lpszProgressTitle := nil;
Result := (ShFileOperation(FileOpStruct) = 0);
end;
// ========================================================
// Functions to Darken,Lighten and mix colors by a percent
// ========================================================
function Darker(Color : TColor; Percent : integer) : TColor;
var R,G,B : byte;
begin
Percent := min(100,abs(Percent));
Color := ColorToRGB(Color);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
R := R - MulDiv(R,Percent,100);
G := G - MulDiv(G,Percent,100);
B := B - MulDiv(B,Percent,100);
Result := RGB(R,G,B);
end;
function Lighter(Color : TColor; Percent : integer) : TColor;
var R,G,B : byte;
begin
Percent := min(100,abs(Percent));
Color := ColorToRGB(Color);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
R := R + MulDiv(255 - R,Percent,100);
G := G + MulDiv(255 - G,Percent,100);
B := B + MulDiv(255 - B,Percent,100);
Result := RGB(R,G,B);
end;
function MixColors(C1,C2 : TColor) : TColor;
begin
Result := RGB((GetRValue(C1) + GetRValue(C2)) div 2,
(GetGValue(C1) + GetGValue(C2)) div 2,
(GetBValue(C1) + GetBValue(C2)) div 2);
end;
// =============================================
// Return a contrasting color to passed color
// =============================================
function ContrastColor(Color : TColor) : TColor;
var R,G,B : byte;
begin
Color := ColorToRGB(Color);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
if R < 220 then R := 255 else R := 0;
if G < 220 then G := 255 else G := 0;
if B < 220 then B := 255 else B := 0;
Result := RGB(R,G,B);
end;
// =======================================
// Return Default Outlook Profile
// =======================================
function DefaultMessagingProfile : string;
var WinReg : TRegistry;
Cmd : string;
begin
Cmd := '';
WinReg := TRegistry.Create;
if WinReg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles',false)then begin
Cmd := WinReg.ReadString('DefaultProfile');
WinReg.CloseKey;
end;
WinReg.Free;
Result := Cmd;
end;
end.
Feliratkozás:
Megjegyzések küldése (Atom)
Nincsenek megjegyzések:
Megjegyzés küldése