Decrementing a datetime field in Paradox

Problem/Question/Abstract:

Decrementing a datetime field in Paradox

Answer:

There is a bug in Local SQL on Paradox:

Executing an Update statement on a Paradox table where '1' is being subtracted in a datetime field does not subtract '1', but rather adds '1'.

// this will ADD one!
UPDATE SAMPLE.DB set DT = DT - 1

// the following workaround will give the correct result:
UPDATE SAMPLE.DB set DT = DT + (-1)

Jumping between compiler errors

Problem/Question/Abstract:

Jumping between compiler errors

Answer:

After compiling, when there were errors found:

Alt-F8 will take you to the next compiler error

Alt-F7 will take you to the previous error.

Add a page break to an Excel worksheet

Problem/Question/Abstract:

How to add a page break to an Excel worksheet

Answer:

If WS is your worksheet:

{ ... }
Excel.ActiveWindow.View := xlPageBreakPreview;
WS.HPageBreaks.Add(WS.Cells.Item[78, 1]);
{ ... }

How to hide the font size list in a TFontDialog

Problem/Question/Abstract:

How can I completely hide the fontsize selection combobox in the font dialog? I have manipulated some properties of the fontdialog but the combobox where you pick the font size is always visible. Furthermore, I want to keep the preview of the font but with a fixed font size.

Answer:

Set the fdLimitSize option in the dialogs Options to true and specifiy the same size for the MinFontsize and Maxfontsize property.

Hide the font size list. This requires a bit of spy work to determine the control IDs in the dialog. Once this has been done you can attach a handler to the fontdialogs Onshow handler:

procedure TForm1.FontDialog1Show(Sender: TObject);
begin
  EnableWindow(GetDlgItem(fontdialog1.handle, 1138), false);
  EnableWindow(GetDlgItem(fontdialog1.handle, 1090), false);
  ShowWindow(GetDlgItem(fontdialog1.handle, 1138), SW_HIDE);
  ShowWindow(GetDlgItem(fontdialog1.handle, 1090), SW_HIDE);
end;

1138 is the handle of the font size combobox (it is a combobox, despite looking like an edit with a list box below it), 1090 the text label above it. Without disabling the controls the accelerator for the size box will close the dialog for some reason.

For the future: the spy works done here was performed this way:

procedure TForm1.Button1Click(Sender: TObject);
begin
  fontdialog1.execute;
end;

function EnumProc(wnd: HWND; lines: TStrings): BOOL; stdcall;
var
  buf, caption: array[0..255] of char;
begin
  result := True;
  GetClassname(wnd, buf, 256);
  GetWindowText(wnd, caption, 256);
  lines.add(format('ID: %d, class: %s, caption: %s', [GetDlgCtrlID(wnd), buf,
    caption]));
end;

procedure TForm1.FontDialog1Show(Sender: TObject);
begin
  memo1.clear;
  EnumChildWindows(fontdialog1.handle, @EnumProc, integer(memo1.lines));
end;

{Output in memo:

ID: 1088, class: Static, caption: Schrift&art:
ID: 1136, class: ComboBox, caption: MS Sans Serif
ID: 1000, class: ComboLBox, caption:
ID: 1001, class: Edit, caption: MS Sans Serif
ID: 1089, class: Static, caption: &Schriftschnitt:
ID: 1137, class: ComboBox, caption: Standard
ID: 1000, class: ComboLBox, caption:
ID: 1001, class: Edit, caption: Standard
ID: 1090, class: Static, caption: &Grad:
ID: 1138, class: ComboBox, caption: 8
ID: 1000, class: ComboLBox, caption:
ID: 1001, class: Edit, caption: 8
ID: 1, class: Button, caption: OK
ID: 2, class: Button, caption: Abbrechen
ID: 1026, class: Button, caption: �&bernehmen
ID: 1038, class: Button, caption: &Hilfe
ID: 1072, class: Button, caption: Darstellung
ID: 1040, class: Button, caption: &Durchgestrichen
ID: 1041, class: Button, caption: &Unterstrichen
ID: 1091, class: Static, caption: &Farbe:
ID: 1139, class: ComboBox, caption: Schwarz
ID: 1073, class: Button, caption: Muster
ID: 1092, class: Static, caption: AaBbYyZz
ID: 1093, class: Static, caption:
ID: 1094, class: Static, caption: S&chrift:
ID: 1140, class: ComboBox, caption: Western
}

Retreive information from a TDBGrid onCellClick

Problem/Question/Abstract:

How to retreive the information from a TDBGrid when you click a cell or row

Answer:

While you click a TDBGrid row, the information can be obtained by the following procedure:

DBAccounts is a TDBGrid
For this example e_F0..e_F2 are TEdit but it can be any object
You can use FieldCount to obtain the number of fields so you can fill an array like

for x = 0 to DBAccounts.FieldCount - 1 do
  AnyArray[x] := DBAccounts.Fields[x].DisplayText

For this Example, Set TDBGrid.Options[dgRowSelect] so when you click a cell the row will be selected. Trim Function removes spaces (OPTIONAL)

procedure TForm4.DBAccountsCellClick(Column: TColumn);
begin
  with DBAccounts.SelectedField do
  begin
    e_F0.Text := Trim(DBAccounts.Fields[0].DisplayText);
    e_F1.Text := Trim(DBAccounts.Fields[1].DisplayText);
    e_F2.Text := Trim(DBAccounts.Fields[2].DisplayText);
    // and so on ....
    //.
    //.
    //.
  end;
end;

How to move icons between TImageLists

Problem/Question/Abstract:

How to move icons between TImageLists

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  ico: TIcon;
begin
  ico := TIcon.Create;
  try
    Imagelist1.GetIcon(0, ico);
    Imagelist2.AddIcon(ico);
  finally
    ico.Free;
  end;
end;

Create a sorted TList that holds integers

Problem/Question/Abstract:

How can I create a TStringlist cousin which holds integers rather than strings. I need the ability to keep a list of objects sorted by an integer with full binary IndexOf.

Answer:

Use a TList, and do casts where appropriate:

To write:

MyList.Add(Pointer(17));
MyList.Add(Pointer(39));

To read:

MyInt := Integer(MyList[0]);

To sort:

