System and User Locale vs. System and User UI Language

Problem/Question/Abstract:

This sorts out the business of Language IDs and UI Language IDs. Why they are different and how to access them.

Answer:

I became quite confused (easy for me) on the subject of Language ID’s. It turns out, that what I failed to realize is that there is really two, potentially different, languages IDs on a system. Sure, I knew that there is both a default “system” ID and a “user” ID for each defined user on the system but what I didn’t know, was that there is also a system and user UI Language ID.

Windows 32 bit operating systems have a System Locale, which can be retrieved with GetSystemDefaultLangID. System This ID determines which bitmap fonts, and OEM, ANSI and MAC code pages are defaults for the system.

Complementing the system locale default is the user locale default that determines which settings are used for dates, times, currency, numbers, and sort order as a default for each user. The GetUserDefaultLangID retrieves the default value for the current user.

Threads can also have a default locale. New threads default to the default user locale but can be changed with SetThreadLocale and retrieved with GetThreadLocale. The thread locale determines which settings are used for formatting dates, times, currency, numbers, and sort order for the thread.

Eventually, I realized that there is also separate default User Interface (UI) language IDs. These determine the language of menus, dialogs, messages, INF files and help files. The System UI Language is retrieved using GetSystemDefaultUILanguage, while the user UI language is retrieved using GetUseDefaultUILanguage.

Once I finally came to terms with this, not so subtle, distinction between “locals” and “UI languages” I realized that what I needed was the user UI language ID unfortunately none of my copies of Delphi (including Delphi 6) support either GetSystemDefaultUILanguage or GetUseDefaultUILanguage. Even worse, these are relatively new API calls and only first appeared with Windows ME and 2000.

Here is a GetUseDefaultUILanguage I pieced together from various MSDN documents, samples, and factoids. This was written with Delphi 6 and supports OSs from Win95 on up. I’ve only tested it on Windows 2000 so please let me know if it hiccups on Win9x and NT.

Send comments to alecb@o2a.com.

// Helper

function HrFromWin32(dwErr: DWord): HResult;
begin
  result := HResultFromWin32(dwErr);
end;

// Helper

function HrFromLastWin32Error: HResult;
var
  dw: DWord;
begin
  dw := GetLastError;
  if dw = 0 then
    result := E_Fail
  else
    result := HrFromWin32(dw);
end;

// Helper

function MAKELANGID(p, s: word): word;
begin
  result := (s shl 10) or p;
end;

// The good stuff

function GetUserDefaultUILanguage: LANGID;
type
  TGetLang = function: LangID;
  THandle = Integer;
var
  GetLang: TGetLang;
  wUILang: LANGID;
  Osv: OSVERSIONINFO;
  Reg: TRegistry;
  Handle: THandle;
begin
  wUILang := 0;
  Osv.dwOSVersionInfoSize := sizeof(Osv);

  if not GetVersionEx(Osv) then
  begin
    OleError(HrFromLastWin32Error);
  end
    // Get the UI language by one of three methods, depending on OS
  else if Osv.dwPlatformId <> VER_PLATFORM_WIN32_NT then
  begin
    // Case 1: Running on Windows 9x. Get the system UI language from registry:
    Reg := TRegistry.Create;
    try
      Reg.RootKey := HKEY_USERS;
      if Reg.OpenKey('.Default\Control Panel\desktop\ResourceLocale', False) then
      begin
        wUILang := LangID(Reg.ReadInteger(''));
        Reg.CloseKey;
      end;
    finally
      Reg.Free;
    end;
  end
  else if (Osv.dwMajorVersion >= 5.0) then
  begin
    // Case 2: Running on Windows 2000 or later. Use GetUserDefaultUILanguage
    // to find the user's prefered UI language
    Handle := LoadLibrary('kernel32.dll');
    if Handle <> 0 then
    begin
      @GetLang := GetProcAddress(Handle, 'GetUserDefaultUILanguage');
      if @GetLang <> nil then
        wUILang := GetLang;
      FreeLibrary(Handle);
    end;
  end
  else
  begin
    // Case 3: Running on Windows NT 4.0 or earlier. Get UI language
    // from locale of .default user in registry:
    // HKEY_USERS\.DEFAULT\Control Panel\International\Locale
    Reg := TRegistry.Create;
    try
      Reg.RootKey := HKEY_USERS;
      if Reg.OpenKey('.Default\Control Panel\desktop\International', False) then
      begin
        wUILang := LangID(Reg.ReadInteger('Locale'));
        Reg.CloseKey;

        // Special case these to the English UI.
        // These versions of Windows NT 4.0 were enabled only, i.e., the
        // UI was English. However, the registry setting
        // HKEY_USERS\.DEFAULT\Control Panel\International\Locale was set
        // to the respective locale for application compatibility.
        if ($0401 = wUILang) or // Arabic
        ($040D = wUILang) or // Hebrew
        ($041E = wUILang) then // Thai
        begin
          wUILang := MakeLangID(LANG_ENGLISH, SUBLANG_ENGLISH_US);
        end;

      end;
    finally
      Reg.Free;
    end;
  end;
  result := wUILang;
end;

Create and Manage dynamic Forms at Runtime using Class References

Problem/Question/Abstract:

How to dynamicaly create and manage different Forms at runtime in a global manner?

Answer:

If you need to create dynamic forms at runtime and you want to manage them in a global manner, you may have the problem that you don't know how to administrate different form classes. For this case, Delphi comes with special class types of all common objects. But before I go into details, let me create a scenario in which this article may helps you.

  "I'll create an application for my customer to let him administrate serveral kinds of data in a local database. Each data category (such as employees, articles, ...) have to been implemented in a specified form with individual edit fields and tools. I don't like to create a MDI bases application (for some reasons) but the customers should have the possibilty to create more than one form for each category (e.g. opens up to 10 forms with customer informations and 3 forms with article informations). He should refer to each form after a while, so all forms have to been non-modular > the customer can hide or minimize each form. In normal MDI application, Delphi helps you to manage the MDI childs form via the 'ActiveMDIChild' property for example, but in non MDI applications you had to manage all child forms by yourself."

To find a workable solution we had to abstract the layer in which we could manage several kinds of forms. Each Delphi form inherites from TCustomForm so our first solution is to create a method who we pass a form reference to memorize - but how to keep such references? By the way, it's also possible to create a form manually and then pass the handle direct to the management component, but we'll create a method which automatically creates each kind of form. At the end of this article we've created a VCL component called TWindowManager which makes all of the discussed stuff, but now - let's start:

function TWindowManager.CreateForm(const Form: TFormClass;
  Name: string; Show: Boolean = False): TCustomForm;
begin
  if not Form.InheritsFrom(TCustomForm) then
    raise Exception.Create('Invalid FormClass - must be a descendant
      of TCustomForm!');
      Result := TCustomForm(Form.Create(Application));
      if Name <> '' then
        Result.Name := Name;
      // insert code here, to store the reference
      if Show then
        Result.Show;
end;

Okay, but how to use it? First, we've created a normal Delphi application and added a new form called DynForm1 for example. Delphi automatically creates the following entry in the pas unit:

type
  TDynForm1 = class(TForm)
    ...
  end;

For the next step we had to refer to the new unit by included the corresponding unit name to the uses clause. To dynamically create the new form at runtime, you can call the method in a way like:

procedure TMainForm.ButtonDyn1Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm1, True);
end;

Don't marvel about the name WindowManager or TWindowManager in the source examples, I've pasted it direct from the component source I've explained earlier.

Do you notice that we have passed the formclass to the method instead of the name or anythink else? It's possible, because the parameter type of the method is TFormClass which is implemented as TFormClass = class of TForm in Delphi's Forms unit.

Now we need a solution to store the form reference:

type
  { TWindowItem }

  PWindowItem = ^TWindowItem;
  TWindowItem = packed record
    Form: Pointer;
  end;

Note:

