Mirror

Black-Box Miscellaneous Functions and Procedures (Views: 101)


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,'' + ExtractFileName(FileName) + '');
  WriteLn(Txt,'');
  WriteLn(Txt);
  WriteLn(Txt,'');
  WriteLn(Txt,'

' + Heading + '

');
  WriteLn(Txt,'              'BGCOLOR=#' + BgColor + ' BORDER=1>');

  // Column Descriptions
  WriteLn(Txt,'    ');
  for i := 0 to StrGrid.ColCount - 1 do
     WriteLn(Txt,'        ');
  WriteLn(Txt,'    ');

  // Write out the Grid Data
  for i := 1 to StrGrid.RowCount - 1 do begin
    WriteLn(Txt,'    ');
    for ii := 0 to StrGrid.ColCount - 1 do
        WriteLn(Txt,'    ');
    WriteLn(Txt,'    ');
  end;

  // Footer
  WriteLn(Txt,'
' + StrGrid.Cells[i,0] + '
' + StrGrid.Cells[ii,i] + '
');
  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=P1P2
// ==================================================

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.

<< Back to main page