procedure CompareInts(Item1, Item2: Pointer): Integer;
begin
  if Integer(Item1) > Integer(Item2) then
    Result := 1
  else if if Integer(Item1) < Integer(Item2) then
    Result := -1
  else
    Result := 0;
end;
{ ... }
MyList.Sort(CompareInts);

How to create a message box with your own icon

Problem/Question/Abstract:

The message box has limited icons as set by Microsoft. I would like to use one of the icon I have and insert it into the message box. Is there a way to do that? Do I have to create a component to handle it?

Answer:

function CustMsgBox(const AMsg, ACaption, BCap1, BCap2, BCap3: string;
  IconInd: integer; FocusInd: byte; Mainform: TForm): integer;
const
  Userexe: array[0..9] of char = 'user.exe';
const
{$IFDEF Win32}
  BHeight = 23;
{$ELSE}
  BHeight = 25;
{$ENDIF}
  BWidth = 77;
var
  W: TForm;
  lCaption: TLabel;
  But1, But2, But3: TButton;
  i1: integer;
  Image1: TImage;
  IHandle: THandle;
  P1: array[byte] of char;
  Textsize: TSize;
  MDC: hDC;
  CurMetrics: TTextMetric;
  Curfont: HFont;
  Msgrect: TRect;
begin
  W := TForm.CreateNew(Application);
  But2 := nil;
  But3 := nil;
  try {set up form}
    W.BorderStyle := bsDialog;
    W.Ctl3D := True;
    W.Width := 360;
    W.Height := 160;
    W.Caption := ACaption;
    W.Font.Name := 'Arial' {Mainform.Font.Name};
    W.Font.CharSet := BALTIC_CHARSET;
    W.Font.Size := Mainform.Font.Size;
    W.Font.Style := Mainform.Font.Style;
    {Get text extent}
    for i1 := 0 to 25 do
      P1[i1] := Chr(i1 + Ord('A'));
    for i1 := 0 to 25 do
      P1[i1 + 26] := Chr(i1 + Ord('a'));
    GetTextExtentPoint(W.Canvas.Handle, P1, 52, Textsize);
    {Get line height}
    MDC := GetDC(0);
    CurFont := SelectObject(MDC, W.Font.Handle);
    GetTextMetrics(MDC, CurMetrics);
    SelectObject(MDC, CurFont);
    ReleaseDC(0, MDC);
    {Set icon}
    Image1 := TImage.Create(W);
    StrPCopy(P1, ParamStr(0));
    if Image1 <> nil then
    begin
      Image1.Width := Image1.Picture.Icon.Width;
      Image1.Height := Image1.Picture.Icon.Height;
      Image1.Left := 20;
      Image1.Top := Textsize.CY + (Textsize.CY div 2);
      Image1.Width := 32;
      Image1.Height := 32;
      Image1.Parent := W;
      Image1.Name := 'Image';
      {get icon index}
      case IconInd of
        16: IHandle := ExtractIcon(hInstance, userexe, 3);
        32: IHandle := ExtractIcon(hInstance, userexe, 2);
        48: IHandle := ExtractIcon(hInstance, userexe, 1);
        64: IHandle := ExtractIcon(hInstance, userexe, 4);
        128: IHandle := ExtractIcon(hInstance, userexe, 0);
        256: IHandle := ExtractIcon(hInstance, userexe, 5);
        512: IHandle := ExtractIcon(hInstance, userexe, 6);
      else
        IHandle := ExtractIcon(hInstance, P1, IconInd);
      end;
      if IHandle <> 0 then
        Image1.Picture.Icon.Handle := IHandle
      else
        Image1.Picture.Icon := Application.Icon;
    end;
    SetRect(MsgRect, 0, 0, Screen.Width div 2, 0);
    DrawText(W.Canvas.Handle, PChar(AMsg), -1, MsgRect, DT_CALCRECT or DT_WORDBREAK);
    {set up label}
    lCaption := TLabel.Create(W);
    lCaption.Parent := W;
    lCaption.Left := 72;
    lCaption.Top := Image1.Top;
    lCaption.Width := Msgrect.Right;
    LCaption.Height := Msgrect.Bottom;
    lCaption.Autosize := False;
    lCaption.WordWrap := True;
    {Adjust form width...must do here to accommodate buttons}
    W.Width := lCaption.Left + lCaption.Width + 30;
    lCaption.Caption := AMsg;
    {buttons}
    But1 := TButton.Create(W);
    But1.Parent := W;
    But1.Caption := BCap1;
    But1.ModalResult := 1;
    if BCap2 <> '' then
    begin
      But2 := TButton.Create(W);
      But2.Parent := W;
      But2.Caption := BCap2;
      But2.ModalResult := 2;
      if BCap3 <> '' then
      begin
        But3 := TButton.Create(W);
        But3.Parent := W;
        But3.Caption := BCap3;
        But3.ModalResult := 3;
      end;
    end;
    {Set button positions}
    {set height depending on whether icon or message is tallest}
    if lCaption.Height > Image1.Height then
      But1.Top := (lCaption.Top + lCaption.Height + 20)
    else
      But1.Top := (Image1.Top + Image1.Height + 20);
    But1.Width := BWidth;
    But1.Height := BHeight;
    if But2 <> nil then
    begin
      But2.Height := BHeight;
      But2.Width := BWidth;
      But2.Top := But1.Top;
      if But3 <> nil then
      begin
        But3.Top := But1.Top;
        But3.Width := BWidth;
        But3.Height := BHeight;
        But3.Left := (W.Width div 2) + ((BWidth div 2) + 8);
        But2.Left := (W.Width div 2) - (BWidth div 2);
        But1.Left := (W.Width div 2) - ((BWidth div 2) + BWidth + 8);
        But3.Cancel := True;
      end
      else
      begin
        But2.Left := (W.Width div 2) + 4;
        But1.Left := (W.Width div 2) - (BWidth + 4);
      end;
    end
    else
    begin
      But1.Left := (W.Width div 2) - (BWidth div 2);
    end;
    {set focus}
    case FocusInd of
      3:
        if BCap3 <> '' then
          But3.Default := True;
      2:
        if BCap2 <> '' then
          But2.Default := True;
    else
      But1.Default := True;
    end;
    {Set clientheight to proper height}
    W.ClientHeight := But1.Top + But1.Height + Textsize.CY;
    { Left := (W.ClientWidth div 2) - (((OKButton.Width * 2) + 10) div 2) }
    {Show messagebox}
    {Set position}
    { Position := poScreenCenter;  }
    W.Left := Mainform.Left + ((Mainform.Width - W.Width) div 2);
    W.Top := Mainform.Top + ((Mainform.Height - W.Height) div 2);
    W.ShowModal;
    Result := W.ModalResult;
  finally
    W.Free;
  end;
