Black-Box Miscellaneous Functions and Procedures (Views: 27)
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,''); WriteLn(Txt,''); WriteLn(Txt,' WriteLn(Txt,''); WriteLn(Txt); WriteLn(Txt,''); WriteLn(Txt,' ' + Heading + '');WriteLn(Txt,'
WriteLn(Txt,' '); ' + IntToStr(StrGrid.ColCount) + ' Rows');WriteLn(Txt,''); WriteLn(Txt,''); 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 // ================================================== 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. |