It's also possible to use a TStringList for example and create items which holds the form handles (or references direct) but it's not a good solutions if you want to search for already existing form (names). Since Version 3 (I'm not sure exactly) Delphi comes with a special container class which gives you some more specific descendants from the TList class. You can use the TObjectList class, derive from it and overwritte the maintenance methods. In this article I use a normal record to store all informations - it's less code to write and you can easily add improved custom informations to store.

The sourcecode of the TWindowManager comes from a Delphi3 implementation I've wrote - if I've some spare time, I'll update it to the newer technology!

Our WindowManager also published a method to directly add already existing form references, so you don't need to create your forms using the CreateForm method:

function TWindowManager.Add(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := True;
  try
    New(WindowItem);
    WindowItem^.Form := Form;
    FWindowList.Add(WindowItem);
  except // wrap up
    Result := True;
  end; // try/except
end;

FWindowList is declared as FWindowList: TList to hold a list of reference records. Followed you'll see to complete sourcode of the TWindowManager - try to understand the individual methods - they are simple. The main trick is the use off class references I've mentioned earlier.

The main component

unit WindowMng;

interface

uses
  Classes, Forms, SysUtils, Windows;

type
  { TWinNotifyEvent }

  TWinNotifyEvent = procedure(Sender: TObject; Form: TCustomForm) of object;

  { TWindowItem }

    // I used a packed record to be more flexible for futher improvements
    // which may need to store additional informations.

  PWindowItem = ^TWindowItem;
  TWindowItem = packed record
    Form: Pointer;
  end;

  { TWindowManager }

  TWindowManager = class(TComponent)
  private
    { Private declarations }
    FAutoNotification: Boolean;
    FLastIndex: Integer;
    FWindowList: TList;
    FOnFormAdded: TWinNotifyEvent;
    FOnFormHandled: TNotifyEvent;
    FOnFormRemoved: TWinNotifyEvent;
  protected
    { Protected declarations }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetFormByIndex(Index: Integer): TCustomForm; virtual;
    function GetWindowItemByIndex(Index: Integer): PWindowItem; virtual;
    function GetWindowItemByForm(const Form: TCustomForm): PWindowItem; virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Add(const Form: TCustomForm): Boolean; overload;
    function Count: Integer;
    function CreateForm(const Form: TFormClass; Name: string; Show: Boolean = False):
      TCustomForm; overload;
    function CreateForm(const Form: TFormClass; Show: Boolean = False): TCustomForm;
      overload;
    function Exists(const Form: TCustomForm): Boolean;
    function Remove(const Form: TCustomForm): Boolean;
    function Restore(const Index: Integer): Boolean; overload;
    function Restore(const Form: TCustomForm): Boolean; overload;
    property Forms[Index: Integer]: TCustomForm read GetFormByIndex; default;
  published
    { Published declarations }
    property AutoNotification: Boolean read FAutoNotification write FAutoNotification;
    property OnFormAdded: TWinNotifyEvent read FOnFormAdded write FOnFormAdded;
    property OnFormHandled: TNotifyEvent read FOnFormHandled write FOnFormHandled;
    property OnFormRemoved: TWinNotifyEvent read FOnFormRemoved write FOnFormRemoved;
  end;

procedure Register;

implementation

// -----------------------------------------------------------------------------

procedure Register;
begin
  RegisterComponents('Freeware', [TWindowManager]);
end;

// -----------------------------------------------------------------------------

{ TWindowManager }

constructor TWindowManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoNotification := False;
  FLastIndex := -1;
  FWindowList := TList.Create;
end;

destructor TWindowManager.Destroy;
begin
  FWindowList.Free;
  inherited Destroy;
end;

procedure TWindowManager.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  if (FAutoNotification) and (AComponent <> nil) and (Operation = opRemove)
    and (AComponent is TCustomForm) and (Exists(TCustomForm(AComponent))) then
    Remove(TCustomForm(AComponent));
  inherited Notification(AComponent, Operation);
end;

function TWindowManager.Add(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := False;
  if not Exists(Form) then
  try
    New(WindowItem);
    WindowItem^.Form := Form;
    FWindowList.Add(WindowItem);
    if FAutoNotification then
      Form.FreeNotification(Self);
    Result := True;
    if assigned(FOnFormAdded) then
      FOnFormAdded(Self, Form);
    if assigned(FOnFormHandled) then
      FOnFormHandled(Self);
  except // wrap up
  end; // try/except
end;

function TWindowManager.Count: Integer;
begin
  Result := FWindowList.Count;
end;

function TWindowManager.CreateForm(const Form: TFormClass; Name: string; Show: Boolean
  = False): TCustomForm;
begin
  if not Form.InheritsFrom(TCustomForm) then
    raise
      Exception.Create('Invalid FormClass - must be a descendant of TCustomForm!');
  Result := TCustomForm(Form.Create(Application));
  if Name <> '' then
    Result.Name := Name;
  Add(Result);
  if Show then
    Result.Show;
end;

function TWindowManager.CreateForm(const Form: TFormClass; Show: Boolean = False):
  TCustomForm;
begin
  Result := CreateForm(Form, '', Show);
end;

function TWindowManager.Exists(const Form: TCustomForm): Boolean;
begin
  Result := GetWindowItemByForm(Form) <> nil;
end;

function TWindowManager.GetFormByIndex(Index: Integer): TCustomForm;
var
  WindowItem: PWindowItem;
begin
  Result := nil;
  WindowItem := GetWindowItemByIndex(Index);
  if WindowItem <> nil then
    Result := TCustomForm(WindowItem^.Form);
end;

function TWindowManager.GetWindowItemByIndex(Index: Integer): PWindowItem;
begin
  Result := nil;
  if Index < Count then
    Result := PWindowItem(FWindowList[Index]);
end;

function TWindowManager.GetWindowItemByForm(const Form: TCustomForm): PWindowItem;
var
  iIndex: Integer;
begin
  Result := nil;
  FLastIndex := -1;
  for iIndex := 0 to FWindowList.Count - 1 do
    if GetWindowItemByIndex(iIndex)^.Form = Form then
    begin
      FLastIndex := iIndex;
      Result := GetWindowItemByIndex(FLastIndex);
      Break;
    end;
end;

function TWindowManager.Remove(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := False;
  WindowItem := GetWindowItemByForm(Form);
  if WindowItem <> nil then
  try
    FWindowList.Delete(FLastIndex);
    Dispose(WindowItem);
    Result := True;
    if assigned(FOnFormRemoved) then
      FOnFormRemoved(Self, Form);
    if assigned(FOnFormHandled) then
      FOnFormHandled(Self);
  except // wrap up
  end; // try/except
end;

function TWindowManager.Restore(const Form: TCustomForm): Boolean;
begin
  Result := False;
  if (Form <> nil) and (Exists(Form)) then
  try
    if IsIconic(Form.Handle) then
      Form.WindowState := wsNormal;
    Form.SetFocus;
    Result := True;
  except // wrap up
  end; // try/except
end;

function TWindowManager.Restore(const Index: Integer): Boolean;
begin
  Result := Restore(GetFormByIndex(Index));
end;

end.

To show you the in more detail how to work with this component, followed you'll find a demo application with two additional forms. You don't need to install the component to a package, I'll create it at runtime:

The project file

program WMDemo;

uses
  Forms,
  MainFrm in 'MainFrm.pas' {MainForm},
  WindowMng in 'WindowMng.pas',
  DynFrm1 in 'DynFrm1.pas' {DynForm1},
  DynFrm2 in 'DynFrm2.pas' {DynForm2};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.

The MainForm file

unit MainFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, WindowMng;

type
  TMainForm = class(TForm)
    ButtonDyn1: TButton;
    GroupBoxForms: TGroupBox;
    ListBoxForms: TListBox;
    ButtonHelloWorld: TButton;
    ButtonDyn2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ButtonDyn1Click(Sender: TObject);
    procedure ListBoxFormsDblClick(Sender: TObject);
    procedure ButtonHelloWorldClick(Sender: TObject);
    procedure ButtonDyn2Click(Sender: TObject);
  private
    { Private declarations }
    WindowManager: TWindowManager;
    procedure RedrawFormList(Sender: TObject);
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses
  DynFrm1, DynFrm2;

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  // create WindowManager
  WindowManager := TWindowManager.Create(Self);

  // enable 'AutoNotification'. If this feature is turned on,
  // WindowManager will receive a notification if a form was closed
  // by the user, so it can fire events to recorgnize this.
  // We use the 'OnFormHandled' event to redraw out ListBox.
  WindowManager.AutoNotification := True;

  // link event handler to update out ListBox.
  WindowManager.OnFormHandled := RedrawFormList;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  // destroy WindowManager
  WindowManager.Free;
end;

procedure TMainForm.RedrawFormList(Sender: TObject);
var
  i: Integer;
begin
  // get all available forms and display them.
  // we also stores the object reference to enable the 'restore' function
  // if the user double-clicked on an item.
  ListBoxForms.Clear;
  for i := 0 to WindowManager.Count - 1 do
    ListBoxForms.AddItem(WindowManager.Forms[i].Name, WindowManager.Forms[i]);
end;

procedure TMainForm.ButtonDyn1Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm1, True);
end;

procedure TMainForm.ButtonDyn2Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm2, True);
end;

procedure TMainForm.ListBoxFormsDblClick(Sender: TObject);
var
  ClickForm: TCustomForm;
begin
  // extract the 'clicked' form.
  with ListBoxForms do
    ClickForm := TCustomForm(Items.Objects[ItemIndex]);

  // restore the form to the top order.
  // we used the WindowManager method 'Restore' to be sure
  // that the form will be restored also if it was iconized
  // before.
  WindowManager.Restore(ClickForm);
end;

procedure TMainForm.ButtonHelloWorldClick(Sender: TObject);
begin
  // check, if any registered forms exists.
  if WindowManager.Count = 0 then
  begin
    ShowMessage('No dynamic Forms exists - please create one!');
    Exit;
  end;

  // check, if the first available form is 'DynForm1'.
  // if true, call the HelloWorld method.
  if WindowManager.Forms[0] is TDynForm1 then
    TDynForm1(WindowManager.Forms[0]).HelloWorld
  else
    ShowMessage('The first Form is not a "Dynamic Form I"!');
end;

end.

The MainForm resource file

object MainForm: TMainForm
  Left = 290
    Top = 255
    BorderStyle = bsSingle
    Caption = 'MainForm'
    ClientHeight = 229
    ClientWidth = 510
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    DesignSize = (
    510
    229)
    PixelsPerInch = 96
    TextHeight = 13
    object ButtonDyn1: TButton
    Left = 16
      Top = 16
      Width = 121
      Height = 25
      Caption = 'Create Dynamic Form I'
      TabOrder = 0
      OnClick = ButtonDyn1Click
  end
  object GroupBoxForms: TGroupBox
    Left = 16
      Top = 56
      Width = 481
      Height = 169
      Anchors = [akLeft, akTop, akRight, akBottom]
      Caption = 'Available Forms (Double-Click to restore)'
      TabOrder = 1
      object ListBoxForms: TListBox
      Left = 2
        Top = 15
        Width = 477
        Height = 152
        Align = alClient
        BorderStyle = bsNone
        ItemHeight = 13
        ParentColor = True
        TabOrder = 0
        OnDblClick = ListBoxFormsDblClick
    end
  end
  object ButtonHelloWorld: TButton
    Left = 344
      Top = 16
      Width = 153
      Height = 25
      Caption = 'Fire ''HelloWorld'' on DynForm1'
      TabOrder = 2
      OnClick = ButtonHelloWorldClick
  end
  object ButtonDyn2: TButton
    Left = 144
      Top = 16
      Width = 121
      Height = 25
      Caption = 'Create Dynamic Form II'
      TabOrder = 3
      OnClick = ButtonDyn2Click
  end
end

The DynForm1 file

unit DynFrm1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TDynForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure HelloWorld;
  end;

var
  DynForm1: TDynForm1;

implementation

{$R *.dfm}

procedure TDynForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // be sure that our form will be freed.
  Action := caFree;
end;

procedure TDynForm1.HelloWorld;
begin
  ShowMessage('HelloWorld method was fired!');
end;

end.

The DynForm2 file

unit DynFrm2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TDynForm2 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  DynForm2: TDynForm2;

implementation

{$R *.dfm}

procedure TDynForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // be sure that our form will be freed.
  Action := caFree;
end;

end.

Hope this article helps you to understand how dynamic forms can be created and managed.

How to reindex Paradox tables

Problem/Question/Abstract:

How to reindex Paradox tables

Answer:

There are a number of ways to approach this. One way would be to make a call to the BDE API function DbiRegenIndexes. This insulates you from having to know what indexes exist, if any, the BDE handling all the code for you. Error checking can be handled by examining the return value (type DBIResult) or by using the Check function (defined in the BDE wrapper unit BDE).

procedure TForm1.Button4Click(Sender: TObject);
var
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    Open;
    Check(DbiRegenIndexes(Table1.Handle));
    Close;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;

As when calling any BDE API function, the BDE API wrapper unit BDE (for Delphi 1, the units DbiTypes, DbiErrs, and DbiProcs) must be referenced in the Uses section of the unit from which the call is to be made. The BDE API function DbiSaveChanges, used here, forces any data changes in memory buffer to be written to disk at that point.

Another way to handle this situation -- if you know at design-time all the indexes that will exist for the table -- would be to iterate through the items in the TIndexDefs object of the TTable component, delete each index (DeleteIndex method), and then add all needed indexes back (AddIndex method).

procedure TForm1.Button3Click(Sender: TObject);
var
  aName: string;
  i: Byte;
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    IndexDefs.Update;
    i := IndexDefs.Count;
    while i > 0 do
    begin
      aName := IndexDefs.Items[i - 1].Name;
      DeleteIndex(aName);
      Dec(i);
    end;
    AddIndex('', 'MainField', [ixPrimary]);
    AddIndex('Field1', 'Field1', []);
    AddIndex('Field2', 'Field2', []);
    IndexDefs.Update;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;

When iterating through the items in the TIndexDefs object, the cycling must be backwards, from highest to lowest. This is to account for those table types that have primary indexes. With those table types, deleting a primary index first causes all secondary indexes to be unavailable, which interferes with this iterating based on the TIndexDefs array object contents. This is because a secondary index cannot exist in some table types (such as Paradox) without an existing primary index. For the same reason, when recreating the indexes, the process should start with the primary index and then progress through all secondary indexes (if any are to be created).

If information about the index definitions is not known at design-time, this process becomes emminently more complex. The data from all indexes will need to be saved to memory, the information for all indexes existing simultaneously in memory. This is because a primary index would need to be deleted at some point (to later be rebuilt), destroying references to any secondary indexes (whether retrieval for the secondary indexes takes place before or after deletion of the primary index). To accomplish this, some multi-entity storage structure would need to be created to hold a variable number of elements, one element per index. Each element would need to be able to store the four bits of data that comprise an index's definition: Name (String), Fields (String), Expression (String), and Options (TIndexOptions). An array or a TList object of Pascal records with these data fields would suffice for this purpose.

Once the definition information for all indexes are stored to memory, the succeeding steps are similar to those for the previous method: Delete each index (DeleteIndex) and then recreate each index based on the definition information stored in the array or TList (AddIndex).

Create a thread-safe wrapper class for TCustomIniFile descendents

Problem/Question/Abstract:

How to create a thread-safe wrapper class for TCustomIniFile descendents

Answer:

{Unit ThreadSafeWrapperU:
Declares and implements a simple thread-safe wrapper class as base class
for classes that need to serialize access to some internal object.

Author Dr. Peter Below
Version 1.0 created 18 Oktober 2000
Current revision: 1.0
Last modified: 18 Oktober 2000
Last review: 18.04.2001}

unit ThreadSafeWrapperU;

interface

uses SyncObjs;

type

  {This is a class from which classes wrapping some data object in a thread-safe
manner can be derived. The derived class should add a public
Function Lock: Sometype;
that calls InternalLock and then returns a reference for the protected object (kept in a private field ).
  Access to the protected object will typically take the form

     with wrapper.lock do
     try
       stuff
     finally
       wrapper.Unlock;
     end;}

  TThreadSafeWrapper = class
  private
    FGuardian: TCriticalSection;
  protected
    {Enter the critical section}
    procedure InternalLock;
  public
    {Create the critical section}
    constructor Create; virtual;
    {Destroy the critical section}
    destructor Destroy; override;
    {Leave the critical section}
    procedure Unlock;
  end;

implementation

constructor TThreadSafeWrapper.Create;
begin
  FGuardian := TCriticalSection.Create;
  inherited;
end;

destructor TThreadSafeWrapper.Destroy;
begin
  FGuardian.Free;
  inherited;
end;

procedure TThreadSafeWrapper.InternalLock;
begin
  FGuardian.Acquire;
end;

procedure TThreadSafeWrapper.Unlock;
begin
  FGuardian.Release;
end;

end.

{ThreadSafeInifileU:
Implements a thread-safe wrapper class for TCustomInifile descendents.

Author Dr. Peter Below
Version 1.0 created 24.12.2000
Version 1.01 created 25.04.2001, added most of the public inifile methods to wrap
              access to the internal inifile
Current revision: 1.01
Last modified: 24.12.2000
Last review: 25.04.2001}

unit ThreadSafeInifileU;

interface

uses
  Windows, Classes, ThreadSafeWrapperU, Inifiles;

type
  {Enumerated type for TCustomInifile descendents to use}
  TIniType = (itRegistryInifile, itInifile, itMemInifile);

  {A thread-safe inifile class. The default inifile class used if none is specified in
  the constructor is TRegistryInifile}
  TThreadsafeInifile = class(TThreadSafeWrapper)
  private
    FIni: TCustomInifile;
  public
    constructor Create(aFilename: string; aClass: TIniType = itRegistryInifile;
      aAccess: LongWord = KEY_READ or KEY_WRITE); reintroduce;
    destructor Destroy; override;
    function Lock: TCustomInifile;
    function SectionExists(const Section: string): Boolean;
    function ReadString(const Section, Ident, Default: string): string;
    procedure WriteString(const Section, Ident, Value: string);
    function ReadInteger(const Section, Ident: string; Default: Longint): Longint;
    procedure WriteInteger(const Section, Ident: string; Value: Longint);
    function ReadBool(const Section, Ident: string; Default: Boolean): Boolean;
    procedure WriteBool(const Section, Ident: string; Value: Boolean);
    function ReadDate(const Section, Ident: string; Default: TDateTime): TDateTime;
    function ReadDateTime(const Section, Ident: string; Default: TDateTime):
      TDateTime;
    function ReadFloat(const Section, Ident: string; Default: Double): Double;
    function ReadTime(const Section, Ident: string; Default: TDateTime): TDateTime;
    procedure WriteDate(const Section, Ident: string; Value: TDateTime);
    procedure WriteDateTime(const Section, Ident: string; Value: TDateTime);
    procedure WriteFloat(const Section, Ident: string; Value: Double);
    procedure WriteTime(const Section, Ident: string; Value: TDateTime);
    procedure ReadSection(const Section: string; Strings: TStrings);
    procedure ReadSections(Strings: TStrings);
    procedure ReadSectionValues(const Section: string; Strings: TStrings);
    procedure EraseSection(const Section: string);
    procedure DeleteKey(const Section, Ident: string);
    function ValueExists(const Section, Ident: string): Boolean;
  end;

implementation

uses
  Registry;

{TThreadsafeInifile.Create:
Create the custom ini file descendent.

Parameters:
aFilename: The name to use.
aClass: Defines the class to use.
aAccess: The desired access if aclass is itRegistryInifile.

We have a slight problem here since TCustomInifile.Create is not a virtual constructor.
So we need a somewhat cumbersome Case construct to create the correct class of
TCustomInifile descendent.

Created 24.12.2000 by P. Below}

constructor TThreadsafeInifile.Create(aFilename: string; aClass: TIniType =
  itRegistryInifile;
  aAccess: DWord = KEY_READ or KEY_WRITE);
begin
  inherited Create;
  case aClass of
    itRegistryInifile:
      FIni := TRegistryInifile.Create(aFilename, aAccess);
    itInifile:
      FIni := TInifile.Create(aFilename);
    itMemInifile:
      FIni := TMemInifile.Create(aFilename);
  end;
end;

{TThreadsafeInifile.Destroy:
Destroy the internal inifile object.

Created 24.12.2000 by P. Below}

destructor TThreadsafeInifile.Destroy;
begin
  FIni.Free;
  inherited;
end;

{TThreadsafeInifile.Lock:
Aquire access to the ini file and return its reference. Must be paired with an Unlock call!

Created 24.12.2000 by P. Below}

function TThreadsafeInifile.Lock: TCustomInifile;
begin
  InternalLock;
  Result := FIni;
end;

function TThreadsafeInifile.SectionExists(const Section: string): Boolean;
begin
  InternalLock;
  try
    Result := FIni.SectionExists(Section);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadString(const Section, Ident, Default: string): string;
begin
  InternalLock;
  try
    Result := FIni.ReadString(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteString(const Section, Ident, Value: string);
begin
  InternalLock;
  try
    FIni.WriteString(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadInteger(const Section, Ident: string; Default:
  Longint): Longint;
begin
  InternalLock;
  try
    Result := FIni.ReadInteger(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteInteger(const Section, Ident: string; Value:
  Longint);
begin
  InternalLock;
  try
    FIni.WriteInteger(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadBool(const Section, Ident: string; Default: Boolean):
  Boolean;
begin
  InternalLock;
  try
    Result := FIni.ReadBool(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteBool(const Section, Ident: string; Value: Boolean);
begin
  InternalLock;
  try
    FIni.WriteBool(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadDate(const Section, Ident: string; Default:
  TDateTime): TDateTime;
begin
  InternalLock;
  try
    Result := FIni.ReadDate(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadDateTime(const Section, Ident: string;
  Default: TDateTime): TDateTime;
begin
  InternalLock;
  try
    Result := FIni.ReadDatetime(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadFloat(const Section, Ident: string; Default: Double):
  Double;
begin
  InternalLock;
  try
    Result := FIni.ReadFloat(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ReadTime(const Section, Ident: string; Default:
  TDateTime): TDateTime;
begin
  InternalLock;
  try
    Result := FIni.ReadTime(Section, Ident, Default);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteDate(const Section, Ident: string; Value:
  TDateTime);
begin
  InternalLock;
  try
    FIni.WriteDate(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteDateTime(const Section, Ident: string; Value:
  TDateTime);
begin
  InternalLock;
  try
    FIni.WriteDatetime(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteFloat(const Section, Ident: string; Value: Double);
begin
  InternalLock;
  try
    FIni.WriteFloat(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.WriteTime(const Section, Ident: string; Value:
  TDateTime);
begin
  InternalLock;
  try
    FIni.WriteTime(Section, Ident, Value);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.ReadSection(const Section: string; Strings: TStrings);
begin
  InternalLock;
  try
    FIni.ReadSection(Section, Strings);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.ReadSections(Strings: TStrings);
begin
  InternalLock;
  try
    FIni.ReadSections(Strings);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.ReadSectionValues(const Section: string; Strings:
  TStrings);
begin
  InternalLock;
  try
    FIni.ReadSectionValues(Section, Strings);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.EraseSection(const Section: string);
begin
  InternalLock;
  try
    FIni.EraseSection(Section);
  finally
    Unlock;
  end;
end;

procedure TThreadsafeInifile.DeleteKey(const Section, Ident: string);
begin
  InternalLock;
  try
    FIni.DeleteKey(Section, Ident);
  finally
    Unlock;
  end;
end;

function TThreadsafeInifile.ValueExists(const Section, Ident: string): Boolean;
begin
  InternalLock;
  try
    Result := FIni.ValueExists(Section, Ident);
  finally
    Unlock;
  end;
end;

end.

How to use a TControlCanvas in a component

Problem/Question/Abstract:

How to use a TControlCanvas in a component

Answer:

TScrollingPaintBox = class(TScrollingWinControl)
private
  FCanvas: TCanvas;
public
  constructor Create(aOwner: TComponent); override;
  destructor Destroy; override;
  property Canvas: TCanvas read FCanvas;
end;

constructor TScrollingPaintBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

destructor TScrollingPaintBox.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

A TControlCanvas is important because it creates a DC that belongs to the HWND of the control. Also, override is important on your constructor and destructor to ensure that they are actually called.

Extra Color codes for Delphi

Problem/Question/Abstract:

Extra Color codes for Delphi

Answer:

This Article will be updated over time.

Keep checking back!

unit UnitColorConstants;
{-----------------------------------------------------------------

    Unit Name: UnitColorConstants
    Version: 2.0
    Author: Stewart Moss
    Creation Date: Jan 31 2002 11:54 pm
    Modification Date: Feb 21 2002
    Dependancies:

    Description:

-- This code is copyright (Jan 31 2002) by Stewart Moss
-- All rights Reserved.
-----------------------------------------------------------------}

interface

uses Graphics;

const
  clNicePaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
  clNicePurple = TColor($00E1E100);
  clKhaki = TColor($ADAE80);
  clMonkeyGreen = TColor($00C0DCC0);
  clSkyBlue = TColor($00F1CAA6);
  clMedGray = TColor($00A4A0A0);
  clCream = TColor($00EFFBFF);

  clChocolate = TColor($17335C);
  clDarkBrown = TColor($5C3340);
  clDarkSlateGrey = TColor($4F4F2F);
  clDarkTan = TColor($4F6997);
  clDarkWood = TColor($425E85);
  clLightWood = TColor($A6C2E9);
  clMediumWood = TColor($6480A6);
  clNewTan = TColor($9EC7EB);
  clSemiSweetChocolate = TColor($26426B);
  clSienna = TColor($236B8E);
  clWheat = TColor($BFD8D8);
  clBrass = TColor($42A6B5);
  clBronze = TColor($53788C);
  clBronzeII = TColor($3D7DA6);
  clCoolCopper = TColor($1987D9);
  clCopper = TColor($3373B8);
  clQuartz = TColor($F3D9D9);
  clFieldSpar = TColor($7592D1);
  clGoldenrod = TColor($70DBDB);
  clMediumGoldenrod = TColor($AEEAEA);
  clBrightGold = TColor($19D9D9);
  clGold = TColor($327FCD);
  clOldGold = TColor($3BB5CF);
  clCoral = TColor($007FFF);
  clFirebrick = TColor($23238E);
  clIndianRed = TColor($2F2F4E);
  clMandarianOrange = TColor($3378E4);
  clMediumVioletRed = TColor($9370DB);
  clNeonPink = TColor($C76EFF);
  clOrangeRed = TColor($0024FF);
  clScarlet = TColor($17178C);
  clSpicyPink = TColor($AE1CFF);
  clThistle = TColor($D8BFD8);
  clVioletRed = TColor($9932CC);
  clDarkOliveGreen = TColor($2F4F4F);
  clForestGreen = TColor($238E23);
  clHunterGreen = TColor($215E21);
  clMediumForestGreen = TColor($238E6B);
  clMediumSeaGreen = TColor($426F42);
  clMediumSpringGreen = TColor($00FF7F);
  clPaleGreen = TColor($8FBC8F);
  clSeaGreen = TColor($688E23);
  clSpringGreen = TColor($7FFF00);
  clYellowGreen = TColor($32CC99);
  clAquamarine = TColor($93DB70);
  clCadetBlue = TColor($9F9F5F);
  clCornFlowerBlue = TColor($6F4242);
  clDarkTurquoise = TColor($DB9370);
  clLightBlue = TColor($D9D9C0);
  clLightSteelBlue = TColor($BD8F8F);
  clMediumAquamarine = TColor($99CD32);
  clMediumBlue = TColor($CD3232);
  clMediumTurquoise = TColor($DBDB70);
  clMidnightBlue = TColor($4F2F2F);
  clNeonBlue = TColor($FF4D4D);
  clNewMidnightBlue = TColor($9C0000);
  clRichBlue = TColor($AB5959);
  clSlateBlue = TColor($FF7F00);
  clSteelBlue = TColor($8E6B23);
  clSummerSky = TColor($DEB038);
  clTurquoise = TColor($EAEAAD);
  clBlueViolet = TColor($9F5F9F);
  clOrchid = TColor($DB70DB);
  clDarkPurple = TColor($781F87);
  clViolet = TColor($4F2F4F);
  clDarkOrchid = TColor($CD3299);
  clMediumSlateBlue = TColor($007FFF);
  clDarkSlateBlue = TColor($8E236B);
  clMediumOrchid = TColor($DB7093);

implementation

end.

Here Is an example of the color codes :-

Violets
Blues
Greens



Reds
Yellows
White, Black and Gray Shades

Make a new DBLookupComboBox-Component with OnChange-Event

Problem/Question/Abstract:

DB-Aware Components like TDBEdit have an Event "OnChange". This Event is established in TCustomEdit.
Unfortunately in TDBLookupComboBox there is no OnChange-Event, because this component is not based on TCustomEdit but on TWinControl.
What to do if you want to have an OnChange event in a DBLookupComboBox?

Answer:

DB-Aware Components like TDBEdit have an Event "OnChange". This Event is established in TCustomEdit.

Unfortunately in TDBLookupComboBox there is no OnChange-Event, because this component is not based on TCustomEdit but on TWinControl.

What to do if you want to have an OnChange event in a DBLookupComboBox?

Well, let's build our own component with this event! It's easy  because TDBLookupControl established an protected Procedure "KeyValueChanged". It will fired when the property "KeyValue" ist changed.

So we can overwrite this Event in our own Componentent and call a new Event "OnChang".
That's all :-)

type

  TMyDBLookupComboBox = class(TDBLookupComboBox)
  private
    FOnChange: TNotifyEvent;
  protected
    procedure KeyValueChanged; override;
  published
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

implementation

procedure TMyDBLookupComboBox.KeyValueChanged;
begin
  inherited;
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

How to use the dgMultiSelect option in a TDBGrid

Problem/Question/Abstract:

How to use the dgMultiSelect option in a TDBGrid

Answer:

When you add [dgMultiSelect] to the Options property of a DBGrid, you give yourself the ability to select multiple records within the grid. The records you select are represented as bookmarks and are stored in the SelectedRows property. The SelectedRows property is an object of type TBookmarkList.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DBGrid1: TDBGrid;
    Count: TButton;
    Selected: TButton;
    Clear: TButton;
    Delete: TButton;
    Select: TButton;
    GetBookMark: TButton;
    Find: TButton;
    FreeBookmark: TButton;
    DataSource1: TDataSource;
    procedure CountClick(Sender: TObject);
    procedure SelectedClick(Sender: TObject);
    procedure ClearClick(Sender: TObject);
    procedure DeleteClick(Sender: TObject);
    procedure SelectClick(Sender: TObject);
    procedure GetBookMarkClick(Sender: TObject);
    procedure FindClick(Sender: TObject);
    procedure FreeBookmarkClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Bookmark1: TBookmark;
  z: Integer;

implementation

{$R *.DFM}

{Example of the Count property}

procedure TForm1.CountClick(Sender: TObject);
begin
  if DBgrid1.SelectedRows.Count > 0 then
  begin
    showmessage(inttostr(DBgrid1.SelectedRows.Count));
  end;
end;

{Example of the CurrentRowSelected property}

procedure TForm1.SelectedClick(Sender: TObject);
begin
  if DBgrid1.SelectedRows.CurrentRowSelected then
    showmessage('Selected');
end;

{Example of the Clear Method}

procedure TForm1.ClearClick(Sender: TObject);
begin
  dbgrid1.SelectedRows.Clear;
end;

{Example of the Delete Method}

procedure TForm1.DeleteClick(Sender: TObject);
begin
  DBgrid1.SelectedRows.Delete;
end;

{This example iterates through the selected rows of the grid and displays
the second field of the dataset.
The Method DisableControls is used so that the DBGrid will not update when the
dataset is changed. The last position of the dataset is saved as a TBookmark.
The IndexOf method is called to check whether or not the bookmark is still existent.
The decision of using the IndexOf method rather than the Refresh method should be determined by the specific application.}

procedure TForm1.SelectClick(Sender: TObject);
var
  x: word;
  TempBookmark: TBookMark;
begin
  DBGrid1.Datasource.Dataset.DisableControls;
  with DBgrid1.SelectedRows do
    if Count > 0 then
    begin
      TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark;
      for x := 0 to Count - 1 do
      begin
        if IndexOf(Items[x]) > -1 then
        begin
          DBGrid1.Datasource.Dataset.Bookmark := Items[x];
          showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
        end;
      end;
    end;
  DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.EnableControls;
end;

{This example allows you to set a bookmark and then search for the bookmarked record
within selected a record(s) within the DBGrid.}

{Sets a bookmark}

procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
  Bookmark1 := DBGrid1.Datasource.Dataset.GetBookmark;
end;

{Frees the bookmark}

procedure TForm1.FreeBookmarkClick(Sender: TObject);
begin
  if assigned(Bookmark1) then
  begin
    DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
    Bookmark1 := nil;
  end;
end;

{Uses the Find method to locate the position of the bookmarked record within
the selected list in the DBGrid}

procedure TForm1.FindClick(Sender: TObject);
begin
  if assigned(Bookmark1) then
  begin
    if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1), z) then
      showmessage(inttostr(z));
  end;
end;

end.

Black-Box Miscellaneous Functions and Procedures

Problem/Question/Abstract:

This is a Black-Box Miscellaneous Library that I have built up over the years (from Turbo Pascal 2.0 days). I have
posted it to this program as many of my components and classes make use of calls to this library. The functions and procedures are too numerous to document here, but they are self explanatory enough. Peruse the source code and I am sure you find something of interest.

Answer:


unit General;

interface
uses Windows, SysUtils, Forms, Dialogs, DBTables, BDE, Classes, DB,
     Controls, Registry, Printers, Graphics, DBGrids, ShellAPI,
     WinSock, Grids, Math, StdCtrls, NB30, JPEG, Menus,
     WinSvc, ComCtrls, ShlObj, Messages, StrUtils;

const   CrLf             = #13#10;  // Carriage Return / Linefeed pair

        // Keyboard Char Constants
        KY_TAB           = #9;
        KY_ENTER         = #13;
        KY_NONE          = #0;
        KY_BACKSPACE     = #8;
        KY_COPYRIGHT     = #169;    // Type ALT 0169 to get &copy;
        KY_REGISTERED    = #174;    // Type ALT 0174 to get &reg;

        // Extra VK constants missing from Delphi's Windows API interface
        VK_NULL          = 0;
        VK_SEMICOLON     = 186;
        VK_EQUAL         = 187;
        VK_COMMA         = 188;
        VK_MINUS         = 189;
        VK_PERIOD        = 190;
        VK_SLASH         = 191;
        VK_BACKQUOTE     = 192;
        VK_LEFTBRACKET   = 219;
        VK_BBACKSLASH    = 220;
        VK_RIGHTBRACKET  = 221;
        VK_QUOTE         = 222;

        // Conts for 0 and 1 for GetDriveType()
        DRIVE_UNKNOWN    = 0;
        DRIVE_UNASSIGNED = 1;

        // Range limits on int type vars
        MAXSMALLINT      = high(smallint);
        MINSMALLINT      = low(smallint);
        MINWORD          = low(word);
        MAXSHORTINT      = high(shortint);
        MINSHORTINT      = low(shortint);
        MAXBYTE          = high(byte);
        MINBYTE          = low(byte);
        MAXLONGWORD      = high(longword);
        MINLONGWORD      = low(longword);
        MAXSTRING        = high(integer);

        // Characters that are invalid for file names
        INVALID_FILE_CHARS = ['\','/','*','?','<','>','|'];

        
type
      // General usage types
      EApplicationFail = class(Exception);
      float            = double;
      TSex             = (sxUnknown,sxMale,sxFemale);
      TSqlRunMode      = (sqlOpen,sqlOpenTerminate,sqlExec,sqlExecTerminate);
      TJustifyMenuMode = (jsmRight,jsmLeft,jsmToggle);

      TCharTypes = (chAlpha,chDigit,chHex,chUpper,chLower,chWhitespace,
                    chPunctuation,chSign,chAnsi,chControl,chOperator);

      TCharTypesSet = set of TCharTypes;

      TCpuFeature = (cpuNoCPUID,cpuNonIntel,cpuOnChipFPU,
                     cpuVirtualModeExtensions,cpuDebuggingExtensions,
                     cpuPageSizeExtensions,cpuTimeStampCounter,
                     cpuModelSpecificRegisters,cpuPhysicalAddressExtensions,
                     cpuMachineCheckExtensions,cpuCMPXCHG8B,cpuOnChipAPIC,
                     cpuFastSystemCall,cpuMemoryRangeRegisters,cpuPageGlobalEnable,
                     cpuMachineCheckArchitecture,cpuConditionalMoveInstruction,
                     cpuPageAttributeTable,cpu32bitPageSzExtension,
                     cpuProcessorSerialNum,cpuMMXTechnology,cpuFastFloatingPoint,
                     cpuSIMDExtensions);

      TCpuFeatures = set of TCpuFeature;


function BDEinstalled(TerminateOnErr : boolean = false;
                      ShowErrorDlg : boolean = false;
                      InfoList : TStrings = nil) : string;
function CopyFrom(const S : string; StartPos : integer) : string;
function DefaultMessagingProfile : string;
function DeleteTree(const SrcPath : string) : boolean;
function FontInstalled(Const FontName : string) : boolean;
function Darker(Color : TColor; Percent : integer) : TColor;
function MixColors(C1,C2 : TColor) : TColor;
function Lighter(Color : TColor; Percent : integer) : TColor;
function ContrastColor(Color : TColor) : TColor;
function GetDAOversion : integer; overload;
function GetDAOversion(SList : TStrings) : integer; overload;
function StuffStr(const SrcStr,DestStr : string; Position : integer) : string;
function BrowseFolder(const title : string;Flags : longword = 0) : string;
function ServiceStart(aMachine,aServiceName : string) : boolean;
function ServiceStop(aMachine,aServiceName : string) : boolean;
function ServiceGetStatus(sMachine, sService: string ): DWord;
function ServiceGetStatusName(sMachine,sService: string ): string;
function WinCalcValue : string;
function MemCompare(P1,P2 : pointer; Len : integer) : integer;
function SearchTree(StartDir,FileToFind : string;
                    out FileNamePath : string) : boolean;
function StrInList(const SrcStr : string; List : TStrings) : boolean;
function AndEqual(Value,AndValue : longword) : boolean;
function BiosDate : string;
function BiosID : string;
function toString(Value : Variant) : string;
function IntToBase(Value : integer; Base : byte;Digits : byte = 0): string;
function BaseToint(Value : string; Base : byte) : integer;
function StartsWith(const SourceStr,TargetStr : string;
                    IgnoreCase : boolean = false) : boolean;
function EndsWith(const SourceStr,TargetStr : string;
                  IgnoreCase : boolean = false) : boolean;
function GetOSName : string;
function NetFindNextUnmapped : char;
function NetMappedName(LocalDrive : char) : string;
function NetUnMapDrive(LocalDrive : char) : dword;
function NetMapDrive(LocalDrive : char; const RemoteDrivePath : string;
                     UserName : string = ''; Password : string = '') : dword;
function GetLastWinErr(ShowDialog : boolean = true;
                       ErrNum : integer = 0) : string;
function GetMACAddress: string;
function GetParamVal(const TaggedParm : string;
                     IgnoreCase : boolean = true) : string;
function GetCpuSerialNum : string;
function StrToSex(SexStr : string) : TSex;
function SexToStr(Sex : TSex) : string;
function StrToFileName(const FileName : string; ReplaceInvalidWith : char = '_') : string;
function RoundIt(Value : extended; Decimals : integer = 2) : extended;
function Sign(Value : extended) : integer;
function LastChar(StrVar : string) : char;
function IsNullStr(const StrVar : string) : boolean;
function PosEx(const SubStr,TargetS : string; StartPos : integer = 1;
               IgnoreCase : boolean = false) : integer;
function PosCount(const SubStr,TargetS : string; CountIndex : integer = 1) : integer;
function DeskTopLVhandle : THandle;
function CharTypeSet(Ch : char) : TCharTypesSet;
function NumToLetters(Number : extended; Currency : string = 'Rands';
                      Cents : string = 'Cents') : string;
function Discount(Value : double; PercentDisc : double) : double; overload;
function Discount(Value : double; PercentDisc : double;
                  out DiscAmnt : double) : double; overload;
function MarkUp(Value : double; PercentMarkup : double) : double; overload;
function MarkUp(Value : double; PercentMarkup : double;
                out MarkupAmnt : double) : double; overload;
function GPpercent(Cost,Sell : double) : double; overload;
function GPpercent(Cost,Sell : double;
                   out MarkupPercent : double) : double; overload;
function IntToBin(IValue : Int64; NumBits : word = 64) : string;
function BinToInt(BinStr : string) : Int64;
function HexToInt(HexStr : string) : Int64;
function CPUSpeed : integer;
function MyIPAddress : string;
function DateStamp : string;
function FmtStrToInt(IntString : string) : integer;
function FmtStrToIntDef(IntString : string; DefValue : integer) : integer;
function FmtStrToFloat(FloatString : string) : extended;
function StrZero(Value : integer; Len : byte) : string;
function Pad(const S : string; L : byte; FillChar : char = ' ') : string;
function PadL(const S : string; L : byte; FillChar : char = ' ') : string;
function PadR(const S : string; L : byte; FillChar : char = ' ') : string;
function Space(N : byte) : string;
function Replicate(C : char; L : word) :string;
function Proper(StrVar : string) :string;
function Zdiv(N1,N2 : integer) : integer; overload;
function Zdiv(N1,N2 : extended) : extended; overload;
function Empty(const Arg : array of const) : boolean;
function AlphaOnly(StrVar : string) : string;
function NumericOnly(StrVar : string) : string;
function FileInUse(FileName : string) : boolean;
function GetLogonName(UCase : boolean = true) : string;
function GetDomainName(User : string = '') : string;
function GetDiskSerialNum(DriveLetter : char; HexValue : boolean = false) : string;
function GetExePath : string;
function GetExeName : string;
function GetExeFile : string;
function GetAliasPath(Aname : string) : string;
function ExtractCommaDelim(var Source : string) : string;
function ExtractField(var Source : string; Delimiter : string) : string; overload;
function ExtractField(StrList : TStrings; const Source : string; Delimiter : string) : string; overload;
function StripParen(const StrVar : string) : string;
function WinExecWait(const ChangeDir : string; const ExecutableFile : string;
                     Params : string = ''; WindowStyle : LongWord = SW_SHOWNORMAL) : boolean;
function FileVersion(const FileName : string = '') : string;
function FileVersionInfo(const FieldName : string; const FileName : string = '') : string;
function FileVersionLanguage(const FileName : string = '') : string;
function UnixPathToDosPath(FName : string) : string;
function DosPathToUnixPath(FName : string) : string;
function EnCryptString(StrVar : string; EncryptKey : string = '') : string;
function DeCryptString(StrVar : string; EncryptKey : string = '') : string;
function CharCount(SearchChar : char; Buffer : string) : integer;
function RPos(SubStr : string; S : string) : integer;
function GetUniqueFileName : string;
function IsNetworked : boolean;
function CheckBackSlash(Path : string; MustHave : boolean = true) : string;
function ConfirmDlg(MessageStr : string; DoBeep : boolean = true) : boolean;
function DateToStr4(TargetDate : TDateTime) : string;
function StrToDate4(DateStr : string; ErrMessage : boolean = true) : TDateTime;
function StrToDateTime4(const DateTimeStr : string) : TDateTime;
function StrToDateTime(DateStr : string) : TDateTime;
function DateToStr(TargetDate : TDateTime) : string;
function StrToDate(DateStr : string) : TDateTime;
function IsDefaultPrinter(Showmessage : boolean = true) : boolean; overload;
function IsDefaultPrinter(out DefaultPrinterName : string;
                          Showmessage : boolean = true) : boolean; overload;
function FontStyleToInt(FS : TFontStyles) : integer;
function IntToFontStyle(Num : integer) : TFontStyles;
function WindowsDir : string;
function WindowsSystemDir : string;
function ComputerName : string;
function GetFileTimes(FileName : string;
                      out Created  : TDateTime;
                      out Modified : TDateTime;
                      out Accessed : TDateTime) : boolean;
function CopyPdxTable(SrcTable,DstTable : string;
                      out ErrMess : string;
                      Overwrite : boolean = true) : boolean;
function iif(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Char): Char; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: extended): extended; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer; overload;
function iif(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload;
function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;
function BitIsSet(WordValue : word; BitNum : word) : boolean; overload;
function BitIsSet(WordValue : word; BitNums : array of word) : boolean; overload;


procedure LoadCLSID(StringList : TStrings; Separator : char = '*';
                    IncludeVersionIndependent : boolean = true);
procedure StrGridToHTML(const FileName : string; StrGrid : TStringGrid;
                        const Heading : string = '';
                        TextColor : TColor = clBlack;
                        TableBgColor : TColor = clAqua);
procedure StrGridToRTF(const Filename : string; SG : TStringGrid);

procedure DisableTaskManager(const State : boolean);
procedure DisableLockWorkStation(const State : boolean);
procedure DisableChangePassword(const State : boolean);
procedure DisableLogoff(const State : boolean);
procedure DisableShutdown(const State : boolean);
procedure DisableRegistryTools(const State : boolean);
procedure DisableScreenSaver(const State : boolean);
procedure SetScreenSaverTimeOut(const TimeMilSec : integer);
procedure PrintStrGrid(StringGrid : TStringGrid; ShowSetupDialog : boolean = true);
procedure SetCheckBoxCheck(cb : TCheckBox; Checked : boolean);
procedure GoURL(const WebUrl : string);
procedure SetTrackbarNarrow(TB : TTrackBar);
procedure CpyRecByName(Src,Dst : TDataSet);
procedure CpyRecByNum(Src,Dst : TDataSet);
procedure NetDomainList(StringList : TStrings);
procedure SetBit(var WordValue : word; BitNum : word); overload;
procedure SetBit(var WordValue : word; BitNums : array of word); overload;
procedure ClearBit(var WordValue : word; BitNum : word); overload;
procedure ClearBit(var WordValue : word; BitNums : array of word); overload;
procedure ToggleBit(var WordValue : word; BitNum : word); overload;
procedure ToggleBit(var WordValue : word; BitNums : array of word); overload;
procedure CreateTreeMenus(Path : string; Menu : TMainMenu;
                          Root : TMenuItem; ListImage : TImageList );
procedure JustifyMenuItem(Menu : TMainMenu; MenuItem : TMenuItem;
                         Justify : TJustifyMenuMode = jsmRight);
procedure ScreenShot(X1,X2,Y1,Y2 : integer; BMap : TBitMap); overload;
procedure ScreenShot(BMap : TBitMap); overload;
procedure ScreenShot(X1,X2,Y1,Y2 : integer; JMap : TJPEGImage); overload;
procedure ScreenShot(JMap : TJPEGImage); overload;
procedure AllowMultiline(theControl : TWinControl);
procedure ShredFile(const FileName : string);
procedure QueryToStrGrid(Query : TQuery; StrGrid : TStringGrid; Titles : boolean = true);
procedure GetScreenXY(TargetControl : TControl; out X : integer;
                      out Y : integer);
procedure VarToStr(var Source; Count : integer; out StrVar : string;
                   ReplaceChar0With : char = #0);
procedure StrToVar(const StrVar : string; out UtypedVar);
procedure SetLastChar(var StrVar : string; CharValue : char);
procedure GetWindowsList(TS : TStrings);
procedure SwapMem(var Source,Dest; Len : integer);
procedure StringScan(const Buffer : string; const Mask : string; LinesList : TStrings);
procedure ErrorDlg(MessageStr : string; DoBeep : boolean = true);
procedure InfoDlg(MessageStr : string; DoBeep : boolean = true);
procedure WarningDlg(MessageStr : string; DoBeep : boolean = true);
procedure SetMaxSize(Form : TForm);
procedure HaltApplication(UserMessage : string; ShowMessage : boolean = false);
procedure Delay(ms : longword);
procedure LoadGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
procedure SaveGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
procedure SetAutoStart(AppTitleKey : string; Status : boolean = true);
procedure RemoveFormCaption(Form : TForm);
procedure SortStr(var StrVar : string);
procedure ReplaceChars(var StrVar : string; ThisChar,WithChar : char;
                       IgnoreCase : boolean = false);
procedure IncLimit(var X : longint; Limit : longint;
                   RollOverVal : longint = 0; IncBy : longint = 1);
procedure DecLimit(var X : longint; Limit : longint;
                   RollUnderVal : longint = 0; DecBy : longint = -1);
procedure TextOutAngle(ParentCanvas : TCanvas;
                       X,Y : integer;
                       const FontName : string;
                       FontSize,Angle : integer;
                       const Txt : string;
                       Color : TColor = clBlack;
                       Transparent : boolean = true);
procedure AnimateShowWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
procedure AnimateHideWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
procedure DisableKeyboard;
procedure EnableKeyboard;

{ ======================================================================== }

implementation

const ENCRYPT_KEY = 'Put some string Here That is Meaningfull';

      // Win ver constants
      cOsUnknown              : integer = -1;
      cOsWin95                : integer =  0;
      cOsWin98                : integer =  1;
      cOsWin98SE              : integer =  2;
      cOsWinME                : integer =  3;
      cOsWinNT                : integer =  4;
      cOsWin2000              : integer =  5;
      cOsWhistler             : integer =  6;

var oldHook : HHook;  // Used by keyboard enable/disable

// Keyboard intercept routine

function KeyBoardHook(Code : integer; wParam : word; lParam: longint) : longint;
begin
  if (Code < 0) then
     Result := CallNextHookEx(oldHook,Code,wParam,lParam)
  else
     Result := 1;
end;

procedure DisableKeyboard;
begin
  oldHook := SetWindowsHookEx(WH_KEYBOARD,@KeyBoardHook,HInstance,0);
end;

procedure EnableKeyboard;
begin
  if (oldHook <> 0) then begin
     UnhookWindowshookEx(oldHook);
     oldHook := 0;
  end;
end;

// =============================================
// Simple password encode/decode routines
// Changed to EncryptString and DecryptString
// was .....
// function EncodePassword(Pass : string) : string;
// function DecodePassword(Pass : string) : string;
// =============================================

function EnCryptString(StrVar : string; EncryptKey : string = '') : string;
var Cmd,Key  : string;
    i,KIdx : integer;
    Ch : byte;
begin
   Cmd := StringOfChar(' ',length(StrVar));
   KIdx := 1;
   if EncryptKey = '' then Key := ENCRYPT_KEY else Key := EncryptKey;

   for i := 1 to length(StrVar) do begin
      Ch := byte(StrVar[i]) xor byte(Key[KIdx]);
      if Ch = 0 then Ch := 255;
      Cmd[i] := char(Ch);
      inc(KIdx);
      if KIdx > length(Key) then KIdx := 1;
   end;

   Result := Cmd;
end;


function DeCryptString(StrVar : string; EncryptKey : string = '') : string;
var Cmd,Key : string;
    Ch : byte;
    i,KIdx : integer;
begin
   Cmd := StringOfChar(' ',length(StrVar));
   KIdx := 1;
   if EncryptKey = '' then Key := ENCRYPT_KEY else Key := EncryptKey;

   for i := 1 to length(StrVar) do begin
      Ch := byte(StrVar[i]);
      if Ch = 255 then Ch := 0;
      Cmd[i] := char(Ch xor byte(Key[KIdx]));
      inc(KIdx);
      if KIdx > length(Key) then KIdx := 1;
   end;
  
   Result := Cmd;
end;

// ===================================
// Convert a string to a TSex var
// ===================================

function StrToSex(SexStr : string) : TSex;
var BChar : char;
    Cmd : TSex;
begin
  Cmd := sxUnknown;

  if (length(SexStr) > 0) then begin
      BChar := UpCase(SexStr[1]);

      case BChar of
           'M' : Cmd := sxMale;
           'F' : Cmd := sxFemale;
      end;
  end;

  Result := Cmd;
end;


// ==================================
// Convert a TSex var to a string
// ==================================

function SexToStr(Sex : TSex) : string;
var Cmd : string;
begin
  Cmd := 'Unknown';
  case Sex of
       sxMale : Cmd := 'Male';
       sxFemale : Cmd := 'Female';
  end;

  Result := Cmd;
end;

// ===============================================
// Convert a string to a valid file name
// Invalid chars are replaced by ReplaceWith
// Default replace char is UNDER_LINE
// ===============================================

function StrToFileName(const FileName : string;
                       ReplaceInvalidWith : char = '_') : string;
var Cmd : string;
    i : integer;
begin
  Cmd := FileName;
  for i := 1 to length(FileName) do
    if Cmd[i] in INVALID_FILE_CHARS then
      Cmd[i] := ReplaceInvalidWith;

  Result := Cmd;
end;


// ===================================
// Return Count of a char in a string
// ===================================

function CharCount(SearchChar : char; Buffer : string) : integer;
var C,i : integer;
begin
  C := 0;
  if length(Buffer) > 0 then
     for i := 1 to length(Buffer) do
         if Buffer[i] = SearchChar then inc(C);
  Result := C;
end;

// ====================================================
// Str to Numeric Functions same as Delphi's StrToInt,
// StrToIntDef,StrToFloat.
// allows formatted strings eg. 9,143,654
// ====================================================

function FmtStrToInt(IntString : string) : integer;
var i : byte;
    s : string;
    sign : integer;
begin
  s := '';
  sign := 1;
  for i := 1 to length(IntString) do begin
      if IntString[i] = '-' then sign := -1;
      if IntString[i] in ['0'..'9'] then s := s + IntString[i];
  end;

  Result := StrToInt(s) * sign;
end;


function FmtStrToIntDef(IntString : string; DefValue : integer) : integer;
var i : byte;
    s : string;
    sign,v : integer;
begin
  s := '';
  sign := 1;
  for i := 1 to length(IntString) do begin
      if IntString[i] = '-' then sign := -1;
      if IntString[i] in ['0'..'9'] then s := s + IntString[i];
  end;

  try
    v := StrToInt(s) * sign;
  except
    v := DefValue;
  end;

  Result := v;
end;


function FmtStrToFloat(FloatString : string) : extended;
var i : byte;
    s : string;
    sign : extended;
begin
  s := '';
  sign := 1.0;
  for i := 1 to length(FloatString) do begin
      if FloatString[i] = '-' then sign := -1.0;
      if FloatString[i] in ['0'..'9','.'] then s := s + FloatString[i];
  end;

  try
    Result := StrToFloat(s) * sign;
  except
    Result := 0;
  end;
end;


{ ===================================== }
{ Execute a program like WINEXE()       }
{ But WAIT for the program to terminate }
{ before returning to the calling app   }
{ Returns true or false.                }
{ ===================================== }

function WinExecWait(const ChangeDir : string;
                     const ExecutableFile : string;
                     Params : string = '';
                     WindowStyle : LongWord = SW_SHOWNORMAL) : boolean;
var  p : TProcessInformation;
     s : TStartupInfo;
     PParams : PChar;
     Cmd : boolean;
     CDir : string;
begin
   CDir := GetCurrentDir;
   s.cb := SizeOf(TStartupInfo);
   s.wShowWindow := WindowStyle;
   s.lpDesktop := nil;
   s.dwFlags := STARTF_USESHOWWINDOW;
   s.lpReserved := nil;
   s.lpTitle := nil;
   s.cbReserved2 := 0;
   s.lpReserved2 := nil;

   if trim(ChangeDir) <> '' then SetCurrentDir(ChangeDir);

   if trim(Params) = '' then
      PParams := PChar(ExecutableFile)
   else begin
      // if Params[1] <> ' ' then Params := ' ' + Params;  W2000 ???
      if Params[1] <> ' ' then Params := '"' + ExecutableFile + '" ' + Params ;

      PParams := PChar(Params);
   end;

   // Following does not work in W2000
   // if CreateProcess(PChar(ExecutableFile),PParams,nil,nil,true,0,nil,nil,s,p) then begin
   if CreateProcess(nil,PParams,nil,nil,true,0,nil,nil,s,p) then begin
      WaitForSingleObject(p.hProcess,INFINITE);
      CloseHandle(p.hProcess);
      CloseHandle(p.hThread);
      Cmd := true;
   end
   else
      Cmd := false;

   SetCurrentDir(CDir);
   Result := Cmd;
end;



{ ============================== }
{ Convert Unix Path to Dos Path  }
{ and vice-versa                 }
{ ============================== }

function UnixPathToDosPath(FName : string) : string;
var i : integer;
begin
  for i := 1 to length(FName) do if FName[i] = '/' then FName[i] := '\';
  Result := FName;
end;

function DosPathToUnixPath(FName : string) : string;
var i : integer;
begin
  for i := 1 to length(FName) do if FName[i] = '\' then FName[i] := '/';
  Result := FName;
end;

// =============================================================
// Return the file version of a
// Win32 executable file. See FileVersionInfo for additional                }
// =============================================================

function FileVersion(const FileName : string = '') : string;
var V1,V2,V3,V4 : word;
    VerInfoSize, VerValueSize, Dummy : DWORD;
    VerInfo : Pointer;
    VerValue : PVSFixedFileInfo;
    FName : string;
begin
  try
    if FileName = '' then
       FName := GetExePath + GetExeFile
    else
       FName := trim(FileName);
    VerInfoSize := GetFileVersionInfoSize(PChar(FName), Dummy);
    GetMem(VerInfo, VerInfoSize);

    try
      GetFileVersionInfo(PChar(FName), 0, VerInfoSize, VerInfo);
      VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);

      with VerValue^ do begin
          V1 := dwFileVersionMS shr 16;
          V2 := dwFileVersionMS and $FFFF;
          V3 := dwFileVersionLS shr 16;
          V4 := dwFileVersionLS and $FFFF;
      end;
    finally
      FreeMem(VerInfo, VerInfoSize);
    end;

    Result := IntToStr(V1) + '.' + IntToStr(V2) + '.' +
             IntToStr(V3) + '.' + IntToStr(V4);
  except
    Result := '';
  end;
end;

// =================================================================
// Get info form file version eg. "Comments", "ProductName" etc.
// See Project/Options/Version Info for available Fields
// =================================================================

function FileVersionInfo(const FieldName : string;
                         const FileName : string = '') : string;
var VerInfoSize,VerValueSize,Dummy : DWORD;
    Lang : string;
    VerInfo : Pointer;
    VerValue : ^word;
    VerChar : PChar;
    FName : string;
begin
  VerChar := nil;
  try
    if FileName = '' then
       FName := GetExePath + GetExeFile
    else
       FName := trim(FileName);
    VerInfoSize := GetFileVersionInfoSize(PChar(FName),Dummy);
    GetMem(VerInfo,VerInfoSize);

    try
      GetFileVersionInfo(PChar(FName),0,VerInfoSize,VerInfo);
      VerQueryValue(VerInfo,'\VarFileInfo\Translation',
                    Pointer(VerValue),VerValueSize);
      Lang := IntToHex(VerValue^,4);
      inc(VerValue);
      Lang := Lang + IntToHex(VerValue^,4);
          VerQueryValue(VerInfo,PChar('\StringFileInfo\' + Lang + '\' + FieldName),
                    Pointer(VerChar),VerValueSize);
      if VerChar <> nil then begin
        Result := VerChar;
        SetLength(Result,StrLen(PChar(Result)))
      end
      else
        Result := '';
    finally
      FreeMem(VerInfo,VerInfoSize);
    end;
  except
    Result := '';
  end;
end;


function FileVersionLanguage(const FileName : string = '') : string;
var VerInfoSize,VerValueSize,Dummy : DWORD;
    VerInfo : Pointer;
    Lang : string;
    VerValue : ^DWORD;
    FName : string;
begin
  SetLength(Lang,257);
  try
    if FileName = '' then
       FName := GetExePath + GetExeFile
    else
       FName := trim(FileName);
    VerInfoSize := GetFileVersionInfoSize(PChar(FName),Dummy);
    GetMem(VerInfo,VerInfoSize);

    try
      GetFileVersionInfo(PChar(FName),0,VerInfoSize,VerInfo);
      VerQueryValue(VerInfo,'\VarFileInfo\Translation',
                    Pointer(VerValue),VerValueSize);
      VerLanguageName(VerValue^,PChar(Lang),256);
      Result := Lang;
      SetLength(Result,StrLen(PChar(Result)))
    finally
      FreeMem(VerInfo,VerInfoSize);
    end;
  except
    Result := '';
  end;
end;





{ ==================================== }
{ Return a string with it's            }
{ Parenthesis stripped.                }
{ eg. "Freddy" will return Freddy      }
{     [Koos] will return Koos          }
{ ==================================== }

function StripParen(const StrVar : string) : string;
begin
  Result := copy(StrVar,2,length(StrVar)-2);
end;

{ ==================================== }
{ Return a boolean of state of file    }
{ false = File is NOT open on network  }
{ true  = file is open on network      }
{ ==================================== }

function FileInUse(FileName : string) : boolean;
var F : file;
    IsInUse : boolean;
begin
  AssignFile(F,FileName);

  try
    Reset(F);
    CloseFile(F);
    IsInUse := false;
  except
    IsInUse := true;
  end;

  Result := IsInUse;
end;


// =================================================
// Return true/false if string is in string list
// =================================================

function StrInList(const SrcStr : string; List : TStrings) : boolean;
var Cmd : boolean;
    i : integer;
    CmpStr : string;
begin
  Cmd := false;
  CmpStr := UpperCase(trim(SrcStr));

  for i := 0 to List.Count - 1 do begin
    if CmpStr = Uppercase(trim(List[i])) then begin
      Cmd := true;
      break;
    end;
  end;

  Result := Cmd;
end;


{ =========================== }
{ Return a string of N spaces }
{ =========================== }

function Space(N : byte) : string;
begin
    Space := StringOfChar(' ',N);
end;

{ ========================================== }
{ Replicate returns a string of C that is    }
{ L characters long. OBSOLETE                }
{ Use StringofChar instead !!!!!!!
{ ========================================== }

function Replicate(C : char; L : word) :string;
begin
   Result := StringOfChar(C,L);
end;

{ =================================================== }
{ Returns a string left padded with zeros for L bytes }
{ =================================================== }

function StrZero(Value : integer; Len : byte) : string;
begin
   Result := FormatFloat(StringOfChar('0',Len),Value);
end;

{ ======================================= }
{ Right justify a string an pad remaining }
{ space with blanks or truncate if < L    }
{ ======================================= }

function PadR(const S : string; L : byte; FillChar : char = ' ') : string;
begin
  Result := Pad(S,L,FillChar);
end;

function Pad(const S : string; L : byte; FillChar : char = ' ') : string;
var Cmd : string;
begin
  Cmd := trim(S);

  if L < length(Cmd) then
      Cmd := Copy(Cmd,1,L)
  else
      Cmd := Cmd + StringOfChar(FillChar,L - length(Cmd));

  Result := Cmd;
end;

{ ====================================== }
{ Right justify a string                 }
{ ====================================== }

function PadL(const S : string; L : byte; FillChar : char = ' ') : string;
var Cmd : string;
begin
  Cmd := trim(S);
  if L < length(Cmd) then
      Cmd := Copy(Cmd,1,L)
  else
      Cmd := StringOfChar(FillChar,L - length(S)) + S;

  Result := Cmd;
end;

// =====================================
// Like copy, but does not need LEN
// =====================================

function CopyFrom(const S : string; StartPos : integer) : string;
begin
  Result := copy(S,StartPos,MAXSTRING);
end;

{ ==================================== }
{ Return a proper name from a var      }
{ ==================================== }

function Proper(StrVar : string) :string;
var Upit   : boolean;
    RetStr : string;
    I,Olen : word;
    S      : string[1];
begin
    Upit   := true;
    RetStr := '';
    Olen   := length(StrVar);

    StrVar := trim(Lowercase(StrVar));

    for I := 1 to length(StrVar) do begin
      S := copy(StrVar,I,1);

      if Upit or (S = ' ') or (S = '.') then begin
         S := upcase(S[1]);
         Upit := (S = ' ') or (S = '.');
      end;

      RetStr := RetStr + S;
    end;

  Result := Pad(RetStr,Olen);
end;

{ =================================== }
{ Eliminate DIVIDE by zero error      }
{ of two reals.                       }
{ Zdiv returns 0 if divisor is zero   }
{ Overload to accomodate int and real }
{ =================================== }

function Zdiv(N1,N2 : extended) : extended; overload;
var Cmd : extended;
begin
  Cmd := 0.00;
  if N2 <> 0.0 then Cmd := N1 / N2;
  Result := Cmd;
end;

function Zdiv(N1,N2 : integer) : integer; overload;
var Cmd : integer;
begin
  Cmd := 0;
  if N2 <> 0 then Cmd := N1 div N2;
  Result := Cmd;
end;

{ ================================ }
{ Return true if var type is empty }
{ param passed as [Xvar]           }
{ ================================ }

function Empty(const Arg : array of const) : boolean;
begin
  Result := false;

  case Arg[0].VType of
       vtInteger  : if Arg[0].VInteger = 0 then Result := true;
       vtBoolean  : if not Arg[0].VBoolean then Result := true;
       vtChar     : if Arg[0].VChar in [#0,#32] then Result := true;
       vtExtended : if abs(Arg[0].VExtended^) < 0.000001 then Result := true;
       vtString   : if trim(Arg[0].VString^) = '' then Result := true;
       vtPointer  : if Arg[0].VPointer = nil then Result := true;
       vtPchar    : if trim(StrPas(Arg[0].VPchar)) = '' then Result := true;
  else
       MessageBeep(MB_ICONHAND);
       if MessageDlg('                   BAD PARAMETER' + CrLf + CrLf +
                     'Invalid Type Sent To FUNCTION EMPTY( [ Xvar ] )' + CrLf +
                     CrLf + '     INTEGER,BOOLEAN,CHAR,EXTENDED' + CrLf +
                     '     STRING,POINTER or PCHAR Expected' + CrLf
                     ,mtError,[mbAbort,mbIgnore],0) = 3 then
                     Application.Terminate;

  end;
end;

// ==============================================================
// Same as Borland POS() except returns POS of LAST occurance
// ==============================================================

function RPos(SubStr : string; S : string) : integer;
var i : integer;
begin
  SubStr := ReverseString(SubStr);
  S := ReverseString(S);
  i := pos(SubStr,S);
  if i <> 0 then i := (length(S) + 1) - (i + length(SubStr) - 1);
  Result := i;
end;


{ ================================================= }
{ Return Alpha Characters only from a passed string }
{ ================================================= }

function AlphaOnly(StrVar : string) : string;
var RetStr : string;
    i : integer;
begin
  RetStr := '';
  for i := 1 to length(StrVar) do
    if StrVar[i] in ['A'..'Z','a'..'z'] then RetStr := RetStr + StrVar[i];
  Result := RetStr;
end;

{ =================================================== }
{ Return Numeric Characters only from a passed string }
{ =================================================== }

function NumericOnly(StrVar : string) : string;
var RetStr : string;
    i : integer;
begin
   RetStr := '';
   for I := 1 to length(StrVar) do
       if StrVar[i] in ['0'..'9'] then RetStr := RetStr + StrVar[i];
   Result := RetStr;
end;

// =============================
// Return Windows Logon Name
// =============================

function GetLogonName(UCase : boolean = true) : string; platform;
var Count : DWORD;
begin
  Count := 257;
  SetLength(Result,Count);
  {$WARNINGS OFF}
  Win32Check(GetUserName(PChar(Result),Count));
  SetLength(Result,StrLen(PChar(Result)));
  {$WARNINGS ON}
  if UCase then Result := UpperCase(Result);
end;


function GetDomainName(User : string = '') : string; platform;
var Count1,Count2 : DWORD;
    Sd : PSecurityDescriptor;
    Snu : SID_Name_Use;
begin
  Sd := nil;
  Snu := SIDTypeUser;
  Count1 := 0;
  Count2 := 0;
  if trim(User) = '' then User := GetLogonName(false);
  {$WARNINGS OFF}
  LookupAccountName(nil,PChar(User),Sd,Count1,PChar(Result),Count2,Snu);
  SetLength(Result,Count2 + 1);
  Sd := AllocMem(Count1);

  try
    if LookupAccountName(nil,PChar(User),Sd,Count1,PChar(Result),Count2,Snu) then
       SetLength(Result,StrLen(PChar(Result)))
    else
       Result := '';
  finally
    FreeMem(Sd);
  end;
  {$WARNINGS ON}
end;




// =====================================
// Get the serial number from hard disk
// =====================================

function GetDiskSerialNum(DriveLetter : char; HexValue : boolean = false) : string;
var VolumeSerialNumber : DWORD;
    MaximumComponentLength : DWORD;
    FileSystemFlags : DWORD;
    Cmd : string;
begin
  Cmd := '';
  try
    GetVolumeInformation(PChar(DriveLetter + ':\'),
                         nil, 0, @VolumeSerialNumber,
                         MaximumComponentLength, FileSystemFlags,
                         nil, 0);
    if HexValue then
       Cmd := IntToHex(HiWord(VolumeSerialNumber), 4) +
                 '-' + IntToHex(LoWord(VolumeSerialNumber), 4)
    else
       Cmd := IntToStr(VolumeSerialNumber);            
  except end;

  Result := Cmd;
end;


// ========================
// Various Program Paths
// ========================

function GetExePath : string;
begin
  Result := ExtractFilePath(Application.ExeName);
end;

function GetExeFile : string;
begin
  Result := ExtractFileName(Application.ExeName);
end;

function GetExeName : string;
var ExName : string;
begin
  ExName := ExtractFileName(Application.ExeName);
  Result := copy(ExName,1,pos('.',ExName)-1);
end;

function GetAliasPath(Aname : string) : string;
var i : integer;
    L : TStringList;
    Cmd : string;
begin
  Cmd := '';
  L := TStringList.Create;
  Session.GetAliasParams(Aname,L);
  for i := 0 to L.Count-1 do
    if uppercase(copy(L[i],1,5)) = 'PATH=' then
       Cmd := copy(L[i],6,length(L[i])) + '\';
  L.Free;
  Result := Cmd;
end;


{ ================================================================= }
{ Extracts a field from a string delimited by "Delimeter"           }
{ The source string is returned with the field and delim removed    }
{ ================================================================= }

function ExtractField(var Source : string; Delimiter : string) : string;
var Cmd : string;
    L,P : integer;
begin
  P := pos(Delimiter,Source);

  if P = 0 then begin
     Cmd := Source;
     Source := '';
  end
  else begin
     Cmd := '';
     L := length(Source);
     Cmd := copy(Source,1,P - 1);
     L := L - (length(Cmd) + 1);
     Source := copy(Source,P + 1,L);
  end;

  Result := Cmd;
end;

// Similar - but sets a string list

function ExtractField(StrList : TStrings; const Source : string;
                      Delimiter : string) : string; overload;
var S : string;
begin
  StrList.Clear;
  S := Source;

  while S <> '' do begin
    StrList.Add(ExtractField(S,'|'));
  end;
end;



// ============================================================
// Returns a string list of lines sepparated by delimiters
// Similar to BAAN string.scan
// eg.  StringScan(Buffer,'|||%|',StrLst)
// =============================================================

procedure StringScan(const Buffer : string; const Mask : string;
                     LinesList : TStrings);
var i : integer;
    MainLine : string;
begin
  LinesList.Clear;
  MainLine := Buffer;
  for i := 1 to length(Mask) do LinesList.Add(ExtractField(MainLine,Mask[i]));
  LinesList.Add(MainLine);
end;


// =============================================================
// Insert and delete into a string starting at position
// =============================================================

function StuffStr(const SrcStr,DestStr : string; Position : integer) : string;
var Cmd : string;
begin
  Cmd := DestStr;
  Delete(Cmd,Position,length(SrcStr));
  Insert(SrcStr,Cmd,Position);
  Result := Cmd;
end;



{ ================================================================= }
{ Extracts a field from a string comma delimited and                }
{ enclosed with quotes ""                                           }
{ ================================================================= }

function ExtractCommaDelim(var Source : string) : string;
var Cmd : string;
    L,i : integer;
begin
  Cmd := '';
  i := 2;
  L := length(Source);

  if (trim(Source) <> '') and (Source[1] = '"') then begin  // Quotes
     while (Source[i] <> '"') and (i <= L) do inc(i);
     if Source[i] = '"' then begin
        Cmd := StripParen(copy(Source,1,i));
        Delete(Source,1,i+1);   // Remove Field and comma
     end;
  end
  else
  if (trim(Source) <> '') and (Source[1] <> '"') then begin  // Integer
     while (Source[i] <> ',') and (i <= L) do inc(i);
     Cmd := copy(Source,1,i-1);
     Delete(Source,1,i);   // Remove Field and comma
  end;

  Result := Cmd;
end;


// ====================================================
// Return a unique filename in Default TEMP Directory
// File is Created and Closed 0 bytes in length
// ====================================================

function GetUniqueFileName : string;
var Cmd : string;
    TempPath : string;
begin
  SetLength(Cmd,257);
  SetLength(TempPath,257);
  GetTempPath(257,PChar(TempPath));
  GetTempFileName(PChar(TempPath),'Mah',0,PChar(Cmd));
  if pos(#0, Cmd) > 0 then Cmd := copy(Cmd, 1, pos(#0, Cmd) - 1);
  Result := Cmd;
end;

// ===============================================
// Return a sortable date/time string of NOW
// in format YYYY/MM/DD-HH:NN:SS:ZZZ
// ===============================================

function DateStamp : string;
begin
  Result := FormatDateTime('yyyy/mm/dd hh:nn:ss:zzz',Now);
end;


{ ======================================== }
{ This is a FAST swap routine that swaps   }
{ the contents of any 2 variables.         }
{ The variables may be of any type but     }
{ the sizeof the VAR must be passed in Len }
{ the variable L. ASSEMBLER                }
{ ======================================== }

procedure SwapMem(var Source,Dest; Len : integer);
   begin
     asm
         push edi
         push esi
         mov esi,Source
         mov edi,Dest
         mov ecx,Len
         cld
     @1:
         mov al,[edi]
         xchg [esi],al
         inc si
         stosb
         loop @1
         pop esi
         pop edi
      end;
   end;


// ======================================
// Return true if attached to a network
// ======================================

function IsNetworked : boolean;
begin
  Result := (GetSystemMetrics(SM_NETWORK) and 1 = 1);
end;

// ======================================
// Various Error Message Dialog boxes
// Short cuts of MessageDlg()
// ======================================

procedure ErrorDlg(MessageStr : string; DoBeep : boolean = true);
begin
  if DoBeep then MessageBeep(MB_ICONHAND);
  MessageDlg(MessageStr,mtError,[mbOk],0);
end;

procedure InfoDlg(MessageStr : string; DoBeep : boolean = true);
begin
  if DoBeep then MessageBeep(MB_ICONEXCLAMATION);
  MessageDlg(MessageStr,mtInformation,[mbOk],0);
end;

function ConfirmDlg(MessageStr : string; DoBeep : boolean = true) : boolean;
begin
  if DoBeep then MessageBeep(MB_ICONQUESTION);
  Result :=  (MessageDlg(MessageStr,mtConfirmation,[mbYes,mbNo],0) = mrYes);
end;

procedure WarningDlg(MessageStr : string; DoBeep : boolean = true);
begin
  if DoBeep then MessageBeep(MB_ICONASTERISK);
  MessageDlg(MessageStr,mtWarning,[mbOk],0);
end;

// =================================================
// Set Maximum form size without covering task bar
// =================================================

procedure SetMaxSize(Form : TForm);
var h : THandle;
    r : TRect;
begin
  h := FindWindow('Shell_TrayWnd',nil);
  if h <> 0 then begin
     GetWindowRect(h,r);
     if r.Bottom - r.Top <= 6 then
      Form.SetBounds(0,0,Screen.Width,Screen.Height)
     else
      if r.Left > 0 then
         Form.setBounds(0,0,r.Left,Screen.Height)
      else
       if r.Right < Screen.Width - 10 then
          Form.SetBounds(r.Right,0,Screen.Width - r.Right,Screen.Height)
           else
             if r.Bottom < Screen.Height - 10 then
                Form.SetBounds(0,r.Bottom,Screen.Width,Screen.Height - r.Bottom)
             else
                Form.SetBounds(0,0,Screen.Width,r.Top)
  end
  else
    Form.SetBounds(0,0,Screen.Width,Screen.Height);
end;

// ====================================================
// Strip or add backslash to directory path
// See includetrailingbackslash()
// ====================================================

function CheckBackSlash(Path : string; MustHave : boolean = true) : string;
begin
    Path := trim(Path);
    if MustHave and (length(Path) > 0) and (Path[length(Path)] <> '\') then
       Path := Path + '\';
    if not MustHave and (length(Path) > 0) and (Path[length(Path)] = '\') then
       delete(Path,length(Path),1);
    Result := Path;
end;

// =====================================
// Graceful application termination
// Cannot use halt in OnShow of Form
// =====================================

procedure HaltApplication(UserMessage : string; ShowMessage : boolean = false);
begin
   if ShowMessage then ErrorDlg(UserMessage);
   Application.Terminate;
   Raise EApplicationFail.Create(UserMessage);
end;

// ======================================================================
// Date functions to overcome Borland's standard StrTodate() and
// DateToStr(), which require and return dates in format DD/MM/YY
// These functions workd the same but require and return dates in
// with 4 digit year in format DD/MM/YYYY
// ======================================================================

function DateToStr4(TargetDate : TDateTime) : string;
var yyyy,mm,dd : word;
begin
  DecodeDate(Targetdate,yyyy,mm,dd);
  Result := FormatFloat('00',dd) + '/' +
            FormatFloat('00',mm) + '/' +
            FormatFloat('0000',yyyy);
end;


function StrToDate4(DateStr : string; ErrMessage : boolean = true) : TDateTime;
var yyyy,mm,dd : word;
    Cmd : TDateTime;
begin
    try
      dd := StrToIntDef(copy(DateStr,1,2),0);
      mm := StrToIntDef(copy(DateStr,4,2),0);
      yyyy := StrToIntDef(copy(DateStr,7,4),0);
      Cmd := EncodeDate(yyyy,mm,dd);
    except
      on E:Exception do begin
         if ErrMessage then MessageDlg(E.Message,mtError,[mbOk],0);
         Cmd := 0.0;
      end;
    end;

    Result := Cmd;
end;

// ====================================
// Convert string to a TDateTime
// Format dd/mm/yyyy hh:nn:ss
// hh:nn:ss is optional
// ====================================

function StrToDateTime4(const DateTimeStr : string) : TDateTime;
var yyyy,mm,dd,hh,nn,ss : word;
    S : string;
    P : integer;
    Cmd : TDateTime;
begin
  Cmd := 0.0;
  hh := 0;
  nn := 0;
  ss := 0;

  if length(DateTimeStr) > 0 then begin
     S := DateTimeStr;
     P := pos('/',S);
     dd := StrToIntDef(copy(S,1,P - 1),0);
     S := copy(S,P + 1,18);
     P := pos('/',S);
     mm := StrToIntDef(copy(S,1,P - 1),0);
     S := copy(S,P + 1,18);
     P := pos(' ',S);
     if P = 0 then
       yyyy := StrToIntDef(S,0)
     else begin
       yyyy := StrToIntDef(copy(S,1,P - 1),0);
       S := copy(S,P + 1,18);
       P := pos(':',S);
       if P = 0 then
         hh := StrToIntDef(S,0)
       else begin
         hh := StrToIntDef(copy(S,1,P - 1),0);
         S := copy(S,P + 1,18);
         P := pos(':',S);
         if P = 0 then
           nn := StrToIntDef(S,0)
         else begin
           nn := StrToIntDef(copy(S,1,P - 1),0);
           S := copy(S,P + 1,18);
           ss := StrToIntDef(S,0);
         end;
      end;
     end;

     try
       Cmd := EncodeDate(yyyy,mm,dd) + EncodeTime(hh,nn,ss,0);
     except
       on E: Exception do begin
         MessageDlg(E.Message,mtError,[mbOk],0);
         Cmd := 0.0;
       end;
     end;
  end;

  Result := Cmd;
end;


// Override and Warn if using standard Delphi functions

function DateToStr(TargetDate : TDateTime) : string;
begin
   InfoDlg('Rather use DateToStr4()'#13'It is NOT dependant on ShortDateFormat'+
           #13'and uses fixed format DD/MM/YYYY');
   Result := '**/**/****';
end;


function StrToDate(DateStr : string) : TDateTime;
begin
   InfoDlg('Rather use StrToDate4()'#13'It is NOT dependant on ShortDateFormat'+
           #13'and uses fixed format DD/MM/YYYY');
   Result := 0;
end;

function StrToDateTime(DateStr : string) : TDateTime;
begin
   InfoDlg('Rather use StrToDateTime4()'#13'It is NOT dependant on ShortDateFormat'+
           #13'and uses fixed format DD/MM/YYYY HH:NN:SS');
   Result := 0;
end;



// ===========================================
// Check if a default printer is installed
// ===========================================

function IsDefaultPrinter(Showmessage : boolean = true) : boolean; overload;
var FDevice,FDriver,FPort : array [0..254] of char;
    FHandle : THandle;
    CurrentPrinterName : string;
    Cmd : boolean;
begin
  Cmd := false;

  try
    if Printer.Handle <> 0 then begin
      Printer.GetPrinter(FDevice,FDriver,FPort,FHandle);
      CurrentPrinterName := FDevice;

      if CurrentPrinterName <> '' then
        Cmd := true
      else begin
        Cmd := false;
        if ShowMessage then ErrorDlg('No Default Printer is Defined');
      end;
    end;
  except
    if ShowMessage then ErrorDlg('Cannot Open Default Printer');
    Cmd := false;
  end;

  Result := Cmd;
end;

function IsDefaultPrinter(out DefaultPrinterName : string;
                          Showmessage : boolean = true) : boolean; overload;
var FDevice,FDriver,FPort : array [0..254] of char;
    FHandle : THandle;
    CurrentPrinterName : string;
    Cmd : boolean;
begin
  Cmd := false;

  try
    if Printer.Handle <> 0 then begin
      Printer.GetPrinter(FDevice,FDriver,FPort,FHandle);
      CurrentPrinterName := FDevice;
      DefaultPrinterName := CurrentPrinterName;

      if CurrentPrinterName <> '' then
        Cmd := true
      else begin
        Cmd := false;
        if ShowMessage then ErrorDlg('No Default Printer is Defined');
      end;
    end;
  except
    if ShowMessage then ErrorDlg('Cannot Open Default Printer');
    Cmd := false;
  end;

  Result := Cmd;
end;



// ============================
// Delay for X miliseconds
// 1000 ms = 1 second
// ============================

procedure Delay(ms : longword);
var TheTime : longword;
begin
  TheTime := GetTickCount + ms;
  while GetTickCount < TheTime do Application.ProcessMessages;
end;

// ===============================
// Convert Fontstyles to Integer
// ===============================

function FontStyleToInt(FS : TFontStyles) : integer;
var Cmd : integer;
begin
  Cmd := 0;
  if fsBold in FS then inc(Cmd);
  if fsItalic in FS then inc(Cmd,2);
  if fsUnderline in FS then inc(Cmd,4);
  if fsStrikeOut in FS then inc(Cmd,8);
  Result := Cmd;
end;

// ==========================================
// Is a font installed in the system ?
// ==========================================

function FontInstalled(const FontName : string) : boolean;
begin
  Result := Screen.Fonts.IndexOf(FontName) > 0;
end;


// ===============================
// Convert Integer to TFontstyles
// ===============================

function IntToFontStyle(Num : integer) : TFontStyles;
var Cmd : TFontStyles;
begin
  Cmd := [];
  if (Num and 1) = 1 then Include(Cmd,fsBold);
  if (Num and 2) = 2 then Include(Cmd,fsItalic);
  if (Num and 4) = 4 then Include(Cmd,fsUnderline);
  if (Num and 8) = 8 then Include(Cmd,fsStrikeout);
  Result := Cmd;
end;

// ==========================================
// Get windows directorys
// ==========================================
(*
function WindowsDir : string;
var Dir : PChar;
    WDir : string;
begin
   GetMem(Dir,MAX_PATH);
   GetWindowsDirectory(Dir,MAX_PATH);
   WDir := string(Dir);
   FreeMem(Dir);
   if WDir[length(WDir)] <> '\' then WDir := WDir + '\';
   Result := WDir;
end;
*)

function WindowsDir : string;
begin
  SetLength(Result,255);
  GetWindowsDirectory(PChar(Result),255);
  SetLength(Result,StrLen(PChar(Result)));
end;


(*
function WindowsSystemDir : string;
var Dir : PChar;
    WDir : string;
begin
   GetMem(Dir,MAX_PATH);
   GetSystemDirectory(Dir,MAX_PATH);
   WDir := string(Dir);
   FreeMem(Dir);
   if WDir[length(WDir)] <> '\' then WDir := WDir + '\';
   Result := WDir;
end;
*)

function WindowsSystemDir : string;
begin
  SetLength(Result,255);
  GetSystemDirectory(PChar(Result),255);
  SetLength(Result,StrLen(PChar(Result)));
end;


function ComputerName : string; platform;
var Count : DWORD;
begin
   Count := MAX_COMPUTERNAME_LENGTH + 1;
   SetLength(Result,Count);
   Win32Check(GetComputerName(PChar(Result),Count));
   Setlength(Result,StrLen(PChar(Result)));
end;


// ================================================
// Load and Save TDBGrid Col settings from a file
// ================================================

procedure LoadGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
var FName : string;
begin
  if DefaultToExePath then
     FName := GetExePath + FileName
  else
     FName := FileName;

  try
    Grid.Columns.LoadFromFile(FileName);
  except end;
end;


procedure SaveGridSettings(FileName : string; Grid : TDBGrid; DefaultToExePath : boolean = true);
var FName : string;
begin
  if DefaultToExePath then
     FName := GetExePath + FileName
  else
     FName := FileName;

  try
    Grid.Columns.SaveToFile(FileName);
  except end;
end;


// ================================================================
// Return the three dates (Created,Modified,Accessed
// of a given filename. Returns FALSE if file cannot
// be found or permissions denied. Results are returned
// in TdateTime OUT parameters
// ================================================================

function GetFileTimes(FileName : string;
                      out Created  : TDateTime;
                      out Modified : TDateTime;
                      out Accessed : TDateTime) : boolean;
var FileHandle : integer;
    Cmd : boolean;
    FTimeC,FTimeA,FTimeM : TFileTime;
    LTime : TFileTime;
    STime : TSystemTime;
begin
  FileHandle := FileOpen(FileName,fmShareDenyNone);
  Created := 0.0;
  Modified := 0.0;
  Accessed := 0.0;

  if FileHandle < 0 then
     Cmd := false
  else begin
     Cmd := true;
     GetFileTime(FileHandle,@FTimeC,@FTimeA,@FTimeM);
     FileClose(FileHandle);

     // Created
     FileTimeToLocalFileTime(FTimeC,LTime);
     if FileTimeToSystemTime(LTime,STime) then begin
       Created := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
       Created := Created + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
     end;

     // Accessed
     FileTimeToLocalFileTime(FTimeA,LTime);
     if FileTimeToSystemTime(LTime,STime) then begin
       Accessed := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
       Accessed := Accessed + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
     end;

     // Modified
     FileTimeToLocalFileTime(FTimeM,LTime);
     if FileTimeToSystemTime(LTime,STime) then begin
       Modified := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
       Modified := Modified + EncodeTime(STime.wHour,STime.wMinute,STime.wSecond,STime.wMilliSeconds);
     end;

  end;

  Result := Cmd;
end;

// =========================================
// Get IP address of current machine
//==========================================

function MyIPAddress : string;
type TaPInAddr = array [0..10] of PInAddr;
     PaPInAddr = ^TaPInAddr;
var  phe : PHostEnt;
     pptr : PaPInAddr;
     Buffer : array [0..63] of char;
     Cmd : string;
     I : integer;
     GInitData : TWSADATA;
begin
    WSAStartup($101, GInitData);
    Cmd := '';
    GetHostName(Buffer, SizeOf(Buffer));
    phe := GetHostByName(buffer);
    if (phe <> nil) then begin
      pptr := PaPInAddr(Phe^.h_addr_list);
      I := 0;
      while pptr^[I] <> nil do begin
         Cmd := StrPas(inet_ntoa(pptr^[I]^));
         inc(I);
      end;
      WSACleanup;
    end;

    Result := Cmd;
end;


// ======================================
// Calculate the CPU speed in mhz
// ======================================

function CPUSpeed : integer;
const DELAYTIME = 500; // measure time in ms
var TimerHi,TimerLo: DWORD;
    PriorityClass,Priority : integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);
  SetPriorityClass(GetCurrentProcess,REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
  Sleep(10);

  asm
    dw 310Fh // rdtsc
    mov TimerLo,eax
    mov TimerHi,edx
  end;

  Sleep(DelayTime);

  asm
    dw 310Fh // rdtsc
    sub eax,TimerLo
    sbb edx,TimerHi
    mov TimerLo,eax
    mov TimerHi,edx
  end;

  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);

  Result := round(TimerLo / (1000.0 * DelayTime));
end;


// =================================================================
// Add/Delete currently running program to the AUTORUN
// section of the registry (W2000 should be OK)
// =================================================================

procedure SetAutoStart(AppTitleKey : string; Status : boolean = true);
const RUNKEY = '\Software\Microsoft\Windows\CurrentVersion\Run';
var WinReg : TRegistry;
begin
  WinReg := TRegistry.Create;
  try
     WinReg.RootKey := HKEY_LOCAL_MACHINE;
     if WinReg.OpenKey(RUNKEY,false) then begin
       case Status of
            false : WinReg.DeleteValue(AppTitleKey);
            true  : WinReg.WriteString(AppTitleKey,ParamStr(0));
        end;
     end;
  finally
     WinReg.Free;
  end;
end;

// ========================================
// Remove the caption bar of a form.
// Normally called in OnCreate event
// ========================================

procedure RemoveFormCaption(Form : TForm);
begin
  SetWindowLong(Form.Handle,GWL_STYLE,
                GetWindowLong(Form.Handle,GWL_STYLE) AND NOT WS_CAPTION);
  Form.ClientHeight := Form.Height;
  Form.Refresh;
end;


// ===========================================
// Hex and Binary functions DELPHI forgot
// ===========================================

{ ===================================== }
{ Convert a HexString value to an Int64 }
{ Note : Last Char can  be 'H' for Hex  }
{        eg. '00123h' or '00123H'       }
{ ===================================== }

function HexToInt(HexStr : string) : Int64;
var Cmd : Int64;
    i : byte;
begin
  HexStr := trim(HexStr);
  if HexStr = '' then HexStr := '0';
  HexStr := UpperCase(HexStr);
  if HexStr[length(HexStr)] = 'H' then Delete(HexStr,length(HexStr),1);
  Cmd := 0;

  for i := 1 to length(HexStr) do begin
      Cmd := Cmd shl 4;
      if HexStr[i] in ['0'..'9'] then
         Cmd := Cmd + (byte(HexStr[i]) - 48)
      else
         if HexStr[i] in ['A'..'F'] then
            Cmd := Cmd + (byte(HexStr[i]) - 55)
         else begin
            Cmd := 0;
            break;
         end;  
  end;

  Result := Cmd;
end;

{ ============================================== }
{ Convert an Int64 value to a binary string      }
{ NumBits can be 64,32,16,8 to indicate the      }
{ return value is to be Int64,DWord,Word         }
{ or Byte respectively  (default = 64)           }
{ NumBits normally are only required for         }
{ negative input values                          }
{ ============================================== }

function IntToBin(IValue : Int64; NumBits : word = 64) : string;
var Cmd : string;
begin
Cmd := '';

case NumBits of
      32 : IValue := dword(IValue);
      16 : IValue := word(IValue);
      8  : IValue := byte(IValue);
end;

while IValue <> 0 do begin
    Cmd := char(48 + (IValue and 1)) + Cmd;
    IValue := IValue shr 1;
end;

if Cmd = '' then Cmd := '0';
Result := Cmd;
end;


{ ============================================== }
{ Convert a bit binary string to an Int64 value  }
{ Note : Last Char can  be 'B' for Binary        }
{        eg. '001011b' or '001011B'              }
{ ============================================== }

function BinToInt(BinStr : string) : Int64;
var i : byte;
    Cmd : Int64;
begin
   BinStr := trim(BinStr);
   if BinStr = '' then BinStr := '0';
   BinStr := UpperCase(BinStr);
   if BinStr[length(BinStr)] = 'B' then Delete(BinStr,length(BinStr),1);
   Cmd := 0;
   for i := 1 to length(BinStr) do begin
     if not (BinStr[i] in ['0','1']) then begin
        Cmd := 0;
        Break;
     end;
     Cmd := (Cmd shl 1) + (byte(BinStr[i]) and 1) ;
   end;

   Result := Cmd;
end;

// =======================================
// Generic integer to base conversions
// =======================================

const B36 : PChar = ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ');

function IntToBase(Value : integer; Base : byte;
                   Digits : byte = 0): string;
var Cmd : string;
begin
  Cmd := '';
  repeat
    Cmd := B36[Value mod Base] + Cmd;
    Value := Value div Base;
  until (Value div Base = 0);

  Cmd := B36[Value mod Base] + Cmd;
  while length(Cmd) < Digits do Cmd := '0' + Cmd;
  Result := Cmd;
end;

function BaseToint(Value : string; Base : byte) : integer;
var i : byte;
    Cmd : integer;
begin
  Cmd := 0;
  for i := 1 to length(Value) do begin
     if (pos(Value[i],B36)-1) < Base then
        Cmd := Cmd * Base + (pos(Value[i], B36)-1)
     else begin
        Cmd := 0;
        break;
     end;
  end;

  Result := Cmd;
end;




// ================================
// Sales functions
// ================================

{ ===================================== }
{ Discount a Value by PercentDiscount%  }
{ 2 Overloaded versions                 }
{ One returns the actual disc amount    }
{ ===================================== }

function Discount(Value : double; PercentDisc : double) : double; overload;
begin
   Result := (Value * (100.0 - PercentDisc)) * 0.01;
end;

function Discount(Value : double; PercentDisc : double;
                  out DiscAmnt : double) : double; overload;
var Cmd : double;
begin
   Cmd := (Value * (100.0 - PercentDisc)) * 0.01;
   DiscAmnt := Value - Cmd;
   Result := Cmd;
end;

{ ===================================== }
{ Markup a Value by PercentMarkup%      }
{ 2 Overloaded versions                 }
{ One returns the actual markup amount  }
{ ===================================== }

function MarkUp(Value : double; PercentMarkup : double) : double; overload;
begin
  Result := Value * (1.0 + (PercentMarkup * 0.01));
end;

function MarkUp(Value : double; PercentMarkup : double;
                out MarkupAmnt : double) : double; overload;
var Cmd : double;
begin
  Cmd := Value * (1.0 + (PercentMarkup * 0.01));
  MarkupAmnt := Value * (PercentMarkup * 0.01);
  Result := Cmd;
end;

{ ==================================== }
{ Returns the GP% of a selling and     }
{ cost price.                          }
{ ==================================== }

function GPpercent(Cost,Sell : double) : double; overload;
var Cmd : double;
begin
  if Sell < 0.0001 then
    Cmd := 0.0
  else
    Cmd := (1.0 - (Cost / Sell)) * 100.0;

  Result := Cmd;
end;

function GPpercent(Cost,Sell : double;
                   out MarkupPercent : double) : double; overload;
var Cmd : double;
begin
  MarkupPercent := 0;

  if Sell < 0.0001 then
    Cmd := 0.0
  else begin
    Cmd := (1.0 - (Cost / Sell)) * 100.0;
    if Cost > 0.0001 then
       MarkUpPercent := ((Sell - Cost) / Cost) * 100.0;
  end;

  Result := Cmd;
end;

// ========================================
// Return X,Y SCREEN coords of a control
// ========================================

procedure GetScreenXY(TargetControl : TControl; out X : integer;
                      out Y : integer);
var P : TPoint;
begin
  P.x := TargetControl.Left;
  P.y := TargetControl.Top;
  P := TargetControl.Parent.ClientToScreen(P);
  X := P.x;
  Y := P.y;
end;

// ===============================================
// Convert a number to an English Sentence
// ===============================================

function NumToLetters(Number : extended; Currency : string = 'Rands';
                      Cents : string = 'Cents') : string;
const MaxAmt = 4294967295.99;
      NumArr : array [1..19] of string[9] =
                     ('One','Two','Three','Four','Five','Six','Seven',
                      'Eight','Nine','Ten','Eleven','Twelve',
                      'Thirteen','Fourteen','Fifteen','Sixteen',
                      'Seventeen','Eighteen','Nineteen');
      TenArr : array [1..9] of string[7] =
                     ('Ten','Twenty','Thirty','Forty','Fifty',
                      'Sixty','Seventy','Eighty','Ninety');
var Cmd : string;
    Decimals : extended;

    function RecurseNumber(N : longword) : string;
    begin
      case N of
           1..19                  : Result := NumArr[N];
           20..99                 : Result := TenArr[N div 10] +
                                    ' ' + RecurseNumber(N mod 10);
           100..999               : Result := NumArr[N div 100] +
                                    ' Hundred ' +
                                    RecurseNumber(N mod 100);
           1000..999999           : Result := RecurseNumber(N div 1000) +
                                    ' Thousand ' +
                                    RecurseNumber(N mod 1000);
           1000000..999999999     : Result := RecurseNumber(N div 1000000) +
                                    ' Million ' +
                                    RecurseNumber(N mod 1000000);
           1000000000..4294967295 : Result := RecurseNumber(N div 1000000000) +
                                    ' Billion ' +
                                    RecurseNumber(N mod 1000000000);
      end;
    end;

begin
  Cmd := '';

  if (Number < 0.00) or (Number > MaxAmt) then
      MessageDlg('NumToLetters() - Number out of range',mtError,[mbOk],0)
  else begin
      Decimals := Frac(Number) * 100.9;

      if (Number >= 1.00) then begin
        Cmd := RecurseNumber(Round(Int(Number))) + ' ' + Currency;
        Cmd := Cmd + ' + ' + FormatFloat('00',Decimals)  + ' ' + Cents;
      end
      else
        if Decimals > 0.00 then
           Cmd := RecurseNumber(Round(Decimals))  + ' ' + Cents
        else
           Cmd := 'Zero ' + Currency + ' Zero ' + Cents;
  end;

  Result := Cmd;
end;


// =============================================
// Return a set describing char attributes
// =============================================

function CharTypeSet(Ch : char) : TCharTypesSet;
const
  CHARS_ALPHA        = ['a'..'z','A'..'Z'];
  CHARS_UPPER        = ['A'..'Z'];
  CHARS_LOWER        = ['a'..'z'];
  CHARS_DIGIT        = ['0'..'9'];
  CHARS_HEX          = ['0'..'9','A'..'F','a'..'f'];
  CHARS_WHITE        = [#9..#13,' '];
  CHARS_PUNCT        = ['!','"','''','(',')',',','.',';',':','?','[',']'];
  CHARS_SIGN         = ['+','-'];
  CHARS_ANSI         = [#0..#127];
  CHARS_CONTROL      = [#0..#31];
  CHARS_OPERATOR     = ['+','-','*','/','^'];
var Cmd : TCharTypesSet;
begin
   Cmd := [];
   if Ch in CHARS_ALPHA then Include(Cmd,chAlpha);
   if Ch in CHARS_DIGIT then Include(Cmd,chDigit);
   if Ch in CHARS_HEX then Include(Cmd,chHex);
   if Ch in CHARS_UPPER then Include(Cmd,chUpper);
   if Ch in CHARS_LOWER then Include(Cmd,chLower);
   if Ch in CHARS_WHITE then Include(Cmd,chWhitespace);
   if Ch in CHARS_PUNCT then Include(Cmd,chPunctuation);
   if Ch in CHARS_SIGN then Include(Cmd,chSign);
   if Ch in CHARS_ANSI then Include(Cmd,chAnsi);
   if Ch in CHARS_CONTROL then Include(Cmd,chControl);
   if Ch in CHARS_OPERATOR then Include(Cmd,chOperator);

   Result := Cmd;
end;

// =============================================================================
// One line if .. then .. else statements
// like Clipper iif()
// =============================================================================

function iif(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: char): char; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: integer): integer; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: cardinal): cardinal; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: extended): extended; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: boolean): boolean; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: pointer): pointer; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function iif(const Condition: Boolean; const TruePart, FalsePart: int64): int64; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

// =========================================================
// Return Handle to Desktop ListView
// eg. SendMessage(DeskTopLVhandle,LVM_ALIGN,LVA_ALIGNLEFT)
// =========================================================

function DeskTopLVhandle : THandle;
var S : string;
    LVH : THandle;
begin
  LVH := FindWindow('ProgMan',nil);
  LVH := GetWindow(LVH,GW_CHILD);
  LVH := GetWindow(LVH,GW_CHILD);
  SetLength(S,40);
  GetClassName(LVH,PChar(S),39);
  if PChar(S) <> 'SysListView32' then LVH := 0;
  Result := LVH;
end;

// ===========================================
// Load a stringlist with all window titles
// ===========================================

var XTS : TStrings;

procedure GetWindowsList(TS : TStrings);

    function EnumWindowsCode(Wnd : hWnd; Form : TForm) : Boolean; Export; StdCall;
    var Buffer : array[0..99] of char;
    begin
      GetWindowText(Wnd,Buffer,100);
      if StrLen(Buffer) <> 0 then XTS.Add(StrPas(Buffer));
      Result := true;
    end;

begin
  TS.Clear;
  XTS := TS;
  EnumWindows(@EnumWindowsCode,0);
end;


// ================================
// JAVA like toString functions
// ================================

function toString(Value : Variant): string;
begin
  case TVarData(Value).VType of
    varSmallInt,
    varInteger   : Result := IntToStr(Value);
    varSingle,
    varDouble,
    varCurrency  : Result := FloatToStr(Value);
    varDate      : Result := FormatDateTime('dd/mm/yyyy', Value);
    varBoolean   : if Value then Result := 'T' else Result := 'F';
    varString    : Result := Value;
  else
    Result := '';
  end;
end;

// =============================================================================
// PosEx - Same as standard Pos function, except that you also
// can specify the start position, and ignore the case.
// =============================================================================

function PosEx(const SubStr,TargetS : string;
               StartPos : integer = 1;
               IgnoreCase : boolean = false) : integer;
var Cmd : integer;
begin
  if StartPos < 1 then StartPos := 1;
  if StartPos = 1 then begin
    if IgnoreCase then
       Cmd := Pos(UpperCase(SubStr),UpperCase(TargetS))
    else
       Cmd := Pos(SubStr,TargetS);
  end
  else begin
    if IgnoreCase then
       Cmd := Pos(UpperCase(SubStr),UpperCase(Copy(TargetS,StartPos,Length(TargetS))))
    else
       Cmd := Pos(SubStr,Copy(TargetS,StartPos,Length(TargetS)));

    if Cmd > 0 then Cmd := Cmd + StartPos - 1;
  end;

  Result := Cmd;
end;

// =============================================================================
// PosCount - Same as standard Pos function, except that you also
// can specify the index occurance of the string;
// =============================================================================

function PosCount(const SubStr,TargetS : string; CountIndex : integer = 1) : integer;
var i,Cmd,P : integer;
begin
  if CountIndex < 1 then CountIndex := 1;
  Cmd := 0;
  for i := 1 to CountIndex do begin
     P := pos(SubStr,copy(TargetS,Cmd + 1,MAX_PATH));
     if (P = 0) then begin
       Cmd := 0;
       break;
     end
     else
       Cmd := Cmd + P;
  end;

  Result := Cmd;
end;


// ==========================================================
// Misc String functions
// ==========================================================

function IsNullStr(const StrVar : string) : boolean;
begin
  Result := length(StrVar) = 0;
end;

function LastChar(StrVar : string) : char;
var Cmd : char;
begin
  Cmd := #0;
  if length(StrVar) > 0 then Cmd := StrVar[length(StrVar)];
  Result := Cmd;
end;

procedure SetLastChar(var StrVar : string; CharValue : char);
begin
  if length(StrVar) > 0 then StrVar[length(StrVar)] := CharValue;
end;


procedure SortStr(var StrVar : string);
var S : string;

   procedure QuickSort(L, R: integer);
   var I,J : integer;
       c : char;
   begin
     repeat
       I := L;
       J := R;
       c := S[(L + R) shr 1];
       repeat
         while S[I] < c do inc(I);
         while S[J] > c do dec(J);
         if I <= J then begin
           SwapMem(S[I],S[J],1);
           inc(I);
           dec(J);
         end;
       until I > J;
       if L < J then QuickSort(L,J);
       L := I;
     until I >= R;
   end;

begin
  S := StrVar;
  if length(StrVar) > 1 then begin
     QuickSort(1,length(StrVar));
     StrVar := S;
  end;
end;

procedure ReplaceChars(var StrVar : string; ThisChar,WithChar : char;
                       IgnoreCase : boolean = false);
var i : integer;
begin
   for i := 1 to length(StrVar) do begin
       if IgnoreCase then begin
          if UpCase(StrVar[i]) = UpCase(ThisChar) then StrVar[i] := WithChar;
       end  
       else
          if StrVar[i] = ThisChar then StrVar[i] := WithChar;
    end;
end;


procedure VarToStr(var Source; Count : integer; out StrVar : string;
                  ReplaceChar0With : char = #0);
var Cmd : string;
    i : integer;
begin
  SetLength(Cmd,Count);
  FillChar(Cmd,0,SizeOf(Cmd));
  move(Source,Cmd[1],Count);
  for i := 1 to Count do if Cmd[i] = #0 then
      Cmd[i] := ReplaceChar0With;
  StrVar := Cmd;
end;


procedure StrToVar(const StrVar : string; out UtypedVar);
begin
  try move(StrVar[1],UTypedVar,length(StrVar)); except end;
end;


function StartsWith(const SourceStr,TargetStr : string;
                    IgnoreCase : boolean = false) : boolean;
begin
  if not IgnoreCase then
    Result := (copy(TargetStr,1,length(SourceStr)) = SourceStr)
  else
    Result := (copy(UpperCase(TargetStr),1,length(SourceStr)) = UpperCase(SourceStr));
end;


function EndsWith(const SourceStr,TargetStr : string;
                  IgnoreCase : boolean = false) : boolean;
begin
  if not IgnoreCase then
    Result := (copy(TargetStr,length(TargetStr) - length(SourceStr) + 1,MAXINT) = SourceStr)
  else
    Result := (copy(UpperCase(TargetStr),length(TargetStr) - length(SourceStr) + 1,MAXINT) = UpperCase(SourceStr));
end;


// ==========================================
// Inc and Dec value with limit rollover
// ==========================================

procedure IncLimit(var X : longint; Limit : longint;
                   RollOverVal : longint = 0; IncBy : longint = 1);
var XVal : longint;
begin
  XVal := X;
  if XVal = Limit then
     XVal := RollOverVal
  else
    inc(XVal,IncBy);

  X := XVal;
end;


procedure DecLimit(var X : longint; Limit : longint;
                   RollUnderVal : longint = 0; DecBy : longint = -1);
var XVal : longint;
begin
  XVal := X;
  if XVal = Limit then
     XVal := RollUnderVal
  else
    dec(XVal,DecBy);

  X := XVal;
end;

// ==================================================
// Populate a string grid from an open query
// ==================================================

procedure QueryToStrGrid(Query : TQuery; StrGrid : TStringGrid; Titles : boolean = true);
var mCol,mLin,FntWidth : integer;
begin
   FntWidth := StrGrid.Font.Size;
   Query.First;

   if not Query.Eof then begin
      StrGrid.ColCount := Query.FieldCount;
      StrGrid.RowCount := Query.RecordCount + iif(Titles,1,0);
      StrGrid.FixedCols := 0;
      StrGrid.FixedRows := iif(Titles,1,0);
      if Titles then for mCol := 0 To Query.FieldCount - 1 do
         StrGrid.Cells[mCol,0] := Query.Fields[mCol].FieldName;
      mLin := 0;
      while not Query.Eof do begin
        for mCol := 0 To Query.FieldCount - 1 do begin
           StrGrid.Cells[mCol,mLin + StrGrid.FixedRows] :=
                   Query.Fields[mCol].AsString;
           StrGrid.ColWidths[mCol] := Query.Fields[mCol].DisplayWidth * FntWidth;
        end;
        Query.Next;
        inc(mLin);
      end;
   end;
end;

// =============================================
// Copy String Grid to RTF Word Doc
// =============================================

procedure WriteToStream(var Stream : TStream; s : string);
begin
   Stream.Write(PChar(s)^,Length(s));
end;

function Text2Rtf(s : string) : string;
var s2 : string;
    i : integer;
begin
  s2 := '';
  i := 1;

  while i <= length(s) do begin
    case byte(s[i]) of
       92       : s2 := s2 + '\\';
       123      : s2 := s2 + '\{';
       125      : s2 := s2 + '\}';
       128..255 : s2 := s2 + '\''' + IntToHex(byte(s[i]),2);
    else s2 := s2 +s [i];
    end;//

    inc(i);
  end;

  Result := s2;
end;

procedure StrGridToRTF(const Filename : string; SG : TStringGrid);
var St : TStream;
    f,r,CellWidth,CellPos : integer;
begin
  St := TFileStream.Create(Filename,fmCreate);
  try
    //RTF header
    WriteToStream(St,'{\rtf1\ansi\deff0\deflang1033');
    WriteToStream(St,'{\fonttbl{\f0\fnil\fcharset1{\*\fname Arial;}Arial;}}');
    WriteToStream(St,'\viewscale100\uc1\pard\f0\fs20\par');
    CellWidth := 2988;

    //Writing Grid Data
    for r := 0 to SG.RowCount-1 do begin
      WriteToStream(St,'{\trowd\trgaph70\trleft0\trrh230');
      CellPos := CellWidth;

      for f := 0 to SG.ColCount-1 do begin
        WriteToStream(St,'\clvertalt\clbrdrt\brdrs\brdrw10');
        WriteToStream(St,'\clbrdrl\brdrs\brdrw10');
        WriteToStream(St,'\clbrdrb\brdrs\brdrw10');
        WriteToStream(St,'\clbrdrr\brdrs\brdrw10');
        WriteToStream(St,'\cellx'+inttostr(cellpos));
        CellPos := CellPos + CellWidth;
      end;

      for f := 0 to SG.ColCount-1 do
        WriteToStream(St,'\pard\plain\fs20\intbl ' + Text2Rtf(SG.Cells[f,r])+'\cell ');

      WriteToStream(St,'\row }');
    end;

    //End of RTF file
    WriteToStream(St,'\par }');
  finally
    if Assigned(St) then St.Free;
  end;
end;

procedure StrGridToHTML(const FileName : string; StrGrid : TStringGrid;
                        const Heading : string = '';
                        TextColor : TColor = clBlack;
                        TableBgColor : TColor = clAqua);
var Txt : TextFile;
    i,ii : integer;
    BgColor,TxColor : string;
begin
  // Convert TColor to HTML Hex Color
  BgColor := IntToHex(GetRValue(TableBgColor),2) +
             IntToHex(GetGValue(TableBgColor),2) +
             IntToHex(GetBValue(TableBgColor),2);

  TxColor := IntToHex(GetRValue(TextColor),2) +
             IntToHex(GetGValue(TextColor),2) +
             IntToHex(GetBValue(TextColor),2);

  // Create output file
  AssignFile(Txt,FileName);
  Rewrite(Txt);

  // HTML Header Info
  WriteLn(Txt,'<HTML>');
  WriteLn(Txt,'<HEAD>');
  WriteLn(Txt,'<TITLE>' + ExtractFileName(FileName) + '</TITLE>');
  WriteLn(Txt,'</HEAD>');
  WriteLn(Txt);
  WriteLn(Txt,'<BODY TEXT=#' + TxColor + ' BGCOLOR=#CCCCCC>');
  WriteLn(Txt,'<H1>' + Heading + '</H1>');
  WriteLn(Txt,'<TABLE WIDTH=100% CELLPADDING=2 CELLSPACING=2 ' +
              'BGCOLOR=#' + BgColor + ' BORDER=1>');

  // Column Descriptions
  WriteLn(Txt,'    <TR>');
  for i := 0 to StrGrid.ColCount - 1 do
     WriteLn(Txt,'        <TH>' + StrGrid.Cells[i,0] + '</TH>');
  WriteLn(Txt,'    </TR>');

  // Write out the Grid Data
  for i := 1 to StrGrid.RowCount - 1 do begin
    WriteLn(Txt,'    <TR>');
    for ii := 0 to StrGrid.ColCount - 1 do
        WriteLn(Txt,'    <TD>' + StrGrid.Cells[ii,i] + '</TD>');
    WriteLn(Txt,'    </TR>');
  end;

  // Footer
  WriteLn(Txt,'</TABLE>');
  WriteLn(Txt,'<P>');
  WriteLn(Txt,'<H3>' + IntToStr(StrGrid.ColCount) + ' Rows</H3>');
  WriteLn(Txt,'</BODY>');
  WriteLn(Txt,'</HTML>');

  CloseFile(Txt);
end;



// ============================================
// Overwrite file with char 0 and delete
// recovery is impossible
// ============================================

procedure ShredFile(const FileName : string);
const BUFFSIZE = $FFFE;
var Fle : file;
    Buffer : pointer;
    FSize : integer;
begin
  GetMem(Buffer,BUFFSIZE);
  FillChar(Buffer^,BUFFSIZE,0);
  AssignFile(Fle,FileName);
  try
    Reset(Fle,1);
    FSize := FileSize(Fle);

    while FSize > 0 do begin
       BlockWrite(Fle,Buffer^,min(FSize,BUFFSIZE));
       dec(FSize,BUFFSIZE);
    end;

    CloseFile(Fle);
    DeleteFile(FileName);
  except end;
  FreeMem(Buffer);
end;

// ============================================================
// Returns -1, or 1 according to the sign of the argument
// Zero returns 1
// ============================================================

function Sign(Value : extended) : integer;
var Cmd : integer;
begin
  if Value < 0.0 then Cmd := -1 else Cmd := 1;
  Result := Cmd;
end;

// =======================================
// Better Rounder ie. 10's,100's etc
// =======================================

function RoundIt(Value : extended; Decimals : integer = 2) : extended;
var Nominator : extended;
begin
  Nominator := Power(10,Decimals);
  Result := Round(Value * Nominator) / Nominator;
end;

// ========================================================================
// This will copy a Paradox or dBase table from one directory to another.
// Note that this does not use BDE aliases. It would be possible to do that
// by declaring parameters for the source and destination databases,
// respectively.
// ========================================================================

function CopyPdxTable(SrcTable,DstTable : string; out ErrMess : string;
                      Overwrite : boolean = true) : boolean;
var DB : TDatabase;
    STbl,DTbl : string;
    Cmd : boolean;
begin
  Cmd := false;
  ErrMess := '';
  if (ExtractFilePath(SrcTable) = '') then
    STbl := ExtractFilePath(Application.EXEName) + SrcTable
  else
    STbl := SrcTable;

  if (ExtractFilePath(DstTable) = '') then
    DTbl := ExtractFilePath(Application.EXEName) + DstTable
  else
    DTbl := DstTable;

  if FileExists(STbl) then begin
      DB := TDatabase.Create(nil);
      with DB do begin
        Connected := False;
        DatabaseName := ExtractFilePath(SrcTable);
        DriverName := 'STANDARD';
        Connected := True;
      end;

      try
        Check(DBICopyTable(DB.Handle,Overwrite,PChar(STbl),nil,PChar(DTbl)));
        Cmd := true;
      except
        on E: Exception do ErrMess := 'CopyPdxTable() - ' + E.Message;
      end;

      DB.Free;
  end
  else
    ErrMess := 'CopyPdxTable() - Table does not Exist.';

  Result := Cmd;
end;

// ===================================================
// Get INTEL chip features using CPUID call
// ===================================================

function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;
const
    FPU_FLAG    = $0001;
    VME_FLAG    = $0002;
    DE_FLAG     = $0004;
    PSE_FLAG    = $0008;
    TSC_FLAG    = $0010;
    MSR_FLAG    = $0020;
    PAE_FLAG    = $0040;
    MCE_FLAG    = $0080;
    CX8_FLAG    = $0100;
    APIC_FLAG   = $0200;
    SEP_FLAG    = $0800;
    MTRR_FLAG   = $1000;
    PGE_FLAG    = $2000;
    MCA_FLAG    = $4000;
    CMOV_FLAG   = $8000;
    PAT_FLAG    = $10000;
    PSE36_FLAG  = $20000;
    PSNUM_FLAG  = $40000;
    MMX_FLAG    = $800000;
    FXSR_FLAG   = $1000000;
    SIMD_FLAG   = $2000000;

var IsIntel : boolean;
    VendorID : array [0..12] of char;
    IntelID  : array [0..12] of char;
    FeaturesFlag,CpuSignature : DWord;
    Temp : DWord;
    Cmd : TCpuFeatures;
    CpuType : byte;

    // Local routine to add to List and Return SET
    procedure CheckFeature(FeatureFlag : DWord;
                           const Item : string;
                           cpuFeatureType : TCpuFeature);
    begin
      if FeaturesFlag and FeatureFlag = FeatureFlag then begin
        if FeatureList <> nil then FeatureList.Add(Item);
        include(Cmd,cpuFeatureType);
      end;
    end;

begin
  Cmd := [];
  if FeatureList <> nil then FeatureList.Clear;
  IsIntel := false;
  IntelId  := 'GenuineIntel'#0;
  VendorID := '------------'#0;

  try
     asm
         // Determine Intel CPUID support.
         push ebx
         push esi
         push edi
         mov  eax,0                     // Set up for CPUID instruction
         db 00fh                        // CPUID - Get Vendor and check INTEL
         db 0a2h
         mov dword ptr VendorId,ebx
         mov dword ptr VendorId[+4],edx
         mov dword ptr VendorId[+8],ecx
         cmp dword ptr IntelId,ebx      // Check if it is INTEL
         jne @@EndCPUID
         cmp dword ptr IntelId[+4],edx
         jne @@EndCPUID
         cmp dword ptr IntelId[+8],ecx
         jne @@EndCPUID                 // Not an Intel processor

         mov byte ptr IsIntel,1         // Set IsIntel to true
         cmp eax,1                      // Ensure 1 is valid input for CPUID
         jl  @@EndCPUID                 // Else jump to end

         mov eax,1
         db 00fh                        // CPUID -  Get features,family.model etc.
         db 0a2h
         mov CpuSignature,eax
         mov FeaturesFlag,edx
         shr eax,8                      // Isolate family
         and eax,0fh
         mov byte ptr CpuType,al        // Set cputype with family

       @@EndCPUID :

         pop edi                        // Restore registers
         pop esi
         pop ebx
     end;

     // Check Features Mask if Intel
     if IsIntel then begin
        if FeatureList <> nil then begin
           FeatureList.Add('CPU Family ' + IntToStr(CpuType));
           Temp := (CpuSignature shr 4) and $0f;
           FeatureList.Add('CPU Model ' + IntToStr(Temp));
           Temp := CpuSignature and $0f;
           FeatureList.Add('CPU Stepping ' + IntToStr(Temp));
        end;

        CheckFeature(FPU_FLAG,'On-Chip FPU',cpuOnChipFPU);
        CheckFeature(VME_FLAG,'VirtualMode Extensions',cpuVirtualModeExtensions);
        CheckFeature(DE_FLAG,'Debugging Extensions',cpuDebuggingExtensions);
        CheckFeature(PSE_FLAG,'Page Size Extensions',cpuPageSizeExtensions);
        CheckFeature(TSC_FLAG,'Time Stamp Counter',cpuTimeStampCounter);
        CheckFeature(MSR_FLAG,'Model Specific Registers',cpuModelSpecificRegisters);
        CheckFeature(PAE_FLAG,'Physical Address Extensions',cpuPhysicalAddressExtensions);
        CheckFeature(MCE_FLAG,'Machine Check Extensions',cpuMachineCheckExtensions);
        CheckFeature(CX8_FLAG,'CMPXCHG8B Instruction',cpuCMPXCHG8B);
        CheckFeature(APIC_FLAG,'On Chip APIC',cpuOnChipAPIC);
        CheckFeature(SEP_FLAG,'Fast System Call',cpuFastSystemCall);
        CheckFeature(MTRR_FLAG,'Memory Type Range Registers',cpuMemoryRangeRegisters);
        CheckFeature(PGE_FLAG,'Page Global Enable',cpuPageGlobalEnable);
        CheckFeature(MCA_FLAG,'Machine Check Architecture',cpuMachineCheckArchitecture);
        CheckFeature(CMOV_FLAG,'Conditional Move Instruction',cpuConditionalMoveInstruction);
        CheckFeature(PAT_FLAG,'Page Attribute Table',cpuPageAttributeTable);
        CheckFeature(PSE36_FLAG,'32 Bit Page Size Extension',cpu32BitPageSzExtension);
        CheckFeature(PSNUM_FLAG,'Processor Serial Number',cpuProcessorSerialNum);
        CheckFeature(MMX_FLAG,'Intel MMX Technology',cpuMMXTechnology);
        CheckFeature(FXSR_FLAG,'Fast Floating Point Save and Restore',cpuFastFloatingPoint);
        CheckFeature(SIMD_FLAG,'Streaming SIMD Extensions',cpuSIMDExtensions);
     end
     else begin
       if FeatureList <> nil then FeatureList.Add('Non-Intel or >486 Chip - Features Unknown');
       include(Cmd,cpuNonIntel);
     end;
  except
    if FeatureList <> nil then FeatureList.Add('No CPUID Support');
    include(Cmd,cpuNoCPUID);
  end;

  Result := Cmd;
end;

// =======================================
// Get serial num - 486 non-Intel ?????
// =======================================

function GetCpuSerialNum : string;
var dw1,dw2,dw3 : DWORD;
begin

  asm
      push ebx
      push esi
      push edi
      xor eax,eax
      db 00fh     // CPUID
      db 0a2h
      mov eax,1
      db 00fh     // CPUID
      db 0a2h
      mov dw3,eax
      mov eax,3
      db 00fh     // CPUID
      db 0a2h
      mov dw2,edx
      mov dw1,ecx
      pop edi
      pop esi
      pop ebx
  end;

  Result := IntToHex(HiWord(dw3),4) + '-' +
            IntToHex(LoWord(dw3),4) + '-' +
            IntToHex(HiWord(dw2),4) + '-' +
            IntToHex(LoWord(dw2),4) + '-' +
            IntToHex(HiWord(dw1),4) + '-' +
            IntToHex(LoWord(dw1),4);
end;


// ==============================================
// Get a list of computer names on network
// and return in string list
// ==============================================

procedure NetDomainList(StringList : TStrings);
const MAXENTRIES = 200;

type TBuffer = array [1..MAXENTRIES] of TNetResource;
     PTBuffer = ^TBuffer;

var EHandle1,EHandle2 : THandle;
    MaxItems1,MaxItems2,
    BufLen : longword;
    Buffer1,Buffer2 : PTBuffer;
    Network : TNetResource;
    i,ii : longword;
    Loop1,Loop2 : longword;
begin
  StringList.Clear;
  GetMem(Buffer1,SizeOf(TBuffer));
  GetMem(Buffer2,SizeOf(TBuffer));
  FillChar(Network,SizeOf(Network),0);
  Network.dwScope := RESOURCE_GLOBALNET;
  Network.dwType := RESOURCETYPE_DISK;
  Network.dwUsage := 0;

  if WNetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,0,
                  @Network,EHandle1) = NO_ERROR then begin
     repeat
        MaxItems1 := MAXENTRIES;
        BufLen := SizeOf(TBuffer);
        Loop1 := WNetEnumResource(EHandle1,MaxItems1,Buffer1,BufLen);

        if Loop1 = NO_ERROR then begin
           // Process array of TNetResource
           for i := 1 to MaxItems1 do begin
              if WNetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,0,
                              @Buffer1^[i],EHandle2) = NO_ERROR then begin
                 repeat
                    MaxItems2 := MAXENTRIES;
                    BufLen := SizeOf(TBuffer);
                    Loop2 := WNetEnumResource(EHandle2,MaxItems2,Buffer2,BufLen);
                    if Loop2 = NO_ERROR then
                        for ii := 1 to MaxItems2 do StringList.Add(Buffer2^[ii].lpRemoteName);
                 until Loop2 = ERROR_NO_MORE_ITEMS;
                 WNetCloseEnum(EHandle2);
              end;
           end;
       end;
     until Loop1 = ERROR_NO_MORE_ITEMS;

     FreeMem(Buffer1);
     FreeMem(Buffer2);
     WNetCloseEnum(EHandle1);
  end;
end;


function GetParamVal(const TaggedParm : string;
                     IgnoreCase : boolean = true) : string;
var Cmd : string;
    i,Len : integer;
    Comp1,Comp2 : string;
begin
  Cmd := '';
  Comp1 := TaggedParm + '=';
  if IgnoreCase then Comp1 := UpperCase(Comp1);
  Len := length(Comp1);

  for i := 1 to ParamCount do begin
      Comp2 := copy(ParamStr(i),1,Len);
      if IgnoreCase then Comp2 := UpperCase(Comp2);
      if (Comp1 = Comp2) then begin
         Cmd := trim(copy(ParamStr(i),Len + 1,length(ParamStr(i))));
         break;
      end;
  end;

  Result := UpperCase(Cmd);
end;


// ================================
// Return computer mac address
// ================================

function GetMACAddress: string;
var AdapterList : TLanaEnum;
    NCB : TNCB;

    function GetAdapterInfo(Lana : Char): String;
    var Adapter : TAdapterStatus;
        Cmd : string;
    begin
      FillChar(NCB,SizeOf(NCB),0);
      NCB.ncb_command := Char(NCBRESET);
      NCB.ncb_lana_num := Lana;

      if Netbios(@NCB) <> Char(NRC_GOODRET) then
          Cmd := 'mac not found'
      else begin
          FillChar(NCB,SizeOf(NCB),0);
          NCB.ncb_command := Char(NCBASTAT);
          NCB.ncb_lana_num := Lana;

          NCB.ncb_callname := '*';
          FillChar(Adapter,SizeOf(Adapter),0);
          NCB.ncb_buffer := @Adapter;
          NCB.ncb_length := SizeOf(Adapter);

          NetBios(@NCB);
          // Win 98 fails even tho card is there
          // if Netbios(@NCB) <> Char(NRC_GOODRET) then begin
          //   Result := 'mac not found';
          //   Exit;
          //  end;

          Cmd := IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
                    IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
                    IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
                    IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
                    IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
                    IntToHex(Byte(Adapter.adapter_address[5]), 2);
      end;

      Result := Cmd;
    end;


begin
  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBENUM);
  NCB.ncb_buffer := @AdapterList;
  NCB.ncb_length := SizeOf(AdapterList);
  Netbios(@NCB);
  if Byte(AdapterList.length) > 0 then
    Result := GetAdapterInfo(AdapterList.lana[0])
  else
    Result := 'mac not found';
end;

// =====================================================
// Allow for multi-line captions in win controls
// Call first and the set caption programatically
// =====================================================

procedure AllowMultiline(theControl : TWinControl);
var dwStyle : longint;
begin
  dwStyle := GetWindowLong(theControl.handle, GWL_STYLE) or BS_MULTILINE;
  SetWindowLong(theControl.Handle, GWL_STYLE, dwStyle);
end;


// ======================================================
// Get windows error as a text message
// Option show error dialog
// Option error number - default = 0 (GetLastError)
// ======================================================

function GetLastWinErr(ShowDialog : boolean = true;
                       ErrNum : integer = 0) : string;
var Cmd : string;
    Err : integer;
begin
  if ErrNum <> 0 then
     Err := ErrNum
  else
     Err := GetLastError;

  Cmd := SysErrorMessage(Err);
  if ShowDialog then
     MessageDlg('Windows Error ' + IntToStr(Err) + #13#10 + Cmd,
                mtError,[mbOk],0);
  Result := Cmd;
end;

// ================================================================
// Map network drive eg. NetMapDrive('G','\\pgbbxb1\col1\data');
// returns NO_ERROR or win error number . use GetLastWinErr
// ================================================================

function NetMapDrive(LocalDrive : char; const RemoteDrivePath : string;
                     UserName : string = ''; Password : string = '') : dword;
var NetResource : TNetResource;
    LocalD : string;
    PcUserName,PcPassword : PChar;
begin
  PcUserName := nil;
  PcPassword := nil;
  LocalD := LocalDrive + ':';
  NetResource.dwType       := RESOURCETYPE_DISK;
  NetResource.lpLocalName  := PChar(LocalD);
  NetResource.lpRemoteName := PChar(RemoteDrivepath);
  NetResource.lpProvider   := '';
  if UserName <> '' then PcUserName := PChar(UserName);
  if Password <> '' then PcPassword := PChar(Password);
  Result := WNetAddConnection2(NetResource,PcPassword,PcUserName,CONNECT_UPDATE_PROFILE);
end;

function NetUnMapDrive(LocalDrive : char) : dword;
var LocalD : string;
begin
  LocalD := UpCase(LocalDrive) + ':';
  Result := WNetCancelConnection2(PChar(LocalD),CONNECT_UPDATE_PROFILE,true);
end;

// ==============================
// Null string = NOT MAPPED
// ==============================

function NetMappedName(LocalDrive : char) : string;
var BuffLen : DWORD;
    LocalID : string;
begin
  Result := ' ';
  LocalID := LocalDrive + ':';
  BuffLen := MAX_PATH;
  SetLength(Result,BuffLen);
  WNetGetConnection(PChar(LocalID),PChar(Result),BuffLen);
  SetLength(Result,StrLen(PChar(Result)));
  Result := trim(Result);
end;

// ==================================
// Exclude A and B drives
// '' = No Maps Available
// ==================================

function NetFindNextUnmapped : char;
var i : integer;
    Drive : char;
    DrivePath : string;
begin
  Drive := #0;

  for i := 3 to 26 do begin
    DrivePath := char(i + 64) + ':';
    if GetDriveType(PChar(DrivePath)) = 1 then begin
      Drive := char(i + 64);
      NetUnMapDrive(Drive);
      break;
    end;
  end;

  Result := Drive;
end;


// ===================================
// Get windows os/type
// ===================================

function GetOSName : string;
var osVerInfo : TOSVersionInfo;
    majorVer, minorVer : integer;
    OsCode : integer;
begin
  OsVerInfo.dwOsVersionInfoSize := SizeOf(TOsVersionInfo);
  if GetVersionEx(OsVerInfo) then begin
        majorVer := OsVerInfo.dwMajorVersion;
        minorVer := OsVerInfo.dwMinorVersion;

        case (OsVerInfo.dwPlatformId) of
            VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
                begin
                   if (majorVer <= 4)  then
                      OsCode := cOsWinNT
                   else
                      if ((majorVer = 5)  and (minorVer= 0)) then
                         OsCode := cOsWin2000
                      else
                         if ((majorVer = 5) and (minorVer = 1)) then
                             OsCode := cOsWhistler
                         else
                             OsCode := cOsUnknown;
                end;

            VER_PLATFORM_WIN32_WINDOWS :  { Windows 9x/ME }
                begin
                    if ((majorVer = 4) and (minorVer = 0)) then
                        OsCode := cOsWin95
                    else if ((majorVer = 4) and (minorVer = 10)) then begin
                       if (OsVerInfo.szCSDVersion[ 1 ] = 'A') then
                           OsCode := cOsWin98SE
                       else
                           OsCode := cOsWin98;
                    end else if (( majorVer = 4) and (minorVer = 90)) then
                       OsCode := cOsWinME
                    else
                       OsCode := cOsUnknown;
                end;
        else
            OsCode := cOsUnknown;
        end;
    end else
        OsCode := cOsUnknown;


    if (OSCode = cOsUnknown) then
        Result := '(Unkown O/S)'
    else if (OSCode = cOsWin95)  then
        Result := 'Windows 95'
    else if (OSCode = cOsWin98) then
        Result := 'Windows 98'
    else if (OSCode = cOsWin98SE) then
        Result := 'Windows 98 2nd Edition'
    else if ( OSCode = cOsWinME ) then
        Result := 'Windows Millennium'
    else if ( OSCode = cOsWinNT ) then
        Result := 'Windows NT'
    else if ( OSCode = cOsWin2000 ) Then
        Result := 'Windows 2000 / NT 5'
    else
        Result := 'Microsoft Windows';
end;


// ===============================================
// Screen shot routines BMP and JPEG support
// ===============================================

procedure ScreenShotPrim(x : integer; y : integer;
                         Width : integer; Height : integer;
                         BMap : TBitMap);
var dc : HDC;
    lpPal : PLOGPALETTE;
begin
   if ((Width = 0) or (Height = 0)) then exit;
   dc := GetDc(0);
   if (dc = 0) then exit;

   // do we have a palette device?
   if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then begin
      GetMem(lpPal,SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
      FillChar(lpPal^,SizeOf(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)),#0);
      lpPal^.palVersion := $300;
      lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, lpPal^.palPalEntry);
      if (lpPal^.PalNumEntries <> 0) then BMap.Palette := CreatePalette(lpPal^);
      FreeMem(lpPal,SizeOf(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
   end;

   // copy from the screen to the bitmap
   BitBlt(BMap.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
   ReleaseDc(0,dc);
end;

procedure ScreenShot(X1,X2,Y1,Y2 : integer; BMap : TBitMap); overload;
begin
  BMap.Width := X2 - X1;
  BMap.Height := Y2 - Y1;
  ScreenShotPrim(X1,Y1,BMap.Width,BMap.Height,BMap);
end;

procedure ScreenShot(BMap : TBitMap); overload;
begin
  BMap.Width := Screen.Width;
  BMap.Height := Screen.Height;
  ScreenShotPrim(0,0,BMap.Width,BMap.Height,BMap);
end;

procedure ScreenShot(X1,X2,Y1,Y2 : integer; JMap : TJPEGImage); overload;
var BMap : TBitMap;
begin
  BMap := TBitMap.Create;
  BMap.Width := X2 - X1;
  BMap.Height := Y2 - Y1;
  ScreenShotPrim(X1,Y1,BMap.Width,BMap.Height,BMap);

  JMap.Assign(BMap);
  BMap.Free;
end;

procedure ScreenShot(JMap : TJPEGImage); overload;
var BMap : TBitMap;
begin
  BMap := TBitMap.Create;
  BMap.Width := Screen.Width;
  BMap.Height := Screen.Height;
  ScreenShotPrim(0,0,BMap.Width,BMap.Height,BMap);
  JMap.Assign(BMap);
  BMap.Free;
end;

// =========================
// Justify menu item
// =========================

procedure JustifyMenuItem(Menu : TMainMenu; MenuItem : TMenuItem;
                         Justify : TJustifyMenuMode = jsmRight);
var ItemInfo : TMenuItemInfo;
    Buffer : array[0..80] of char;
begin
  ItemInfo.cbSize := SizeOf(TMenuItemInfo);
  ItemInfo.fMask := MIIM_TYPE;
  ItemInfo.dwTypeData := Buffer;
  ItemInfo.cch := SizeOf(Buffer);
  GetMenuItemInfo(Menu.Handle,MenuItem.Command,false,ItemInfo);

  case Justify of
       jsmRight  : ItemInfo.fType := ItemInfo.fType or MFT_RIGHTJUSTIFY;
       jsmLeft   : ItemInfo.fType := ItemInfo.fType and not MFT_RIGHTJUSTIFY;
       jsmToggle : ItemInfo.fType := ItemInfo.fType xor MFT_RIGHTJUSTIFY;
  end;

  SetMenuItemInfo(Menu.Handle,MenuItem.Command,false,ItemInfo);
  DrawMenuBar(Menu.WindowHandle);
end;

// ==========================================
// Create a tree menu into a TmenuItem
// ==========================================

const FEX = '.DOC.EXE.COM.HLP.INI.INF.TXT.BAT.DLL.SYS.VBX.OCX.VXD.FON.TTF.FOT';

procedure CreateTreeMenus(Path : string; Menu : TMainMenu;
                          Root : TMenuItem; ListImage : TImageList );
type pHIcon = ^HIcon;

var SR        : TSearchRec;
    Result    : integer;
    Item      : TMenuItem;
    SmallIcon : HIcon;
    IconA     : TIcon;
    BitMapA   : TBitMap;
    Indice    : integer;
    IconOk    : boolean;

    procedure GetAssociatedIcon(FileName : TFilename;
                                pLargeIcon, PSmallIcon : pHIcon );
    var IconIndex : word;
        FileExt,FileType : string;
        Reg       : TRegistry;
        p         : integer;
        p1,p2     : PChar;
    begin
      IconIndex := 0;
      FileExt := UpperCase(ExtractFileExt(FileName));

      if (((FileExt <> '.EXE' ) and (FileExt <> '.ICO')) or
          (not(FileExists(FileName)))) then begin
          Reg := NIL;
          try
            Reg := TRegistry.Create(KEY_QUERY_VALUE);
            Reg.RootKey := HKEY_CLASSES_ROOT;
            if (FileExt = '.EXE') then FileExt := '.COM';
            if (Reg.OpenKeyReadOnly(FileExt)) then
                try FileType := Reg.ReadString('');
                finally Reg.CloseKey; end;

                if ((FileType <> '' ) and
                    Reg.OpenKeyReadOnly(FileType + '\DefaultIcon')) then
                    try FileName := Reg.ReadString('');
                    finally Reg.CloseKey; end;
          finally
             Reg.Free;
          end;

          if (FileName <> '') then begin;
             p1 := PChar(FileName);
             p2 := StrRScan(p1,',');
             if (p2 <> NIL) then begin
                 p := p2 - p1 + 1;
                 IconIndex := StrToInt(copy(FileName,p + 1,Length(FileName) - p ));
                 SetLength(FileName,p - 1);
             end;
             IconOk := (ExtractIconEx(PChar(FileName),IconIndex,PLargeIcon^,PSmallIcon^,1) <> 1);
          end
          else
             IconOk := true;
      end;

      if IconOk then begin
         try FileName := WindowsSystemDir + 'SHELL32.DLL';
         except FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL'; end;

         case pos(FileExt,FEX) of
              1 : IconIndex := 1;
              5,9 : IconIndex := 2;
              13 : IconIndex := 23;
              17,21 : IconIndex := 63;
              25 : IconIndex := 64;
              29 : IconIndex := 65;
              33,37,41,45,49 : IconIndex := 66;
              53 : IconIndex := 67;
              57 : IconIndex := 68;
              61 : IconIndex := 69;
         else
              IconIndex := 0;
         end;

         if ((ExtractIconEx(PChar(FileName),IconIndex,PLargeIcon^,
              PSmallIcon^,1) <> 1 )) then begin
            if (PLargeIcon <> NIL) then PLargeIcon^ := 0;
            if (PSmallIcon <> NIL) then PSmallIcon^ := 0;
         end;
      end;
    end;

begin
  Menu.Images := ListImage;
  if (Path[Length(Path)] <> '\' ) then Path := Path + '\';
  Result := FindFirst(Path + '*.*',faDirectory,SR);

  while (Result = 0)  do begin
     if (((SR.Attr and faDirectory ) <> 0) and (SR.Name <> '.')
        and (SR.Name <> '..')) then begin
        Item := TMenuItem.Create(Menu);
        Item.Caption := SR.Name;
        Item.ImageIndex := 0;
        Root.Add(Item);
        CreateTreeMenus(Path + SR.Name,Menu,Item,ListImage);
      end;

      if (((SR.Attr and faAnyFile) <> 0) and (SR.Name <> '.')
         and (SR.Name <> '..' )) then begin
         Item := TMenuItem.Create(Menu);
         Item.Caption := SR.Name;
         GetAssociatedIcon(sr.Name,NIL,@SmallIcon);
         IconA := TIcon.Create;
         IconA.Handle := SmallIcon;
         BitMapA := TBitMap.Create;
         BitMapA.Width := IconA.Width;
         BitMapA.Height := IconA.Height;
         BitMapA.Canvas.Draw(0,0,IconA );
         BitMapA.TransparentMode := tmAuto;
         Indice := ListImage.Add(BitMapA,NIL);
         Item.ImageIndex := Indice;
         Root.Add(Item);
         IconA.Free;
         BitMapA.Free;
      end;

      Result := FindNext( SR );
  end;

  try FindClose( SR ); except end;
end;

// ================================================
// Bios Information 95/98 and 2000/NT compatible
// ================================================

function BiosDate : string;
var Cmd : string;
    WinReg : TRegistry;
begin
  WinReg := nil;
  Cmd := '????????';

  try
    // Win 9x
    SetString(Cmd,PChar(Ptr($FFFF5)),10);
  except
    // Win 2000/NT
    try
      WinReg := TRegistry.Create;
      WinReg.RootKey := HKEY_LOCAL_MACHINE;
      if WinReg.OpenKeyReadOnly('\HARDWARE\DESCRIPTION\System') then
         Cmd := WinReg.ReadString('SystemBiosDate');
    finally
      WinReg.Free;
    end;
  end;

  Result := Cmd;
end;


function BiosID : string;
var Cmd : string;
    Buffer : PChar;
    WinReg : TRegistry;
begin
  WinReg := nil;
  Cmd := '????????';

  try
    // Win 9x
    SetString(Cmd,PChar(Ptr($F0000)),$2000);
  except
    // Win 2000/NT
    try
      WinReg := TRegistry.Create;
      WinReg.RootKey := HKEY_LOCAL_MACHINE;
      if WinReg.OpenKeyReadOnly('\HARDWARE\DESCRIPTION\System') then begin
         GetMem(Buffer,$2000);
         WinReg.ReadBinaryData('SystemBiosVersion',Buffer^,$2000);
         Cmd := WinReg.ReadString('Identifier') + ' ' + Buffer;
         FreeMem(Buffer);
      end;
    finally
      WinReg.Free;
    end;
  end;
    
  Result := Cmd;
end;

// ==============================
// Bit manipulation routines
// ==============================

const BitValArr : array [0..15] of word = (1,2,4,8,16,32,64,128,256,512,1024,
                                           2048,4096,8192,16384,32768);

procedure SetBit(var WordValue : word; BitNum : word); overload;
begin
  WordValue := WordValue or BitValArr[BitNum];
end;

procedure SetBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
  BitVals := 0;
  for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
  WordValue := WordValue or BitVals;
end;

procedure ClearBit(var WordValue : word; BitNum : word); overload;
begin
  WordValue := (WordValue or BitValArr[BitNum]) xor BitValArr[BitNum];
end;

procedure ClearBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
  BitVals := 0;
  for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
  WordValue := (WordValue or BitVals) xor BitVals;
end;

procedure ToggleBit(var WordValue : word; BitNum : word); overload;
begin
   WordValue := WordValue xor BitValArr[BitNum];
end;

procedure ToggleBit(var WordValue : word; BitNums : array of word); overload;
var BitVals,i : word;
begin
  BitVals := 0;
  for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
  WordValue := WordValue xor BitVals;
end;

function BitIsSet(WordValue : word; BitNum : word) : boolean; overload;
begin
  Result := (WordValue and BitValArr[BitNum] = BitValArr[BitNum]);
end;

function BitIsSet(WordValue : word; BitNums : array of word) : boolean; overload;
var BitVals,i : word;
begin
  BitVals := 0;
  for i := 0 to length(BitNums) - 1 do inc(BitVals,BitNums[i]);
  Result := (WordValue and BitVals = BitVals);
end;

function AndEqual(Value,AndValue : longword) : boolean;
begin
  Result := (Value and AndValue) = AndValue;
end;

// ====================================
// TDataset Record copy routines
// ====================================

procedure CpyRecByName(Src,Dst : TDataSet);
var i : integer;
    SField,DField : TField;
begin
  for i :=0 to Src.FieldCount - 1 do begin
     SField := Src.Fields[i];
     DField := Dst.FindField(SField.FieldName);

     if (DField <> nil) and
        (DField.FieldKind = fkData) and not
        DField.ReadOnly then begin
        if (SField.DataType = ftString) or
           (SField.DataType <> DField.DataType) then
             DField.AsString := SField.AsString
        else
           DField.Assign(SField);
     end;
   end;
end;

procedure CpyRecByNum(Src,Dst : TDataSet);
var i : integer;
begin
  for i :=0 to Src.FieldCount - 1 do begin
     try
       Dst.Fields[i].Value := Src.Fields[i].Value;
     except
       Dst.Fields[i].Assign(Src.Fields[i]);
     end;
  end;
end;

// ================================
// Recursive Search Tree for a file
// ================================

function SearchTree(StartDir,FileToFind : string;
                    out FileNamePath : string) : boolean; platform;
var Cmd : boolean;

    // Recursive Dir Search
    procedure SearchDir(DirPath : string);
    var SearchRec : TSearchRec;
    begin
      DirPath := IncludeTrailingBackSlash(DirPath);

      if FindFirst(DirPath + '*.*',faAnyFile,SearchRec) = 0 then begin
        if Uppercase(SearchRec.Name) = FileToFind then begin
           Cmd := true;
           FileNamePath := DirPath + SearchRec.Name;
        end
        else begin
          while not Cmd and (FindNext(SearchRec) = 0) do begin
            if UpperCase(SearchRec.Name) = FileToFind then begin
               Cmd := true;
               FileNamePath := DirPath + SearchRec.Name;
            end
            else
              if (SearchRec.Name <> '.') and
                 (SearchRec.Name <> '..') and
                 ((SearchRec.Attr and faDirectory) = faDirectory) then
                  SearchDir(DirPath + SearchRec.Name);
           end;
        end;

        FindClose(SearchRec);
      end;
    end;

// SearchTree
begin
  Screen.Cursor := crHourGlass;
  FileToFind := Uppercase(FileToFind);
  FileNamePath := '';
  Cmd := false;
  SearchDir(StartDir);
  Screen.Cursor := crDefault;
  Result := Cmd;
end;


// ==================================================
// compares memory 0=equal -1=P1<P2 1=P1>P2
// ==================================================

function MemCompare(P1,P2 : pointer; Len : integer) : integer;
var Cmd,i : integer;
    B1,B2 : ^byte;
begin
  Cmd := 0;
  B1 := P1;
  B2 := P2;
  for i := 0 to Len do begin
     if B1^ < B2^ then begin
        Cmd := -1;
        break;
     end;

     if B1^ > B2^ then begin
        Cmd := 1;
        break;
     end;

     inc(B1);
     inc(B2);
  end;

  Result := Cmd;
end;

// ===========================================
// Retieve Text from Win Calculator
// Useful ??? - but interesting
// ===========================================

var ObjHnd : THandle;

function WinCalcProc(ChildWnd : THandle; lParam : integer): bool; stdcall;
var Nme : array[0..127] of char;
begin
  GetClassName(ChildWnd,Nme,SizeOf(Nme));
  Result := (Nme <> 'Static');
  if not Result then ObjHnd := ChildWnd;
end;

function WinCalcValue : string;
var WndCalc : THandle;
    CalcStr : string;
    Txt : array[0..127] of char;
begin
  ObjHnd := 0;
  CalcStr := 'No Calc Avail';
  WndCalc := FindWindow('SciCalc',nil);

  if WndCalc <> 0 then begin
     EnumChildWindows(WndCalc,@WinCalcProc,0);
     if (ObjHnd <> 0) then begin
        GetWindowText(ObjHnd,Txt,SizeOf(Txt));
        CalcStr := Txt;
     end;
  end;

  Result := CalcStr;
end;


// ==========================================================
// Service Routines
// aMachine is UNC path or local machine if left empty
// ==========================================================

function ServiceStart(aMachine,aServiceName : string) : boolean;
var h_manager,h_svc: SC_Handle;
    svc_status: TServiceStatus;
    Temp: PChar;
    dwCheckPoint: DWord;
begin
  svc_status.dwCurrentState := 1;
  h_manager := OpenSCManager(PChar(aMachine), nil,SC_MANAGER_CONNECT);

  if h_manager > 0 then begin
    h_svc := OpenService(h_manager, PChar(aServiceName),
                         SERVICE_START or SERVICE_QUERY_STATUS);
    if h_svc > 0 then begin
      temp := nil;
      if (StartService(h_svc,0,temp)) then
        if (QueryServiceStatus(h_svc,svc_status)) then begin
          while (SERVICE_RUNNING <> svc_status.dwCurrentState) do begin
            dwCheckPoint := svc_status.dwCheckPoint;
            Sleep(svc_status.dwWaitHint);
            if (not QueryServiceStatus(h_svc,svc_status)) then break;
            if (svc_status.dwCheckPoint < dwCheckPoint) then begin
              // QueryServiceStatus didn't increment dwCheckPoint
              break;
            end;
          end;
        end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := (SERVICE_RUNNING = svc_status.dwCurrentState);
end;


function ServiceStop(aMachine,aServiceName : string) : boolean;
var h_manager,h_svc   : SC_Handle;
    svc_status     : TServiceStatus;
    dwCheckPoint : DWord;
begin
  h_manager:=OpenSCManager(PChar(aMachine),nil,SC_MANAGER_CONNECT);

  if h_manager > 0 then begin
    h_svc := OpenService(h_manager,PChar(aServiceName),
                         SERVICE_STOP or SERVICE_QUERY_STATUS);

    if h_svc > 0 then begin
      if(ControlService(h_svc,SERVICE_CONTROL_STOP,svc_status)) then begin
        if(QueryServiceStatus(h_svc,svc_status))then begin
          while(SERVICE_STOPPED <> svc_status.dwCurrentState)do begin
            dwCheckPoint := svc_status.dwCheckPoint;
            Sleep(svc_status.dwWaitHint);

            if(not QueryServiceStatus(h_svc,svc_status))then begin
              // couldn't check status
              break;
            end;

            if(svc_status.dwCheckPoint < dwCheckPoint)then break;
          end;
        end;
      end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := (SERVICE_STOPPED = svc_status.dwCurrentState);
end;

// ================================
// Status Constants
// SERVICE_STOPPED
// SERVICE_RUNNING
// SERVICE_PAUSED
// SERVICE_START_PENDING
// SERVICE_STOP_PENDING
// SERVICE_CONTINUE_PENDING
// SERVICE_PAUSE_PENDING
// =================================

function ServiceGetStatus(sMachine, sService: string ): DWord;
var h_manager,h_svc : SC_Handle;
    service_status     : TServiceStatus;
    hStat : DWord;
begin
  hStat := 0;
  h_manager := OpenSCManager(PChar(sMachine) ,nil,SC_MANAGER_CONNECT);

  if h_manager > 0 then begin
    h_svc := OpenService(h_manager,PChar(sService),SERVICE_QUERY_STATUS);

    if h_svc > 0 then begin
      if(QueryServiceStatus(h_svc, service_status)) then
        hStat := service_status.dwCurrentState;

      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := hStat;
end;

function ServiceGetStatusName(sMachine,sService: string ): string;
var Cmd : string;
    Status : DWord;
begin
  Status := ServiceGetStatus(sMachine,sService);

  case Status of
    SERVICE_STOPPED           : Cmd := 'STOPPED';
    SERVICE_RUNNING           : Cmd := 'RUNNING';
    SERVICE_PAUSED            : Cmd := 'PAUSED';
    SERVICE_START_PENDING     : Cmd := 'STARTING';
    SERVICE_STOP_PENDING      : Cmd := 'STOPPING';
    SERVICE_CONTINUE_PENDING  : Cmd := 'RESUMING';
    SERVICE_PAUSE_PENDING     : Cmd := 'PAUSING';
  else
    Cmd := 'UNKNOWN STATE';
  end;

  Result := Cmd;
end;

// ===================================================
// Change Track Bar to emulate narrow W200 style
// ===================================================

procedure SetTrackbarNarrow(TB : TTrackBar);
var H : integer;
begin
  H := GetWindowLong(TB.Handle,GWL_STYLE);
  SetWindowLong(TB.Handle,GWL_STYLE,H xor $20);
end;

// =============================================================================
// Pop up the standard 'Browse for computer' dialog box
// Flags combination of
// BIF_BROWSEFORCOMPUTER  Only computers else OK button is grayed.
// BIF_BROWSEFORPRINTER          Only printers else OK button is grayed.
// BIF_DONTGOBELOWDOMAIN  Don't include network folders below the domain level.
// BIF_RETURNFSANCESTORS  Only file system ancestors else OK button is grayed.
// BIF_RETURNONLYFSDIRS          Only file system dirs else OK button is grayed.
// ==================================================================

function BrowseFolder(const title : string;
                      Flags : longword = 0) : string;
var BrowseInfo : TBrowseInfo;
    IDRoot : PItemIDList;
    Path : array[0..MAX_PATH] of char;
begin
  // Get the Item ID for Network Neighborhood
  SHGetSpecialFolderLocation(0,CSIDL_NETWORK,IDRoot);
  ZeroMemory(@BrowseInfo,SizeOf(TBrowseInfo));
  ZeroMemory(@path,MAX_PATH);
  BrowseInfo.hwndOwner := 0;
  BrowseInfo.pidlRoot := IDRoot;
  BrowseInfo.lpszTitle := PChar(title);
  BrowseInfo.pszDisplayName := @path;
  BrowseInfo.ulFlags := Flags;
  // Show the browse dialog, get the Item ID for the selected item and convert it to a path
  SHBrowseForFolder(BrowseInfo);
  Result := path;
end;

// ==============================
// Execute browser at URL
// ==============================

procedure GoURL(const WebUrl : string);
begin
  ShellExecute(Application.Handle,'open',PChar(WebUrl),nil,nil,SW_NORMAL);
end;

// =============================================================
// Change a checbox state without triggerring OnCheck Event
// =============================================================

procedure SetCheckBoxCheck(cb : TCheckBox; Checked : boolean);
begin
  cb.Perform(BM_SETCHECK,byte(Checked),0);
end;

// ==================================================================
// Draw text at ANGLE rotation
// ==================================================================

procedure TextOutAngle(ParentCanvas : TCanvas;
                       X,Y : integer;
                       const FontName : string;
                       FontSize,Angle : integer;
                       const Txt : string;
                       Color : TColor = clBlack;
                       Transparent : boolean = true);

var lf : TLogFont;
    tf : TFont;
begin
  with ParentCanvas do begin
    if Transparent then
       SetBKMode(ParentCanvas.Handle,Windows.TRANSPARENT)
    else
       SetBKMode(ParentCanvas.Handle,Windows.OPAQUE);

    Font.Name := FontName;
    Font.Size := FontSize;
    Font.Color := Color;
    tf := TFont.Create;
    tf.Assign(Font);
    GetObject(tf.Handle, SizeOf(lf),@lf);
    lf.lfEscapement := Angle * 10;
    lf.lfOrientation := Angle * 10;
    tf.Handle := CreateFontIndirect(lf);
    Font.Assign(tf);
    tf.Free;
    TextOut(X,Y,Txt);
  end;
end;

(* =============================================================================
   AnimateShowWin() - Use in Form.FormCreate()
   AnimateHideWin() - Use in Form.FormClose()
  
   dwFlags can be:

   AW_SLIDE        Uses slide animation. By default, roll animation is used.
                   This flag is ignored when used with AW_CENTER.

   AW_BLEND        Uses a fade effect. This flag can be used only if hwnd
                   is a top-level window.

   AW_CENTER       Makes the window appear to collapse inward if AW_HIDE is used
                   or expand outward if the AW_HIDE is not used.

   AW_HOR_POSITIVE Animates the window from left to right. This flag can be
                   used with roll or slide animation. It is ignored when
                   used with AW_CENTER or AW_BLEND.

   AW_HOR_NEGATIVE Animates the window from right to left. This flag can be used
                   with roll or slide animation. It is ignored when used with
                   AW_CENTER or AW_BLEND.

   AW_VER_POSITIVE Animates the window from top to bottom. This flag can be used
                   with roll or slide animation. It is ignored when used with
                   AW_CENTER or AW_BLEND.

   AW_VER_NEGATIVE Animates the window from bottom to top. This flag can be used
                   with roll or slide animation. It is ignored when used with
                   AW_CENTER or AW_BLEND.

   Following are used internally by AnimateWin()
   AW_ACTIVATE     Activates the window. Do not use this value with AW_HIDE.
   AW_HIDE         Hides the window. By default, the window is shown.
*)


procedure AnimateWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD);
type
    TAnimFunc = function(a : THandle; b,c : DWORD) : boolean; stdcall;

var Dll : integer;
    AnimFunc : TAnimFunc;
begin
  Dll := LoadLibrary('user32.dll');

  if (Dll <> 0) then begin
    AnimFunc := GetProcAddress(Dll,'AnimateWindow');
    if (@AnimFunc <> nil) then AnimFunc(Form.Handle,dwTime,dwFlags);
    Form.Invalidate;
    FreeLibrary(Dll);
  end;
end;

procedure AnimateShowWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
begin
  AnimateWin(Form,dwFlags or AW_ACTIVATE,dwTime);
end;

procedure AnimateHideWin(Form : TForm; dwFlags : DWORD; dwTime : DWORD = 300);
begin
  AnimateWin(Form,dwFlags or AW_HIDE,dwTime);
end;

// =============================================================================
// Print a string grid
// internal functions
// =============================================================================

procedure PrtStrGrid_SetColumnWidth(SG : TStringGrid; Cols : TList;
                                    var Margins : TRect;
                                    var Spacing : integer);
var i,k,w : integer;
begin
  Printer.Canvas.Font.Style := [ fsBold ];

  for i := 0 to pred(SG.ColCount) do
      Cols.Add(Pointer(Printer.Canvas.TextWidth(SG.cells[i,0])));

  Printer.Canvas.Font.Style := [];

  for i := 1 to pred(SG.RowCount) do begin
     for k := 0 to pred(SG.ColCount) do begin
         w := Printer.Canvas.TextWidth(SG.Cells[k,i]);
         if w > integer(Cols[k]) then Cols[k] := pointer(w);
     end;
  end;

  w := 2 * Printer.Canvas.Font.PixelsPerInch div 3;
  Margins := Rect(w,w,Printer.PageWidth - w,Printer.PageHeight - w);
  Spacing := Printer.Canvas.Font.PixelsPerInch div 10;
  w := 0;

  for i := 0 to pred(Cols.Count) do
      w := w + integer(Cols[i]) + Spacing;
  w := w - Spacing;

  if w > (Margins.Right - Margins.Left ) then begin
     w := w - (Margins.Right - Margins.Left );
     Cols[Cols.Count - 2] := pointer(integer(Cols[Cols.Count - 2]) - w);
  end;

  w := 0;

  for i := 0 to pred(Cols.Count) do
      w := w + integer(Cols[i]) + Spacing;
  Margins.Right := w - Spacing + Margins.Left;
end;


procedure PrtStrGrid_DoLine(LineNo: integer;
                            SG : TStringGrid;
                            Cols : TList;
                            var Margins : TRect;
                            var Spacing : integer;
                            var y : integer);
var x,n,th : integer;
    r : TRect;
begin
  if length(SG.cells[1,LineNo]) <> 0 then begin
     x := Margins.Left;
     th := Printer.Canvas.TextHeight('�y');
     for n := 0 to pred(Cols.Count) do begin
        r := Rect(0,0,integer(Cols[n]),th);
        OffsetRect(r,x,y);
        Printer.Canvas.TextRect(r,x,y,SG.cells[n,lineno]);
        x := r.Right + Spacing;
     end; { for }

     inc(y,th);
  end;
end;

procedure PrtStrGrid_DoHeader(SG : TStringGrid;
                              Cols : TList;
                              var Margins : TRect;
                              var Spacing : integer;
                              var y : integer);
begin
  y := Margins.Top;
  Printer.Canvas.Font.Style := [fsBold];
  PrtStrGrid_DoLine(0,SG,Cols,Margins,Spacing,y);
  Printer.Canvas.Pen.Width := Printer.Canvas.Font.PixelsPerInch div 72;
  Printer.Canvas.Pen.Color := clBlack;
  Printer.Canvas.MoveTo(Margins.Left,y);
  Printer.Canvas.Lineto(Margins.Right,y);
  inc(y,2 * Printer.Canvas.Pen.Width);
  Printer.Canvas.Font.Style := [ ];
end;


procedure PrtStrGrid_DoPrint(SG : TStringGrid;Cols : TList;
                             var Margins : TRect;
                             var Spacing : integer);
var i,y : integer;
begin
  y:= 0;

  for i := 1 to pred(SG.RowCount ) do begin
     Application.ProcessMessages;
     if y = 0 then PrtStrGrid_DoHeader(SG,Cols,Margins,Spacing,y);
     PrtStrGrid_DoLine(i,SG,Cols,Margins,Spacing,y);
     if y >= Margins.Bottom then begin
       Printer.NewPage;
       y := 0;
     end;
  end;
end;

// =============================================================================
// Print String Grid
// Public Library Call
// =============================================================================

procedure PrintStrGrid(StringGrid : TStringGrid; ShowSetupDialog : boolean = true);
var Margins : TRect;
    Spacing : integer;
    Cols : TList;
    Setup : TPrinterSetupDialog;
    CanPrint : boolean;
begin
  Setup := nil;
  CanPrint := true;

  if ShowSetupDialog then begin
    Setup := TPrinterSetupDialog.Create(nil);
    CanPrint := Setup.Execute;
  end;

  if CanPrint then begin
    Cols := TList.Create;
    if Printer.Printing then printer.abort;
    Printer.BeginDoc;

    try
      try
        Printer.Canvas.Font.PixelsPerInch :=
                       GetDeviceCaps(Printer.Handle,logPixelsY);
        Printer.Canvas.Font.Assign(StringGrid.font);
        Printer.Canvas.Font.Color := clBlack;
        Printer.Canvas.Pen.Color := clBlack;
        PrtStrGrid_SetColumnWidth(StringGrid,Cols,Margins,Spacing);
        Application.ProcessMessages;
        PrtStrGrid_DoPrint(StringGrid,Cols,Margins,Spacing);
      except
        on E : Exception do ErrorDlg(E.Message);
      end;
    finally
      if ShowSetupDialog then Setup.Free;
      Cols.Free;
      Printer.EndDoc;
    end;
end;  
end;

// ================================================================
// Check for BDE installed and Version
// ================================================================

function BDEinstalled(TerminateOnErr : boolean = false;
                      ShowErrorDlg : boolean = false;
                      InfoList : TStrings = nil) : string;
var RetVal : string;
    BdeVer : SYSVersion;
    M,D,H,N,S : word;
    Y : smallint;
begin
  RetVal := '';

  try
    Check(DbiGetSysVersion(BdeVer));

    if (InfoList <> nil) then begin
       InfoList.Clear;
       InfoList.Add('ENGINE VERSION  = ' + IntToStr(BdeVer.iVersion));
       InfoList.Add('INTERFACE LEVEL = ' + IntToStr(BdeVer.iIntfLevel));
       DbiDateDecode(BdeVer.DateVer,M,D,Y);
       InfoList.Add('VERSION DATE    = ' + FormatFloat('00',D) + '/' +
                                           FormatFloat('00',M) + '/' +
                                           FormatFloat('0000',Y));
       DbiTimeDecode(BdeVer.TimeVer,H,N,S);
       InfoList.Add('VERSION TIME    = ' + FormatFloat('00',H) + ':' +
                                           FormatFloat('00',N) + ':' +
                                           FormatFloat('00',S div 1000));
    end;

    RetVal := IntToStr(BdeVer.iVersion);
  except
    RetVal := '';
    if ShowErrorDlg then ErrorDlg('Borland Databse Engine (BDE)' + CrLf +
                                  'is NOT Installed');
    if TerminateOnErr then HaltApplication('');
  end;

  Result := RetVal;
end;

// ======================================
// Return Highest DAO installed
// ======================================

function GetDAOversion : integer; overload;
var Path : string;
    Cmd,ThisVer : integer;
    DirInfo : TSearchRec;
begin
  Cmd := 0;
  Path := ExtractFileDrive(WindowsDir) + '\Program Files\Common Files\' +
          'Microsoft Shared\DAO\dao*.dll';

  if FindFirst(Path,faAnyFile,DirInfo) = 0 then begin
     ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
     if ThisVer > Cmd then Cmd := ThisVer;

     while FindNext(DirInfo) = 0 do begin
       ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
       if ThisVer > Cmd then Cmd := ThisVer;
     end;

     FindClose(DirInfo);
   end;

   Result := Cmd;
end;

function GetDAOversion(SList : TStrings) : integer; overload;
var Path : string;
    Cmd,ThisVer : integer;
    DirInfo : TSearchRec;
begin
  SList.Clear;
  Cmd := 0;
  Path := ExtractFileDrive(WindowsDir) + '\Program Files\Common Files\' +
          'Microsoft Shared\DAO\dao*.dll';

  if FindFirst(Path,faAnyFile,DirInfo) = 0 then begin
     ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
     SList.Add(FormatFloat('0.00',ThisVer / 100.0));
     if ThisVer > Cmd then Cmd := ThisVer;

     while FindNext(DirInfo) = 0 do begin
       ThisVer := StrToIntDef(copy(DirInfo.Name,4,3),0);
       SList.Add(FormatFloat('0.00',ThisVer / 100.0));
       if ThisVer > Cmd then Cmd := ThisVer;
     end;

     FindClose(DirInfo);
   end;

   Result := Cmd;
end;

// ========================================================
// Enable/Disable w2000 task manager from popping up
// ========================================================

procedure DisableTaskManager(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
                   true) then
       Reg.WriteInteger('DisableTaskMgr',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Lock Computer
// ========================================================

procedure DisableLockWorkStation(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
                   true) then
       Reg.WriteInteger('DisableLockWorkstation',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Change Password
// ========================================================

procedure DisableChangePassword(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
                   true) then
       Reg.WriteInteger('DisableChangePassword',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Logoff
// ========================================================

procedure DisableLogoff(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
                   true) then
       Reg.WriteInteger('NoLogoff',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Shutdown
// ========================================================

procedure DisableShutDown(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
                   true) then
       Reg.WriteInteger('NoClose',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Registry Tools
// ========================================================

procedure DisableRegistryTools(const State : boolean);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',
                   true) then
       Reg.WriteInteger('DisableRegistryTools',integer(State));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Set Screen Saver Timeout
// ========================================================

procedure SetScreenSaverTimeOut(const TimeMilSec : integer);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Policies\Microsoft\Windows\Control Panel\Desktop',
                   true) then
       Reg.WriteString('ScreenSaveTimeOut',IntToStr(TimeMilSec));
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

// ========================================================
// Enable/Disable w2000 Screen Saver
// ========================================================

procedure DisableScreenSaver(const State : boolean);
begin
     if State = True  then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,0,nil,0);
     if State = False then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,1,nil,0);
end;


// =================================================================
// Set a string list to GUID desc + Separator + OLE Class name
// =================================================================

procedure LoadCLSID(StringList : TStrings; Separator : char = '*';
                    IncludeVersionIndependent : boolean = true);
const REGKEY = 'Software\Classes\CLSID';
var WinReg : TRegistry;
    KeyNames,SubKeyNames : TStringList;
    i : integer;
    KeyDesc : string;
    ProgID,VersID : boolean;
begin
  StringList.Clear;
  KeyNames := TStringList.Create;
  SubKeyNames := TStringList.Create;
  WinReg := TRegistry.Create;
  WinReg.RootKey := HKEY_LOCAL_MACHINE;

  if WinReg.OpenKey(REGKEY,false) then begin
    WinReg.GetKeyNames(KeyNames);
    WinReg.CloseKey;

    // Traverse list of GUID numbers eg. {00000106-0000-0010-8000-00AA006D2EA4}
    for i := 1 to KeyNames.Count - 1 do begin
      if WinReg.OpenKey(REGKEY + '\' + KeyNames[i],false) then begin
        // Set which keys are available
        ProgID := WinReg.KeyExists('ProgID');
        VersID := WinReg.KeyExists('VersionIndependentProgID');

        // "ProgID" Key
        if ProgID then begin
          KeyDesc := WinReg.ReadString(''); // Read (Default) value
          if trim(KeyDesc) = '' then KeyDesc := KeyNames[i];
          WinReg.CloseKey;

          if WinReg.OpenKey(REGKEY + '\' + KeyNames[i] +
                           '\ProgID',false) then begin
            StringList.Add(KeyDesc + Separator + WinReg.ReadString(''));
            WinReg.CloseKey;

            // "Version Independent" Key if present and requested
            if IncludeVersionIndependent and VersID then begin
              KeyDesc := KeyDesc + ' [Version Independent]';
              if WinReg.OpenKey(REGKEY + '\' + KeyNames[i] +
                               '\VersionIndependentProgID',false) then begin
                StringList.Add(KeyDesc + Separator + WinReg.ReadString(''));
                WinReg.CloseKey;
              end;
            end;

          end;
        end
        else
          WinReg.CloseKey;
      end;
    end;
  end;

  WinReg.Free;
  SubKeyNames.Free;
  KeyNames.Free;
end;


// ===========================================
// Delete a dir tree and all children
// ===========================================

function DeleteTree(const SrcPath : string) : boolean;
var FileOpStruct : TShFileOpStruct;
begin
  FileOpStruct.Wnd := Application.Handle;
  FileOpStruct.wFunc := FO_DELETE;
  FileOpStruct.pFrom := PChar(SrcPath);
  FileOpStruct.pTo := nil;
  FileOpStruct.fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
  FileOpStruct.lpszProgressTitle := nil;
  Result := (ShFileOperation(FileOpStruct) = 0);
end;


// ========================================================
// Functions to Darken,Lighten and mix colors by a percent
// ========================================================

function Darker(Color : TColor; Percent : integer) : TColor;
var R,G,B : byte;
begin
  Percent := min(100,abs(Percent));
  Color := ColorToRGB(Color);
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
  R := R - MulDiv(R,Percent,100);
  G := G - MulDiv(G,Percent,100);
  B := B - MulDiv(B,Percent,100);

  Result := RGB(R,G,B);
end;

function Lighter(Color : TColor; Percent : integer) : TColor;
var R,G,B : byte;
begin
  Percent := min(100,abs(Percent));
  Color := ColorToRGB(Color);
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
  R := R + MulDiv(255 - R,Percent,100);
  G := G + MulDiv(255 - G,Percent,100);
  B := B + MulDiv(255 - B,Percent,100);

  Result := RGB(R,G,B);
end;

function MixColors(C1,C2 : TColor) : TColor;
begin
  Result := RGB((GetRValue(C1) + GetRValue(C2)) div 2,
                (GetGValue(C1) + GetGValue(C2)) div 2,
                (GetBValue(C1) + GetBValue(C2)) div 2);
end;

// =============================================
// Return a contrasting color to passed color
// =============================================

function ContrastColor(Color : TColor) : TColor;
var R,G,B : byte;
begin
  Color := ColorToRGB(Color);
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
  if R < 220 then R := 255 else R := 0;
  if G < 220 then G := 255 else G := 0;
  if B < 220 then B := 255 else B := 0;

  Result := RGB(R,G,B);
end;


// =======================================
// Return Default Outlook Profile
// =======================================

function DefaultMessagingProfile : string;
var WinReg : TRegistry;
    Cmd : string;
begin
  Cmd := '';
  WinReg := TRegistry.Create;

  if WinReg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles',false)then begin
    Cmd := WinReg.ReadString('DefaultProfile');
    WinReg.CloseKey;
  end;

  WinReg.Free;
  Result := Cmd;
end;


end.