end;

How to draw colored text on a TStatusBar

Problem/Question/Abstract:

How to draw colored text on a TStatusBar

Answer:

The status bar is a standard Windows control, and as such, displays the font in the clBtnText value, which is set via the Control Panel. This color is black by default, but it can vary due to the user's color scheme. Other standard Windows controls, such as buttons, exhibit this identical behavior. The StatusBar and its associated panels have an owner-draw capability that allow you to draw text in any colors you want. Be sure to change the Style property of the TStatusBar.Panels to OwnerDraw.

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[0] then
  begin
    StatusBar.Canvas.Font.Color := clRed;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
  end
  else
  begin
    StatusBar.Canvas.Font.Color := clGreen;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
  end;
end;

Add a bitmap to a menu item (2)

Problem/Question/Abstract:

How to add bitmaps to a menu?

Answer:

Create a Picture. Load a .BMP from somewhere into the picture. Better have the picture as a resource and load the handle with LoadBitmap(). Use the SetMenuItemBitmaps API call to connect the Picture to the Menu.

All this can by coded in the .Create of a form.

Don't use a bitmap that is too large :) because only the right-top of the bitmap is displayed.


var
  Bmp1: TPicture;
  CheckedHandle,
    Bmp1Handle: THandle;

// ... in the FormCreate event:

// either load from an external file
Bmp1 := TPicture.Create;
Bmp1.LoadFromFile('c:\where\b1.BMP');
Bmp1Handle := Bmp1.Bitmap.Handle;
CheckedHandle := Bmp1Handle;

// or - using resources in the EXEcutable
Bmp1Handle := LoadBitmap(hInstance, 'RESOURCENAME');
CheckedHandle := LoadBitmap(hInstance, 'CHECKED_IMAGE');

// assign the bitmaps
SetMenuItemBitmaps(MenuItemTest.Handle, 0, MF_BYPOSITION,
  Bmp1Handle, CheckedHandle);
...

Templates Delphi

Problem/Question/Abstract:

Templates in Delphi

Answer:

Here is an overview about the different templates in Delphi and where they are stored.
Important: If you reinstall or update Delphi, you should save these files first!

delphi32.dci
Delphi source file templates in a text file

delphi32.dct
Delphi Component Template IDE binary file with the Delphi componens templates

delphi32.dmt
Delphi Menu Template IDE / Menu designer binary file with the menu templates

delphi32.dro
Delphi Repository Options ID text file with the object repository's settings

How to add items of a TListBox as sub-items to a selected tree node

Problem/Question/Abstract:

I have TreeView1, Button1 and ListBox1. ListBox one has x number of items. I need to be able to click Button1 and the items in ListBox1 are inserted as sub-items to the selected tree-node.

Answer:

var
  ix: integer;
  parentnode: TTreeNode;

  TreeView.Items.BeginUpdate;
try
  parentnode := TreeView.FocusedNode;
  for ix := 0 to ListBox1.Items.Count - 1 do
  begin
    if parentnode = nil then
      Tree.Items.Add(nil, ListBox1[ix])
    else
      Tree.Items.AddChild(parentnode, ListBox1[ix]);
  end;
finally
  TreeView.Items.EndUpdate;
end;

Move components from Delphi 5 to Delphi 6

Problem/Question/Abstract:

Have you tried to compile your components, or 3rd party components you have in Delphi 5 into Delphi 6?
99% of them will not compile. However do not despare. It is only because of a few changes Borland has implemented on their latest product. This article covers the major changes.

Answer:

First of all, you will discover that the unit dsgnintf.pas is missing. Borland changed the name to Designintf.pas, moved the property editor code to a new unit, called DesignEditors.pas, put the constants used inside DesignConsts.pas and the menus inside DesignMenus.pas

Also the variants have moved from system.pas to their own unit called Variants.pas

The IFormDesigner interface isn't there anymore. You should use the IDesigner and typecast your variables. (this is a change probably made to accomodate the CLX and I was unable to find any documentation on it from either Borland or Delphi 6 Online help system. I only found that every IFormDesigner has been repaced with IDesigner)

The IDesignerSelections interface has also changed. The most helpfull change is the addition of a Get function that returns a TPersistent when giving the index of the member.

On previous versions if you wanted the TPersistent of an object you wrote:

var
  p: TPersistant;
  ...
    P := Selections[i] as TPersistant;

Now you only write:

var
  p: TPersistant;
  ...
    P := Selections.get[i];

That's about it. I have used these simple instructions to recompile all of  my third party tools, and all of my custom components.

P.S. Just remember... you have to have the source code to do this!!! :-)

Determine if a given TTable has a restricted view

Problem/Question/Abstract:

I am trying to write a function to determine if a given TTable has a restricted view. The filtered and master-detail views are easy. Is there a way to determine if SetRange / ApplyRange, etc. have been used for a table? This is for Paradox tables.

Answer:

TMyTable = class(TTable)
public
  function IsRangeActive: Boolean;
end;

function TMyTable.IsRangeActive: Boolean;
begin
  Result := BuffersEqual(GetKeyBuffer(kiRangeStart), GetKeyBuffer(kiCurRangeStart),
    SizeOf(TKeyBuffer) + RecordSize) and BuffersEqual(GetKeyBuffer(kiRangeEnd),
    GetKeyBuffer(kiCurRangeEnd), SizeOf(TKeyBuffer) + RecordSize);
end;

How to remove the focus rectangle and highlighted cell in a read-only TDBGrid

Problem/Question/Abstract:

How can I get rid of highlighting, focus rectangle etc. in a TDBGrid. I want the grid to display information only - without the user seeing highlighted cells etc. If I disable the grid, the user cannot use the scrollbars.

Answer:

Try this. You can adjust it to your needs:


procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  if not (gdFixed in State) then
    StringGrid1.Canvas.Brush.Color := clWindow;
  StringGrid1.Canvas.FillRect(Rect);
  InflateRect(Rect, -1, -1); {resize so text is not on line}
  DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol, ARow]), -1,
    Rect, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
end;

Access the current row/column of a TMemo

Problem/Question/Abstract:

Access the current row/column of a TMemo

Answer:

The following code reads and writes the cursor's position as row and column; counting starts at 0.

procedure GetMemoRowCol(M: TMemo; var Row, Col: LongInt);
begin
  Row := SendMessage(M.Handle, EM_LINEFROMCHAR, M.SelStart, 0);
  Col := M.SelStart - SendMessage(M.Handle, EM_LINEINDEX, Row, 0);
end;

procedure SetMemoRowCol(M: TMemo; Row, Col: Integer);
begin
  M.SelStart := SendMessage(M.Handle, EM_LINEINDEX, Row, 0) + Col;
end;

Detect an HTTP proxy from an Opera installation

Problem/Question/Abstract:

Detect an HTTP proxy from an Opera installation

Answer:

For the uncommon situation that a user does not have IE installed, one could try to retrieve the proxy information from an Opera installation.

Opera software stores in the registry the directory in that the Opera browser is installed.

In this directory there is a configuration file "Opera.ini" that contains a [PROXY] section. This section holds the required information.
The following handy routine shows how to code it:

procedure TForm1.FormCreate(Sender: TObject);
var
  OperaDir: string;
  sResult: string;
begin
  // get Proxy host info from an Opera installation!
  with TRegistry.Create do
  begin
    sResult := '';
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('\Software\Opera Software', false) then
    begin
      if ValueExists('Last Directory') then
      begin
        OperaDir := ReadString('Last Directory');
        SetLength(sResult, 128);
        SetLength(sResult,
          GetPrivateProfileString(
          'PROXY',
          'HTTP Server',
          '',
          @sResult[1],
          Length(sResult),
          PChar(OperaDir + '\opera.ini')));
      end;
    end;
    Free;
    if sResult <> '' then
      ShowMessage('Your http proxy is ' + sResult)
    else
      ShowMessage('Opera is not installed or no proxy found.');
  end;
end;

Delphi 4/5 and Formula 1 Spreadsheet ActiveX control

Problem/Question/Abstract:

I ran into some problems when upgrading a work environment from Delphi 4 to Delphi 5, where the Formula 1 Spreadsheet ActiveX control (OCX) was involved.

Normal installation of an OCX:

Menu 'Component | Import ActiveX Control'

In the list of ActiveX controls, select 'VC Formula One'. If it is not in the list, use the 'Add' button to insert the OCX (\winnt\system32\vcf15.ocx)

Option step: Hit button 'Create Unit'. This will create an import unit 'VCF15_TLB.PAS', by default into this directory: \Delphi5\Imports\. The 'TLB' means 'Type Library'.

Hit Button 'Install'. If needed, this will create the import unit (see previous step). Then this import unit will be added to a - selected - package.

Open this package, compile and if necessary install it.


This procedure worked fine for Formula 1 with Delphi 4. However, when I had Delphi 5 create the import unit, I ran into these problems:

// ************************************************************************
// Errors:
// Hint: Member 'Type' of 'IF1FileSpec' changed to 'Type_'
// Hint: Member 'Type' of 'IF1NumberFormat' changed to 'Type_'
// Hint: Member 'Type' of 'IF1Book' changed to 'Type_'
// Hint: Parameter 'Array' of IF1Book.CopyDataFromArray changed to 'Array_'
// Hint: Parameter 'Array' of IF1Book.CopyDataToArray changed to 'Array_'
// Hint: Member 'Type' of 'IF1BookView' changed to 'Type_'
// Hint: Parameter 'Array' of IF1BookView.CopyDataFromArray changed to 'Array_'
// Hint: Parameter 'Array' of IF1BookView.CopyDataToArray changed to 'Array_'
// ************************************************************************

To make matters worse, when trying to compile the package file, I would get incompatible type errors in these lines:

property ColWidth[nCol: Integer]: Smallint read Get_ColWidth write Set_ColWidth;
property RowHeight[nRow: Integer]: Smallint read Get_RowHeight write Set_RowHeight;

Answer:

I found that the manufacturer puts an import file into the Formula One directory. The name of this file is 'VCF15.pas' (instead of 'VCF15_TLB.pas')

So I had to go through all my source codes and in the uses clauses replace VCF15_TLB with VCF15.

I also noticed that arguments of type 'WideString' had to be replaced with 'String' in Delphi 5.

After these steps, I can now compile applications under Delphi 5 that use Formula 1 and the deployed executables work.

Empty the recycle bin

Problem/Question/Abstract:

How to empty the recycle bin

Answer:

procedure EmptyRecycleBin;
const
  SHERB_NOCONFIRMATION = $00000001;
  SHERB_NOPROGRESSUI = $00000002;
  SHERB_NOSOUND = $00000004;
type
  TSHEmptyRecycleBin = function(Wnd: HWND; pszRootPath: pChar; dwFlags: DWORD):
    HRESULT; stdcall;
var
  SHEmptyRecycleBin: TSHEmptyRecycleBin;
  LibHandle: THandle;
begin
  LibHandle := LoadLibrary(pChar('Shell32.dll'));
  if LibHandle <> 0 then
    @SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA');
  if @SHEmptyRecycleBin <> nil then
  begin
    SHEmptyRecycleBin(Application.Handle, nil, SHERB_NOCONFIRMATION or
      SHERB_NOPROGRESSUI or SHERB_NOSOUND);
  end;
  FreeLibrary(LibHandle);
  @SHEmptyRecycleBin := nil;
end;

Create a roll-up form

Problem/Question/Abstract:

How can I create a form that will roll up? That is, a form that when clicked will reduce its height to nothing but the title bar?

Answer:

unit testmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Buttons, ShellAPI;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FOldHeight: Integer;
    procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown);
      message WM_NCRBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FOldHeight := ClientHeight;
end;

procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
var
  I: Integer;
begin
  if (Msg.HitTest = HTCAPTION) then
    if (ClientHeight = 0) then
    begin
      I := 0;
      while (I < FOldHeight) do
      begin
        I := I + 40;
        if (I > FOldHeight) then
          I := FOldHeight;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end
    else
    begin
      FOldHeight := ClientHeight;
      I := ClientHeight;
      while (I > 0) do
      begin
        I := I - 40;
        if (I < 0) then
          I := 0;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end;
end;

end.

First, by way of synopsis, the roll-up/down occurs in response to a WM_NCRBUTTONDOWN message firing off and the WMNCRButtonDown procedure handling the message, telling the window to roll up/down depending upon the height of the client area. WM_NCRBUTTONDOWN fires whenever the right mouse button is clicked in a "non-client" area, such as a border, menu or, for our purposes, the caption bar of a form. (The client area of a window is the area within the border where most of the interesting activity usually occurs. In general, the Windows API restricts application code to drawing only within the client area.)

Delphi encapsulates the WM_NCRBUTTONDOWN in a TWMNCRButtonDown type, which is actually an assignment from a TWMNCHitMessage type that has the following structure:

type
  TWMNCHitMessage = record
    Msg: Cardinal;
    HitTest: Integer;
    XCursor: SmallInt;
    YCursor: SmallInt;
    Result: Longint;
  end;

It's easy to create message wrappers in Delphi to deal with messages that aren't handled by an object by default. Since a right-click on the title bar of a form isn't handled by default, I had to create a wrapper. The procedure procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; is the wrapper I created. All that goes on in the procedure is the following:

In order to make this work, I had to create a variable called FOldHeight and set its value at FormCreate whenever the form was to be rolled up. FOldHeight is used as a place for the form to remember what size it was before it was re-sized to 0. When a form is to be rolled up, FOldHeight is immediately set to the current ClientHeight, which means you can interactively set the form's size, and the function will always return the form's ClientHeight to what it was before you rolled it up.

So what use is this? Well, sometimes I don't want to iconize a window; I just want to get it out of the way so I can see what's underneath. Having the capability to roll a form up to its title bar makes it a lot easier to see underneath a window without iconizing it, then having to Alt-tab back to it. (If you are familiar with the Macintosh platform, the System 7.5 environment offers a very similar facility called a "window shade," and makes a roll-up sound when the shade goes up.)

Copy/paste TStringGrids cells to/from ClipBoard

Problem/Question/Abstract:

How to copy/paste TStringGrids cells to/from ClipBoard

Answer:

uses
  Clipbrd;

Copy  

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  GRect: TGridRect;
  C, R: Integer;
begin
  GRect := StringGrid1.Selection;
  S := '';
  for R := GRect.Top to GRect.Bottom do
  begin
    for C := GRect.Left to GRect.Right do
    begin
      if C = GRect.Right then
        S := S + (StringGrid1.Cells[C, R])
      else
        S := S + StringGrid1.Cells[C, R] + #9;
    end;
    S := S + #13#10;
  end;
  ClipBoard.AsText := S;
end;

Paste

procedure TForm1.Button2Click(Sender: TObject);
var
  Grect: TGridRect;
  S, CS, F: string;
  L, R, C: Byte;
begin
  GRect := StringGrid1.Selection;
  L := GRect.Left;
  R := GRect.Top;
  S := ClipBoard.AsText;
  R := R - 1;
  while Pos(#13, S) > 0 do
  begin
    R := R + 1;
    C := L - 1;
    CS := Copy(S, 1, Pos(#13, S));
    while Pos(#9, CS) > 0 do
    begin
      C := C + 1;
      if (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then
        StringGrid1.Cells[C, R] := Copy(CS, 1, Pos(#9, CS) - 1);
      F := Copy(CS, 1, Pos(#9, CS) - 1);
      Delete(CS, 1, Pos(#9, CS));
    end;
    if (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then
      StringGrid1.Cells[C + 1, R] := Copy(CS, 1, Pos(#13, CS) - 1);
    Delete(S, 1, Pos(#13, S));
    if Copy(S, 1, 1) = #10 then
      Delete(S, 1, 1);
  end;
end;

How to determine the CPU type

Problem/Question/Abstract:

How can I check what type my CPU is? E.g. Pentium (PI, PII, PIII or PIV), AMD (K6, K7, Athlon, ThunderBird), IBM, Cyrix or other CPU's.

Answer:

uses
  Windows;

type
  TProcessor = (NON_INTEL, I_386, I_486, I_PENTIUM, I_PENTIUMPRO,
    I_CELERON, I_PENTIUM2, I_PENTIUM3, I_PENTIUM4);

  {This is for Intel - I haven't tried for AMD etc.}

function GetProcessor: TProcessor;
var
  SI: SYSTEM_INFO;
begin
  Result := NON_INTEL;
  GetSystemInfo(SI);
  if (SI.wProcessorArchitecture = 0) then
  begin
    case (SI.wProcessorLevel and 15) of
      3:
        Result := I_386;
      4:
        Result := I_486;
      5:
        Result := I_PENTIUM;
      6:
        case hi(SI.wProcessorRevision) of
          1: Result := I_PENTIUMPRO;
          3, 5: Result := I_PENTIUM2;
          6: Result := I_CELERON;
          7, 8, 10, 11: Result := I_PENTIUM3;
        end;
      15:
        Result := I_PENTIUM4;
    end;
  end;
end;

Drag items from a TTreeView onto a TListBox

Problem/Question/Abstract:

I have a treeview which I need to be able to drag items from onto a listbox (they have to be deleted from the treeview when moved, of course). I have been able to do this between two listboxes, but this one eludes me. Can anyone get me started please?

Answer:

procedure TForm1.TreeView1MouseDown(Sender: TObject; Button:
  TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if TreeView1.Items.Count = 0 then
    exit;
  if Button = mbLeft then
    TreeView1.BeginDrag(False); {begin drag}
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y:
  Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender = TreeView1);
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  dx: integer;
  Node: TTreeNode;
begin
  if Source = TreeView1 then
  begin
    Node := TreeView1.Selected;
    if Node <> nil then
    begin
      with TListBox(Sender) do
      begin
        dx := ItemAtPos(Point(X, Y), false);
        Items.Insert(dx, Node.Text);
        {or use:
        Items.InsertObject(dx, Node.Text, Pointer(Node.Data)); }
      end;
      Node.Delete;
    end;
  end;
end;

How to determine the screen coordinates of highlighted text in a TRichEdit

Problem/Question/Abstract:

How can I determine the screen coordinates (x, y) of the highlighted text of a TRichEdit component?

Answer:

procedure TForm1.Button3Click(Sender: TObject);
var
  pt: TPoint;
begin
  with richedit1 do
  begin
    pt := point(0, 0);
    Perform(messages.EM_POSFROMCHAR, WPARAM(@pt), selstart);
    {pt is in client coordinates}
    label3.caption := Format('(%d, %d)', [pt.x, pt.y]);
    {convert to screen coordinates}
    pt := ClientToScreen(pt);
    label2.caption := Format('(%d, %d)', [pt.x, pt.y]);
  end;
end;

How to start an instance of an application inside another program

Problem/Question/Abstract:

Is there an easy way to start an instance of an application inside another application so it looks like it's MDI when its not. I have the sub-apps and they need to be able to be run seperately, but I would also like to create an application that runs them inside itself, kind of like Word running Excel.

Answer:

If you want to use the Office model (each application is a OLE document server that can be activated in an OLE container) be prepared for a lot of work. Writing OLE document servers is a major effort and the VCLs ActiveX framework will get you only partways to the goal.

For some reason one can get away with parenting a window in another process to a window in your own, via Windows.SetParent. It will then act somewhat like a child window.

procedure TForm1.Button1Click(Sender: TObject);
var
  wnd: HWND;
begin
  WinExec('notepad.exe', sw_hide);
  Sleep(500);
  wnd := FindWindow('notepad', nil);
  Windows.SetParent(wnd, handle);
  SetWindowPos(wnd, 0, 0, 0, clientwidth, clientheight, SWP_NOZORDER or
    SWP_SHOWWINDOW);
end;

You will probably need to implement some inter-app communication, e.g. based on WM_COPYDATA messages, between your applets. Depending on how far you need to go with the integration that may get you most of the way.

Assign TForm.Icon at run time

Problem/Question/Abstract:

Assign TForm.Icon at run time

Answer:

ImageEdit is not good. Try to get Borland's Resource Workshop or paint with paintbrush and use a freeware converter to convert from BMP to ICO, write a little resource script (*.rc) refering to the ICO file and compile it to *.res with BRCC.EXE (comes with Delphi).

Use {$R xxx.res} to include it. Then you may use the API function

HICON LoadIcon(
  HINSTANCE hInstance, // handle of application instance
  LPCTSTR lpIconName // icon-name string or icon resource identifier
  );


Take this handle (HICON) with the message WM_SETICON to assign it to your form:

SendMessage(Form1.Handle, WM_SETICON, false, iconhandle);

Note: 3rd parameter = icon size (true -> large icon; false -> small icon).

Sorting a TListView by the first or any arbitrary column

Problem/Question/Abstract:

How can I sort the items in a TListView?

Answer:

Sorting by the first column

Sorting a TListView by the first column is easy:

ListView1.SortType := stText;

Setting SortType to stText is more or less like setting Sorted to True in a TListBox object. The list will be sorted and will remain sorted after additions and modifications, until SortType is set back to stNone:

ListView1.SortType := stNone;

It's like setting Sorted to False in a TListBox object. It won't undo the sorting, but future additions and modifications to the items list won't be sorted.

Sorting with an OnCompare event

To have a TListView sorted on another column (or arbitrary data stored or referenced in TListItem objects), we should either write an OnCompare event or an ordering function to be used with the CustomSort method. If you want to sort keep a list sorted while adding and modifying items, then you should use an OnCompare event.

procedure(Sender: TObject; Item1, Item2: TListItem;
  Data: Integer; var Compare: Integer) of object;

The parameter Compare which is passed by reference should be set to 1, -1 or 0 depending on whether the first item is greater than (or should be placed after) the second item, the first item is lower than (or should be placed before) the second item, or if the two items are equal, respectively. In the following example we are sorting a TListView by its fourth column (wich represents integer values) in descending order:

procedure TForm1.ListView1Compare(Sender: TObject; Item1,
  Item2: TListItem; Data: Integer; var Compare: Integer);
var
  n1, n2: integer;
begin
  n1 := StrToInt(Item1.SubItems[2]);
  n2 := StrToInt(Item2.SubItems[2]);
  if n1 > n2 then
    Compare := -1
  else if n1 < n2 then
    Compare := 1
  else
    Compare := 0;
end;

Now that we have an OnCompare event, to sort the list and having sorted, we should set SortType to stBoth (instead of stText, that sorts by the first column without using the OnCompare event):

ListView1.SortType := stBoth;

If you just want to perform a temporal sort, you can do the following:

ListView1.SortType := stBoth;
ListView1.SortType := stNone;

or else:

ListView1.CustomSort(nil, 0);

Sorting with an ordering function

If you need a faster sort, then you should write an ordering function. This function should return 1, -1 or 0 (like the Compare parameter of the OnCompare event discussed above). For example:

function ByFourth(Item1, Item2: TListItem; Data: integer):
  integer; stdcall;
var
  n1, n2: cardinal;
begin
  n1 := StrToInt(Item1.SubItems[2]);
  n2 := StrToInt(Item2.SubItems[2]);
  if n1 > n2 then
    Result := -1
  else if n1 < n2 then
    Result := 1
  else
    Result := 0;
end;

Then, every time you want to sort the list, you call CustomSort passing the address of the ordering function. For example:

ListView1.CustomSort(@ByFourth, 0);

The Data parameter of the OnCompare event is 0 if the event is called automatically when SortType is stData or stBoth, but if it is generated because of a call to CustomSort, then its value is the second parameter to this method. The same happens with the Data parameter of the ordering function, so the Data parameter is normally
used to specify a column to sort (we didn't use it in our example to make it simple).

Source Example

var
  Ascending: boolean;

function SortByColumn(Item1, Item2: TListItem; Data: integer):
  integer; stdcall;
// Copyright (c) 2001 Ernesto D'Spirito
// edspirito@latiumsoftware.com
// http://www.latiumsoftware.com
begin
  if Data = 0 then
    Result := AnsiCompareText(Item1.Caption, Item2.Caption)
  else
    Result := AnsiCompareText(Item1.SubItems[Data - 1],
      Item2.SubItems[Data - 1]);
  if Result < 0 then
  begin
    if Ascending then
      Result := -1
    else
      Result := 1;
  end
  else if Result > 0 then
  begin
    if Ascending then
      Result := 1
    else
      Result := -1;
  end;
end;

procedure TForm1.ListView1ColumnClick(Sender: TObject;
  Column: TListColumn);
begin
  // Toggle column Tag
  Column.Tag := 1 - Column.Tag; // 0 -> 1  ;  1 -> 0
  // Determine sort order based on the value of the Tag
  Ascending := Column.Tag = 1;
  // Perform the sort
  TListView(Sender).CustomSort(@SortByColumn, Column.Index);
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

Adding my own resource file: error "Duplicate Resource"

Problem/Question/Abstract:

When I try to add a resource to my project's .res file, I get a "Duplicate Resource" error when linking. The resource I have added is a unique resource.

Answer:

The projects resource file is generated by the IDE wizard, and is not intended to be modified. To add additional resources to your project, create a separate resource file with a unique name that does not conflict with either the project or any of the unit names, e.g. "MyRes.Res". Then to add the resource file to Delphi, simply add the following line to any unit file in the project:

{$R MyRes.Res}

Reading and Writing System-Wide Environment Variables

Problem/Question/Abstract:

How do you set an environment variable that will apply outside the process that set the variable or those spawned by it?

Answer:

On Windows 2000, if you open the control panel and double click on the system icon, the system properties dialog box will open.  On the "Advanced" tab, you can click the "Environment Variables" tab to see a list of the user and system environment variables. The procedures and functions below allow you to read and write those variables.

It is worth mentioning that you can also use "GetEnvironmentVariable" and "SetEnvironmentVariable" to read and write environment variables.  However, if you set and environment variable with "SetEnvironmentVariable", the value you set applies only to the process that called "SetEnvironmentVariable" or are spawned by it.

The first two procedures read and write environment variables for the current user.

function GetUserEnvironmentVariable(const name: string): string;
var
  rv: DWORD;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    OpenKey('Environment', False);
    result := ReadString(name);
    SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
      (PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
  finally
    Free
  end
end;

procedure SetUserEnvironmentVariable(const name, value: string);
var
  rv: DWORD;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    OpenKey('Environment', False);
    WriteString(name, value);
    SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
      (PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
  finally
    Free
  end
end;

The next two procedures read and write environment variables for the system and thus
  affect all users.

function GetSystemEnvironmentVariable(const name: string): string;
var
  rv: DWORD;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('SYSTEM\CurrentControlSet\Control\Session ' +
      'Manager\Environment', False);
    result := ReadString(name);
    SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
      (PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
  finally
    Free
  end
end;

// Modified from
// http://www.delphiabc.com/TipNo.asp?ID=117
// The original article did not include the space in
// "Session Manager" which caused the procedure to fail.

procedure SetSystemEnvironmentVariable(const name, value: string);
var
  rv: DWORD;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('SYSTEM\CurrentControlSet\Control\Session ' +
      'Manager\Environment', False);
    WriteString(name, value);
    SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
      (PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
  finally
    Free
  end
end;

How to create a vertical progress bar and fill it from top to bottom

Problem/Question/Abstract:

Is it possible for the position parameter to fill a vertically orientated ProgressBar going down (rather than starting from its bottom and going up)? I want to indicate negative values. Ideal would be Min = -negative value and Max = +positive value with zero position in center and the fill would start from zero center and go either up or down depending on value.

Answer:

Here's one with that capability:

unit W95meter;

{This component is a Windows 95 style progress meter.  It is free and donated to
the public domain. I do claim copyright of this code and I hereby prohibit the sale of the source or compiled code to anyone for any amount.

Modified 11/29/00 by Eddie Shipman

1. Added Direction Property to allow reverse fills.

Modified 10/15/97 by Eddie Shipman

1. Added a Max Value so Values over 100 can be used

2. Fixed the Invalidation of the control after properties are changed.

Modified 12/22/95 by John Newlin

1. Caught by Larry E. Tanner 70242,27.  Decreasing the Value of the Percent property
    would fail to clear the higher segments. Fixed.

2. Setting the EdgeStyle propety to St95None would not eliminate painting the edge outline. Fixed.

by John Newlin CIS 71535,665}

interface

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Controls, Forms, Menus, Graphics, Dialogs;

type
  StyleType = (st95None, st95Lowered, st95Raised);
  TDirection = (dirForward, dirReverse);
  TW95Meter = class(TGraphicControl)
  private
    FAlign: TAlign;
    FPercent: Integer;
    FBackColor: TColor;
    FSegColor: TColor;
    FSegWidth: Integer;
    FSegGap: Integer;
    FMax: Integer;
    FEdgeStyle: StyleType;
    FDirection: TDirection;
    procedure Initialize;
    procedure SetPercent(Value: Integer);
    procedure SetAlign(Value: TAlign);
    procedure SetBackColor(Value: TColor);
    procedure SetDirection(Value: TDirection);
    procedure SetSegColor(Value: TColor);
    procedure SetSegWidth(Value: Integer);
    procedure SetSegGap(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetStyle(Value: StyleType);
  protected
    procedure UpdateProgress;
    procedure Paint; override;
    procedure AdjustSize; dynamic;
    procedure RequestAlign; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    property Canvas;
    function IntPercent(High, Low: Longint): Integer;
    function RealPercent(High, Low: real): Integer;
  published
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Cursor;
    property Align: TAlign read FAlign write SetAlign default alNone;
    property Direction: TDirection read FDirection write SetDirection default dirForward;
    property EdgeStyle: StyleType read FEdgeStyle write SetStyle default st95Lowered;
    property SegmentGap: Integer read FSegGap write SetSegGap default 2;
    property SegmentWidth: Integer read FSegWidth write SetSegWidth default 8;
    property SegmentColor: TColor read FSegColor write SetSegColor default clActiveCaption;
    property BackGroundColor: TColor read FBackColor write SetBackColor default clBtnFace;
    property Percent: Integer read FPercent write SetPercent default 0;
    property Max: Integer read FMax write SetMax default 100;
    property Width default 100;
    property Height default 18;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Win32', [TW95Meter]);
end;

procedure TW95Meter.SetSegWidth(Value: Integer);
begin
  if (Value > 0) and (Value <> FSegWidth) then
  begin
    FSegWidth := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetMax(Value: Integer);
begin
  if Value <> FMax then
  begin
    FMax := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetSegGap(Value: Integer);
begin
  if (Value > 0) and (Value <> FSegGap) then
  begin
    FSegGap := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetBackColor(Value: TColor);
begin
  if FBackColor <> Value then
  begin
    FBackColor := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetSegColor(Value: TColor);
begin
  if FSegColor <> Value then
  begin
    FSegColor := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetPercent(Value: Integer);
var
  bRefresh: boolean;
begin
  if Value <> FPercent then
  begin
    if FPercent > Value then
      bRefresh := true
    else
      bRefresh := false;
    FPercent := Value;
    if (Fpercent = 0) or (bRefresh = true) or (csDesigning in ComponentState) then
      Invalidate;
    UpdateProgress;
  end;
end;

procedure TW95Meter.SetStyle(Value: StyleType);
begin
  if Value <> FEdgeStyle then
  begin
    FEdgeStyle := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.Initialize;
begin
  Width := 100;
  Height := 18;
  FPercent := 0;
  FBackColor := clBtnFace;
  FSegColor := clActiveCaption;
  FSegWidth := 8;
  FSegGap := 2;
  FEdgeStyle := st95Lowered;
  FMax := 100;
  FDirection := dirForward;
end;

constructor TW95Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Initialize;
end;

procedure TW95Meter.UpdateProgress;
var
  x1, y1, x2, y2, max: Integer;
  bg: TColor;

  procedure DoHorizontalF;
  var
    i: Integer;
  begin
    x1 := 4;
    x2 := x1 + FSegWidth;
    y1 := 4;
    y2 := Height - 4;
    max := Width div (FSegWidth + FSegGap);
    Max := round(max * (FPerCent / FMax));
    for i := 1 to Max do
    begin
      with canvas do
      begin
        if x2 <= width - 4 then
          Rectangle(x1, y1, x2, y2);
        x1 := x1 + FSegWidth + FSegGap;
        x2 := x1 + FSegWidth;
      end;
    end;
  end;

  procedure DoVerticalF;
  var
    i, h: Integer;
  begin
    h := height;
    x1 := 4;
    x2 := Width - 4;
    y1 := Height - (FSegWidth + 4);
    y2 := Height - 4;
    max := Height div (FSegWidth + FSegGap);
    max := round(max * (FPercent / FMax));
    for i := 1 to max do
    begin
      with canvas do
      begin
        if y1 >= 4 then
          Rectangle(x1, y1, x2, y2);
        y1 := y1 - (FSegWidth + FSegGap);
        y2 := y1 + FsegWidth;
      end;
    end;
  end;

  procedure DoHorizontalR;
  var
    i: Integer;
  begin
    x1 := Width - 4;
    x2 := x1 - FSegWidth;
    y1 := 4;
    y2 := Height - 4;
    max := Width div (FSegWidth + FSegGap);
    Max := round(max * (FPerCent / FMax));
    for i := 1 to Max do
    begin
      with canvas do
      begin
        if x2 <= width - 4 then
          Rectangle(x1, y1, x2, y2);
        x1 := x1 - FSegWidth - FSegGap;
        x2 := x1 - FSegWidth;
      end;
    end;
  end;

  procedure DoVerticalR;
  var
    i: Integer;
  begin
    x1 := 4;
    x2 := Width - 4;
    y1 := 4;
    y2 := 4 + FSegWidth;
    max := Height div (FSegWidth + FSegGap);
    max := round(max * (FPercent / FMax));
    for i := 1 to max do
    begin
      with canvas do
      begin
        if y1 >= 4 then
          Rectangle(x1, y1, x2, y2);
        y1 := y1 + (FSegWidth + FSegGap);
        y2 := y1 + FSegWidth;
      end;
    end;
  end;

begin
  canvas.pen.color := FSegColor;
  canvas.brush.color := FsegColor;
  case FDirection of
    dirForward:
      begin
        if Width > Height then
          DoHorizontalF
        else
          DoVerticalF;
      end;
    dirReverse:
      begin
        if Width > Height then
          DoHorizontalR
        else
          DoVerticalR;
      end;
  end;
end;

procedure TW95Meter.Paint;
begin
  with Canvas do
  begin
    Brush.Color := FBackColor;
    if FEdgeStyle = st95none then
    begin
      Pen.Width := 0;
      Pen.Color := FBackColor;
      Rectangle(0, 0, width, height);
      if FPercent > 0 then
        UpdateProgress;
      exit;
    end;
    pen.Width := 2;
    if FEdgeStyle = st95Lowered then
      pen.color := clgray
    else
      pen.color := clWhite;
    moveto(0, height);
    lineto(0, 0);
    lineto(width - 1, 0);
    if FEdgeStyle = st95Lowered then
      pen.color := clWhite
    else
      pen.color := clGray;
    lineto(width - 1, height - 1);
    lineto(0, height - 1);
    Pen.Width := 0;
    Brush.Color := FBackColor;
    Pen.Color := FBackColor;
    Rectangle(1, 1, Width - 1, Height - 1);
    if FPercent > 0 then
      UpdateProgress;
  end;
end;

function TW95Meter.RealPercent(High, Low: Real): Integer;
begin
  result := 0;
  if High = 0.0 then
    exit;
  Result := Round((Low / High) * FMax);
end;

function TW95Meter.IntPercent(High, Low: Longint): Integer;
begin
  result := 0;
  if High = 0 then
    exit;
  Result := Round((low / high) * FMax);
end;

procedure TW95Meter.SetAlign(Value: TAlign);
var
  OldAlign: TAlign;
begin
  if FAlign <> Value then
  begin
    OldAlign := FAlign;
    FAlign := Value;
    if not (csLoading in ComponentState) and (not (csDesigning in ComponentState) or
      (Parent <> nil)) then
      if ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
        not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then
        SetBounds(Left, Top, Height, Width)
      else
        AdjustSize;
  end;
end;

procedure TW95Meter.AdjustSize;
begin
  if not (csLoading in ComponentState) then
    SetBounds(Left, Top, Width, Height);
end;

procedure TW95Meter.RequestAlign;
begin
  { if Parent <> nil then Parent.AlignControl(Self); }
end;

procedure TW95Meter.SetDirection(Value: TDirection);
begin
  if Value <> FDirection then
  begin
    FDirection := Value;
    Invalidate;
  end;
end;

end.