Search for a keyword in a help file

Problem/Question/Abstract:

How to search for a keyword in a help file

Answer:

const
  EmptyString: PChar = '';
begin
  Application.HelpCommand(HELP_PARTIALKEY, LongInt(EmptyString));
end;

Generic File Importer Base Class

Problem/Question/Abstract:

Here is a useful base class to create derived classes to import data from any flat file format you can think of...

Answer:

{-----------------------------------------------------------------------------
Unit Name:     classParentDataManipulator
Author:        StewartM (Stewart Moss)

Documentation Date: 23, 08, 2002  (14:39,)

Version 1.0
-----------------------------------------------------------------------------

Compiler Directives:

Purpose:

Dependancies:

Description:

Parent Class for data manipulation
Creates the basic skelton for adding data manipulation sub-classes

Each of the inherited classes must override the ProcessData method and provide
  their own properties specific to the class (ie Invoice Number etc...)

Very useful class.

inheritance Diagram

  + -- TParentDataProcessor    // base class
       +
       |
       + --- TDerivedImporter  // sub class

Notes:

History:

Copyright 2002 by Stewart Moss.
All rights reserved.
-----------------------------------------------------------------------------}

unit classParentDataManipulator;

interface

uses Sysutils, Classes;

type
  TParentDataProcessor = class(TObject)
  private
    StringIn: string;
    LineCounter: Integer;

  public
    FieldNames,
      FieldValues,
      MultiFieldNames,
      MultiFieldValues: TStringList;

    FormName,
      FileName: string;
    Delimiters: string;
    // A list of delimiters (ie ',/[];:') used in inherited ProcessData()

    constructor create;
    destructor Destroy; override;
    procedure ProcessFile;

    function DataAtPos(S: string; StartP, EndP: Integer): string;
    // Returns the data from "StartP" to "EndP" in String "S"

    function ExpandTabs(s: string): string;
    // ExpandTabs to 8 Spaces

    procedure ProcessData(StrIn: string; LineNumber: Integer); virtual;
    // Virtual method for override in sub-classes

    procedure FieldAdd(FieldName, Data: string; GenException: Boolean);
    // Adds FieldName and FieldValue to Strings and can generate exception if
    // string is empty when required

    procedure MultiFieldAdd(FieldName, Data: string; GenException: Boolean);
    // Adds FieldName and FieldValue to Multi Field Strings and can generate exception
    // if string is empty when required

  end;

  TProcessException = Exception;

implementation

var
  F: text;
  //  Exception: TProcessException;

  { TDataProcessor }

constructor TParentDataProcessor.create;
begin
  inherited create;
  FieldNames := TStringList.Create;
  FieldValues := TStringList.Create;
  MultiFieldNames := TStringList.Create;
  MultiFieldValues := TStringList.Create;
  FieldNames.Clear;
  FieldValues.Clear;
  MultiFieldNames.Clear;
  MultiFieldValues.Clear;
end;

procedure TParentDataProcessor.ProcessFile;
begin
  if Filename = '' then
    raise Exception.Create('No Filename specified');

  try
    AssignFile(F, Filename);
    Reset(f);
  except
    try
      CloseFile(F);
    except
    end;
    raise Exception.Create('Could not open file ' + FileName);
  end;

  LineCounter := 0;

  while not eof(f) do
  begin
    Inc(LineCounter);

    try
      Readln(f, StringIn);
    except
      try
        CloseFile(f);
      except // swallow CloseFile errors
      end;

      raise Exception.Create('Could not read from file. Line number ' +
        IntToStr(LineCounter));
    end;

    StringIn := ExpandTabs(StringIn);
    // Exapnd Tabs to 8 Spaces

    ProcessData(StringIn, LineCounter);
    // Execute virutal method in sub-classes passing current line and LineNumber
  end;

  try
    closefile(f);
  except
    raise Exception.Create('Could not close file ' + FileName);
  end;
end;

procedure TParentDataProcessor.ProcessData(StrIn: string; LineNumber: Integer);
// Virtual method for override in sub-classes
begin
  //
end;

destructor TParentDataProcessor.Destroy;
begin
  FieldNames.Free;
  FieldValues.Free;
  MultiFieldNames.Free;
  MultiFieldValues.Free;
end;

function TParentDataProcessor.DataAtPos(S: string; StartP,
  EndP: Integer): string;
begin
  // Returns the data from "StartP" to "EndP" in String "S"
  Result := trim(Copy(S, StartP, EndP - StartP));
end;

function TParentDataProcessor.ExpandTabs(s: string): string;
begin
  // ExpandTabs to 8 Spaces
  Result := StringReplace(S, #09, '        ', [rfReplaceAll]);
end;

procedure TParentDataProcessor.FieldAdd(FieldName, Data: string;
  GenException: Boolean);
begin
  // Adds FieldName and FieldValue to Strings and can generate exception if
  // string is empty
  if (GenException) and (Data = '') then
    raise Exception.create('-- No ' + FieldName + ' Specified --');
  Fieldnames.add(FieldName);
  FieldValues.add(Data);
end;

procedure TParentDataProcessor.MultiFieldAdd(FieldName, Data: string;
  GenException: Boolean);

var
  loop: integer;
  flag: Boolean;
begin
  // Adds FieldName and FieldValue to Multi Field Strings and can generate exception
  // if string is empty

  if (GenException) and (Data = '') then
    raise Exception.create('-- No Multiple Field - ' + FieldName + ' Specified --');

  flag := false;
  loop := 0;
  while (loop < MultiFieldNames.count) and not flag do
  begin
    if MultiFieldNames.Strings[loop] = FieldName then
      flag := true;
    inc(Loop);
  end;

  dec(loop);

  if Flag then
    MultiFieldValues.Strings[loop] := MultiFieldValues.Strings[loop] + ';' + Data
  else
  begin
    MultiFieldNames.add(FieldName);
    MultiFieldValues.add(Data);
  end;
end;

end.

How to give the scrollbars of a TRichEdit a flat look

Problem/Question/Abstract:

Does anyone know of a way to change the scroll bars in the RichEdit to obtain the flat look?

Answer:

Start with this one and do not forget to put CommCtrl in your uses clause:

procedure TForm1.FormCreate(Sender: TObject);
var
  XVerScrollInfo, XHorScrollInfo: TScrollInfo;
begin
  InitializeFlatSB(RichEdit1.Handle);
  GetScrollInfo(RichEdit1.Handle, SB_VERT, XVerScrollInfo);
  GetScrollInfo(RichEdit1.Handle, SB_HORZ, XHorScrollInfo);
  FlatSB_SetScrollProp(RichEdit1.Handle, WSB_PROP_VSTYLE, FSB_ENCARTA_MODE, True);
  FlatSB_SetScrollProp(RichEdit1.Handle, WSB_PROP_HSTYLE, FSB_ENCARTA_MODE, True);
end;

Easily use HTML Help files in your programs

Problem/Question/Abstract:

Do you long to move from WinHelp to HTML Help in your programs? The unit below converts all WinHelp calls to HTML Help enabling you to upgrade with the minimum of effort.

Answer:

Save this unit to a directory on your Environment Options|Library|Library Path and add to your project uses clause, all WinHelp requests will now be translated to HTML Help. Specify your *.chm file in the Project Options|Application|Help file setting. Context sensitive help will work as normal, use TApplication.HelpCommand to send help commands. eg. Application.HelpCommand(HELP_KEY, DWORD(keyData))

unit dmHTMLHelp;
{Unit to translate WinHelp requests into HTML Help and call the API.}
{Written by Dave Murray, October 2001. dmurray@worldmark.com}
{NOTES:
This unit assigns its own handler to the Application.OnHelp event.
DO NOT assign your own handler to Application.OnHelp.
Also, this unit ignores any form's HelpFile property. (Delphi 4+)}

interface

uses
  Windows, Messages, SysUtils, Forms;

const
  {commands to pass to HtmlHelp(), see HTML Help API Reference}
  HH_DISPLAY_TOPIC = $0000; {open help topic}
  HH_HELP_FINDER = $0000; {backwards compatibility,use HH_DISPLAY_TOPIC instead}
  HH_DISPLAY_TOC = $0001; {select Contents tab in nav pane}
  HH_DISPLAY_INDEX = $0002; {select Index tab + search for keyword}
  HH_DISPLAY_SEARCH = $0003; {select Search tab in nav pane}
  HH_SET_WIN_TYPE = $0004;
  HH_GET_WIN_TYPE = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_ENUM_INFO_TYPE = $0007;
  HH_SET_INFO_TYPE = $0008;
  HH_SYNC = $0009;
  HH_RESERVED1 = $000A; {not currently implemented}
  HH_RESERVED2 = $000B; {not currently implemented}
  HH_RESERVED3 = $000C; {not currently implemented}
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E; {display string resource/text in a popup}
  HH_HELP_CONTEXT = $000F; {display topic for context number}
  HH_TP_HELP_CONTEXTMENU = $0010; {text popup help, same as HELP_CONTEXTMENU}
  HH_TP_HELP_WM_HELP = $0011; {text popup help, same as HELP_WM_HELP}
  HH_CLOSE_ALL = $0012; {close all windows opened by caller}
  HH_ALINK_LOOKUP = $0013; {ALink version of HH_KEYWORD_LOOKUP}
  HH_GET_LAST_ERROR = $0014; {not currently implemented}
  HH_ENUM_CATEGORY = $0015;
  HH_ENUM_CATEGORY_IT = $0016;
  HH_RESET_IT_FILTER = $0017;
  HH_SET_INCLUSIVE_FILTER = $0018;
  HH_SET_EXCLUSIVE_FILTER = $0019;
  HH_INITIALIZE = $001C;
  HH_UNINITIALIZE = $001D;
  HH_PRETRANSLATEMESSAGE = $00FD;
  HH_SET_GLOBAL_PROPERTY = $00FC;

function HtmlHelp(hwndCaller: THandle; pszFile: PChar; uCommand: cardinal; dwData:
  longint): THandle; stdcall;

implementation

function HtmlHelp(hwndCaller: THandle; pszFile: PChar; uCommand: cardinal; dwData:
  longint): THandle; stdcall; external 'hhctrl.ocx' name 'HtmlHelpA'; {external API call}

type
  TdmHTMLHelp = class(TObject) {encapsulates function}
    function ApplicationHelp(Command: Word; Data: Longint; var CallHelp: Boolean):
      Boolean;
  end; {TdmHTMLHelp..}

function TdmHTMLHelp.ApplicationHelp(Command: Word; Data: Longint; var CallHelp:
  Boolean): Boolean;
{translates WinHelp commands to HTMLHelp commands + calls API}
var
  HCommand: word;
begin
  {make sure VCL doesn't activate WinHelp + function succeeds}
  CallHelp := false;
  result := true;
  {translate WinHelp > HTMLHelp}
  case Command of
    HELP_CONTENTS:
      begin
        HCommand := HH_DISPLAY_TOC;
        Data := 0;
      end; {HELP_CONTENTS..}
    HELP_CONTEXT: HCommand := HH_HELP_CONTEXT;
    HELP_CONTEXTPOPUP: HCommand := HH_HELP_CONTEXT;
    HELP_FINDER: HCommand := HH_DISPLAY_TOPIC;
    HELP_KEY: HCommand := HH_DISPLAY_INDEX;
    HELP_QUIT:
      begin
        HCommand := HH_CLOSE_ALL;
        Data := 0;
      end; {HELP_QUIT..}
  else
    begin {default}
      HCommand := HH_DISPLAY_TOPIC;
      Data := 0;
    end; {default..}
  end; {case Command..}
  {call HTML Help API}
  HtmlHelp(Application.MainForm.Handle, PChar(Application.HelpFile), HCommand, Data);
end; {function TdmHTMLHelp.ApplicationHelp}

var
  HTMLHelper: TdmHTMLHelp;

initialization
  {create object + assign event handler}
  HTMLHelper := TdmHTMLHelp.Create;
  Application.OnHelp := HTMLHelper.ApplicationHelp;
finalization
  {free event handler + object}
  Application.OnHelp := nil;
  HTMLHelper.Free;
end.

Two ways to change the default project options

Problem/Question/Abstract:

Two ways to change the default project options

Answer:

You can change the default project options (which is being used by every new project you create) from Delphi GUI:

Create a new project (File | New Application)
Go to "Project | Options" and change the options as you wish.
Check "Default" checkbox in the tabs which you changed options in.

If you rather change the options "manually," you can do so using a simple text editor:

Edit defproj.dof file located in your Delphi's BIN directory (C:\Program Files\Borland\Delphi 2.0\Bin for example) using Notepad or any other text editor. If you don't see the defproj.dof, create one using your favorite text editor in the Delphi's BIN directory using the following format:

[Compiler]
A=1
B=0
C=0
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=0
Z=1
ShowHints=0
ShowWarnings=0
UnitAliases=WinTypes=Windows;<cont.>
WinProcs=Windows;DbiTypes=BDE;<cont.>
DbiProcs=BDE;DbiErrs=BDE;

[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=

[Directories]
OutputDir=
SearchPath=
Conditionals=

[Parameters]
RunParams=

How to display a help file on top of a form with style fsStayOnTop

Problem/Question/Abstract:

I have a form with its formstyle set to fsStayOnTop. If I display the help for this form, the help windows is opened behind my form. Even if I click on the help window it stays behind. How can I display the help windows in front of any form?

Answer:

You can do this by sending a macro to WinHelp.


procedure TForm1.Button1Click(Sender: TObject);
begin
  with Application do
  begin
    Helpfile := 'C:\Programme\Borland\Delphi5\Help\TOOLS\HCW.HLP';
    HelpCommand(HELP_CONTENTS, 0);
    HelpCommand(HELP_COMMAND, Integer(PChar('Generate(' + IntToStr(WM_COMMAND)
      + ', 1471, 0)')));
  end;
end;


This macro call fakes a menu action for the "keep on top" menu item. Use 1472 to deactivate the on top state. Help macros are documented in the helpfile I used above. The HelpOnTop macro gives the menu IDs to use for Generate in this case. HelponTop itself may be useful if you simply want to change the current on-top default for the window (it is a toggle).

How to make a TButton flee from the mouse cursor

Problem/Question/Abstract:

As a joke, I am trying to have a button on a form move around the form to avoid the mouse pointer. I was trying to use the OnMouseMove event of the form to accomplish this, but have not had any success. Does anybody know a quick way of doing this?

Answer:

procedure TMainForm.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  NewPoint: TPoint;
begin
  Randomize;
  NewPoint.X := X;
  NewPoint.Y := Y;
  repeat
    NewPoint.X := NewPoint.X + Random((Sender as TButton).Width div 2);
    NewPoint.Y := NewPoint.Y + Random((Sender as TButton).Height div 2);
  until
    PtInRect(ClientRect, NewPoint) and not PtInRect((Sender as TButton).ClientRect, NewPoint);
  (Sender as TButton).Left := NewPoint.X;
  (Sender as TButton).Top := NewPoint.Y;
end;

How to store several bitmaps into a single file

Problem/Question/Abstract:

Is there a simple way to write a TBitmap object to a file and read it back? I want to store bitmaps and other data all in one file (much like word processors are capable of doing).

Answer:

If you wish to store multiple things into a file, you'll need to implement some sort of file structure so you can know what and where things are in the file. For example, if you wished to store several bitmaps to a file, you could structure your file like this:

file header
bitmap count

bitmap header
bitmap size
bitmap stream
bitmap trailer
...

file trailer

Where "file header" contains information such as the version of the file and a unique file structure identifier, "bitmap count" is the number of bitmaps saved to the file, "bitmap header" is a unique identifier which indicates the start of a bitmap entry in the file, "bitmap size" is the size of the bitmap stream, "bitmap stream" is the bitmap's stream (from SaveToStream), "bitmap trailer" is a trailer identifier which indicates the end of the bitmap entry, and "file trailer" is a unique identifier which indicates the end of the file, and optionally contains the size of the file and a CRC of the file (for error detection). Of course, you'd iterate the "bitmap header"..."bitmap trailer" structure once per bitmap saved to the file.

You can use a TFileStream to read / write this structure. You'll need to write a number of methods which read and interpret each section. You'll also want to create a TBitmap instance each time you encounter a "bitmap header" structure. Here's a quick example of how to implement the "bitmap header"..."bitmap trailer" section:

const
  BITMAP_HEADER = 100;
  BITMAP_TRAILER = 200;

procedure SaveBitmap(Bitmap: TBitmap; Stream: TStream);
var
  Buffer: TMemoryStream;
  Identifier: LongInt;
  Size: LongInt;
begin
  Buffer := TMemoryStream.Create;
  try
    Bitmap.SaveToStream(Buffer);
    Identifier := BITMAP_HEADER;
    Stream.Write(Identifier, SizeOf(Identifier));
    Size := Buffer.Size;
    Stream.Write(Size, SizeOf(Size));
    Buffer.Position := 0;
    Stream.CopyFrom(Buffer, Size);
    Identifier := BITMAP_TRAILER;
    Stream.Write(Identifier, SizeOf(Identifier));
  finally
    Buffer.Free;
  end;
end;

procedure ReadBitmap(Bitmap: TBitmap; Stream: TStream);
var
  Buffer: TMemoryStream;
  Identifier: LongInt;
  Size: LongInt;
begin
  Buffer := TMemoryStream.Create;
  try
    Stream.Read(Identifier, SizeOf(Identifier));
    if Identifier <> BITMAP_HEADER then
      raise Exception.Create('Bitmap header expected');
    Stream.Read(Size, SizeOf(Size));
    Buffer.CopyFrom(Stream, Size);
    Bitmap.LoadFromStream(Buffer);
    Stream.Read(Identifier, SizeOf(Identifier));
    if Identifier <> BITMAP_TRAILER then
      raise Exception.Create('Bitmap trailer expected');
  finally
    Buffer.Free;
  end;
end;

Of course, you'll need to write other methods to read the other file sections, and you'll need to call ReadBitmap the correct number of times (specified in "bitmap count") with a TBitmap instance.

Simple HTML parsing and painting

Problem/Question/Abstract:

How to do simple HTML parsing and painting

Answer:

This morning a friend asked me how to do a simple HTML parsing. He wanted to implement a hint box with formatting possibilities.

So I developed a very simple procedure which draws the contents of a string to a rectangle on a canvas. It only understands the HTML tags b, i and u, and it moves to the next line when it finds a new line code. (This is not HTML conform, but in this case really useful)

The parsing itself is extremely simple, but you need to work  with pointers and not with strings since they make it more difficult to get each individual character.

The following procedure is just a little example. If you need HTML editing/painting please try out WPTools.

// Draw simple HTML text to any canvas
// 3/16/2000 by Julian Ziersch, http://www.ziersch.com/
// Products: WPTools, WPReporter, WPForm
// wPDF: PDF Export for WPTools

procedure DrawHTML(r: TRect; aCanvas: TCanvas; const text: string);
var
  p: PChar;
  c: Char;
  x, y, w, wc, hc: Integer;
  code: string;
begin
  p := PChar(text);
  x := r.Left;
  y := r.Top;
  hc := aCanvas.TextHeight('Ag');
  if p <> nil then
    while p^ <> #0 do
    begin
      c := p^;
      if c = '<' then
      begin
        code := '';
        inc(p);
        while (p^ <> '>') and (p^ <> #0) do
        begin
          code := code + uppercase(p^);
          inc(p);
        end;
        if code = 'B' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsBold]
        else if code = 'I' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsItalic]
        else if code = 'U' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsUnderline]
        else if code = '/B' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsBold]
        else if code = '/I' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsItalic]
        else if code = '/U' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsUnderline];
      end
      else if c = #10 then
      begin
        x := r.Left;
        inc(y, hc);
      end
      else if c >= #32 then
      begin
        wc := aCanvas.TextWidth(c);
        if x + wc > r.Right then
        begin
          x := r.Left;
          inc(y, hc);
        end;
        if y + hc < r.Bottom then
          aCanvas.TextOut(x, y, c);
        inc(x, wc);
      end;
      if p^ > #0 then
        inc(p);
    end;
end;

How to use the Win95 Help (What's this?) button

Problem/Question/Abstract:

How to use the Win95 Help (What's this?) button

Answer:

The help button is supposed to be used only with dialogs, Borderstyle := bsDialog. This is a Microsoft thingy, for a main window you are supposed to provide either a menu item or a speedbutton that does a SendMessage(windowhandle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0) to get the window into the context help mode.

The help button is only available if biMinimize and biMaximize is not set. Furthermore, sometimes you have to override the CreateParams method and set the style accordingly.


interface

type
  TfrmMain = class(TForm)
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

implementation

procedure TfrmMain.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or DS_CONTEXTHELP;
  Params.ExStyle := Params.ExStyle or WS_EX_CONTEXTHELP;
end;

How to create a non-rectangular TPanel

Problem/Question/Abstract:

How to create a non-rectangular TPanel

Answer:

unit ShapedPanel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls;

type
  TShapedPanel = class(TCustomControl)
  private
    { Private declarations }
    FBorderColor: TColor;
    IsLoaded: Boolean;
    FBorderWidth: Integer;
    FRgn, FRgn2: HRGN;
    RgnBrush: TBrush;
    FFIlLColor: TColor;
    procedure SetFillColor(const Value: TColor);
    function GetFillColor: TColor;
    procedure MakeRegion;
    procedure SetBorderColor(Value: TColor);
    procedure WMSize(var Message: TMessage); message WM_SIZE;
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure CreateWnd; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
    property BorderWidth: Integer read FBorderWidth write FBorderWidth default 2;
    property FillColor: TColor read GetFillColor write SetFillColor;
    property Height default 200;
    property Width default 200;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnEndDock;
    property OnEndDrag;

    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EXS', [TShapedPanel]);
end;

constructor TShapedPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks];
  Width := 200;
  Height := 200;
  RgnBrush := TBrush.Create;
  RgnBrush.Color := clBlack;
  FFillColor := clWhite;
  IsLoaded := False;
  FBorderWidth := 2;
  FBorderColor := clBlack;
  FRgn := 0;
  FRgn2 := 0;
end;

destructor TShapedPanel.Destroy;
begin
  DeleteObject(FRgn);
  DeleteObject(FRgn2);
  inherited;
end;

procedure TShapedPanel.CreateWnd;
begin
  inherited;
  MakeRegion;
  IsLoaded := True;
  {IsLoaded is to make sure MakeRegion is not called before there is a
  Handle for this control, but it may not be nessary}
end;

procedure TShapedPanel.MakeRegion;
var
  x4, y2: Integer;
  FPoints: array[0..5] of TPoint;
begin
  {I moved the Region creation to this procedure so it can be called for WM_SIZE}
  SetWindowRgn(Handle, 0, False);
  {this clears the window region}
  if FRgn <> 0 then
  begin
    {Make sure to Always DeleteObject for a Region}
    DeleteObject(FRgn);
    DeleteObject(FRgn2);
    FRgn := 0;
    FRgn2 := 0;
  end;
  x4 := Width div 4;
  y2 := Height div 2;
  FPoints[0] := Point(x4, 0);
  FPoints[1] := Point(Width - x4, 0);
  FPoints[2] := Point(Width, y2);
  FPoints[3] := Point(Width - x4, Height);
  FPoints[4] := Point(x4, Height);
  FPoints[5] := Point(0, y2);
  FRgn := CreatePolygonRgn(FPoints, 6, WINDING);
  SetWindowRGN(Handle, FRgn, True);
  FRgn2 := CreatePolygonRgn(FPoints, 6, WINDING);
  {FRgn2 is used for FrameRgn in Paint}
end;

procedure TShapedPanel.WMSize(var Message: TMessage);
var
  TmpClr: TColor;
begin
  inherited;
  if IsLoaded then
  begin
    TmpClr := Canvas.Brush.Color;
    Canvas.Brush.Color := FFillColor;
    MakeRegion;
    FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
    Paint;
    Canvas.Brush.Color := TmpClr;
  end;
end;

procedure TShapedPanel.Paint;
var
  TmpClr: TColor;
begin
  inherited;
  if IsLoaded then
  begin
    TmpClr := Canvas.Brush.Color;
    Canvas.Brush.Color := FFillColor;
    MakeRegion;
    FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
    FrameRgn(Canvas.Handle, FRgn2, RgnBrush.Handle, FBorderWidth, FBorderWidth);
    Canvas.Brush.Color := TmpClr;
  end;
end;

procedure TShapedPanel.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    RgnBrush.Color := FBorderColor;
    Paint;
  end;
end;

procedure TShapedPanel.SetFillColor(const Value: TColor);
begin
  if FFillColor <> Value then
  begin
    FFillColor := Value;
    Paint;
  end
end;

function TShapedPanel.GetFillColor: TColor;
begin
  Result := FFillColor;
end;

end.

How to randomly select records from a TTable

Problem/Question/Abstract:

How to randomly select records from a TTable

Answer:

procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize; {call only once}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  table1.first;
  table1.MoveBy(Random(table1.recordcount));
end;

Retrieving POST data in a TWebBrowser

Problem/Question/Abstract:

How do I get the POST data in a TWebBrowser event?

Answer:

In the BeforeNavigate2 event of TWebBrowser, you receive the PostData and Header data as OleVariant.  If you simply assign the OleVariant type to a string, you may get part of the data or garbage.  

You can convert the OleVariant to String using this function:

function VariantToString(AVar: OleVariant): string;
var
  i: integer;
  V: olevariant;
begin
  Result := '';
  if VarType(AVar) = (varVariant or varByRef) then
    V := Variant(TVarData(AVar).VPointer^)
  else
    V := AVar;

  if VarType(V) = (varByte or varArray) then
  try
    for i := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do
      Result := Result + Chr(Byte(V[i]));
  except;
  end
  else
    Result := V;
end;

How to call Windows system dialogs from code

Problem/Question/Abstract:

How to call Windows system dialogs from code

Answer:

{ ... }

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Shell(sMethod: Integer);
  end;

var
  Form1: TForm1;
  oShell: OleVariant;

implementation

{$R *.DFM}

procedure TForm1.Shell(sMethod: Integer);
begin
  case sMethod of
    0: {Minimizes all windows on the desktop}
      begin
        oShell.MinimizeAll;
        Button1.Tag := Button1.Tag + 1;
      end;
    1: {Displays the Run dialog}
      begin
        oShell.FileRun;
        Button1.Tag := Button1.Tag + 1;
      end;
    2: {Displays the Shut Down Windows dialog}
      begin
        oShell.ShutdownWindows;
        Button1.Tag := Button1.Tag + 1;
      end;
    3: {Displays the Find dialog}
      begin
        oShell.FindFiles;
        Button1.Tag := Button1.Tag + 1;
      end;
    4: {Displays the Date/ Time dialog}
      begin
        oShell.SetTime;
        Button1.Tag := Button1.Tag + 1;
      end;
    5: {Displays the Internet Properties dialog}
      begin
        oShell.ControlPanelItem('INETCPL.cpl');
        Button1.Tag := Button1.Tag + 1;
      end;
    6: {Enables user to select folder from Program Files}
      begin
        oShell.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
        Button1.Tag := Button1.Tag + 1;
      end;
    7: {Displays the Taskbar Properties dialog}
      begin
        oShell.TrayProperties;
        Button1.Tag := Button1.Tag + 1;
      end;
    8: {Un-Minimizes all windows on the desktop}
      begin
        oShell.UndoMinimizeAll;
        Button1.Tag := 0;
      end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  oShell := CreateOleObject('Shell.Application');
  Shell(Button1.Tag);
  oShell := VarNull;
end;

How to move down selected items in a TListBox

Problem/Question/Abstract:

I want to move items up and down a TListBox controlled by the up and down arrows. Has anyone got the code to do this?

Answer:

Here's something to move a selected item down:



procedure TF_MainForm.b_fileDownClick(Sender: TObject);
var
  i: integer;
begin
  i := LB_Files.itemindex;
  if (i = -1) or (i = LB_Files.items.count - 1) then
    Exit;
  LB_Files.Items.Move(LB_Files.itemindex, LB_Files.itemindex + 1);
  LB_Files.itemindex := i + 1;
end;

How to copy folders from one drive to another

Problem/Question/Abstract:

How to copy folders from one drive to another

Answer:

uses
  ShellAPI;

procedure CopyTree(dir, dest: string);
var
  sfos: TSHFileOpStruct;
begin
  FillChar(sfos, SizeOf(sfos), 0);
  dir := dir + '\*.*'#0;
  dest := dest + '\*.*'#0;
  with sfos do
  begin
    wnd := 0;
    wfunc := FO_COPY;
    pFrom := PChar(dir);
    pTo := PChar(dest);
    fFlags := FOF_ALLOWUNDO or FOF_RENAMEONCOLLISION or FOF_SIMPLEPROGRESS;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
    lpszProgressTitle := nil
  end;
  SHFileOperation(sfos);
end;

Get field values of a dataset as comma text

Problem/Question/Abstract:

How to get field values of a dataset as comma text ?
Getting the unique field values (strings of course) as comma text can be a big advantage in populating any TStrings descendant. The following functions implement it with respect to a table and also on TBDEDataset.

Answer:

Getting the unique field values (strings of course) as comma text can be a big advantage if you want to fill in a List box or CheckedListBox or for that matter a PickList of DBGrid.

Here are two functions that will let you get the field values as CommaText.The first one gets it from a table given the databasename ,tablename and field name. The second function retrieves it from a TBDEDataSet given the dataset  and field name. The components used in the functions are created at runtime so you don't require a component to be added to the form per se, but the respective units should be added in the uses clause.

The idea is to use a query to get just the required field values. A for loop is used to concatenate the values with a comma in between. The use of DISTINCT in the SQL ensures that there are no repeated entries.
The second function, which works with a dataset, uses a BatchMove component to move the data to a table and then does the function of creating a commatext string.

The Commatext can be assigned to any TStrings descendant making stuff like

ChecklistBox.Items.CommaText := GetCommaTextFromdb(table.DatabaseName, 'fieldName',
  'Tablename');

possible.

function GetCommaTextFromdb(const Dbname, dbField, Tablename: string): string;
var
  i: integer;
  QryTemp: TQuery;
  sFieldname: string;
begin
  Result := '';
  QryTemp := TQuery.Create(nil);
  with QryTemp do
  begin
    DatabaseName := Dbname;
    SQL.Clear;
    SQL.Add('SELECT DISTINCT ' + dbField + ' FROM ' + Tablename);
    Active := True;
    First;
    for i := 0 to QryTemp.RecordCount - 1 do
    begin
      sFieldname := FieldByName(dbField).AsString;
      if (sFieldname <> '') then
      begin
        Result := Result + '"' + (sFieldname) + '"';
        if i <> (QryTemp.RecordCount - 1) then
          Result := Result + ',';
        Next;
      end;
      Active := False;
    end;
    QryTemp.Free;
  end;

function GetCommaTextFromDataSet(Dataset: TBDEDataSet; dbField: string): string;
var
  i: integer;
  QryTemp: TQuery;
  sFieldname: string;
  BatchMove: TBatchMove;
  TempOutTable: TTable;
begin
  Result := '';
  QryTemp := TQuery.Create(nil);
  BatchMove := TBatchMove.Create(nil);
  TempOutTable := TTable.Create(nil);
  TempOutTable.TableName := 'TempOutTable';

  if Dataset is TQuery then
    QryTemp.DatabaseName := TQuery(Dataset).DatabaseName
  else
    QryTemp.DatabaseName := TTable(Dataset).DatabaseName;

  TempOutTable.DatabaseName := QryTemp.DatabaseName;

  with BatchMove do
  begin
    Mappings.Clear;
    Source := Dataset;
    Destination := TempOutTable;
    Mode := batCopy;
    Execute;
  end;

  with QryTemp do
  begin
    SQL.Clear;
    SQL.Add('SELECT DISTINCT ' + dbField + ' FROM TempOutTable');
    Active := True;
    First;

    for i := 0 to QryTemp.RecordCount - 1 do
    begin
      sFieldname := FieldByName(dbField).AsString;
      if (sFieldname <> '') then
      begin
        Result := Result + '"' + (sFieldname) + '"';
        if i <> (QryTemp.RecordCount - 1) then
          Result := Result + ',';
      end;
      Next;
    end;
    Active := False;
  end;
  TempOutTable.DeleteTable;
  QryTemp.Free;
  BatchMove.Free;
  TempOutTable.Free;
end;

Create and print a screen shot of a TForm

Problem/Question/Abstract:

How to create and print a screen shot of a TForm

Answer:

The following details a better way to print the contents of a form, by getting the device independent bits in 256 colors from the form, and using those bits to print the form to the printer.

In addition, a check is made to see if the screen or printer is a palette device, and if so, palette handling for the device is enabled. If the screen device is a palette device, an additional step is taken to fill the bitmap's palette from the system palette, overcoming some buggy video drivers who don't fill the palette in.

Note: Since this code does a screen shot of the form, the form must be the topmost window and the whole from must be viewable when the form shot is made.

unit Prntit;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  dc: HDC;
  isDcPalDevice: BOOL;
  MemDc: HDC;
  MemBitmap: hBitmap;
  OldMemBitmap: hBitmap;
  hDibHeader: THandle;
  pDibHeader: pointer;
  hBits: THandle;
  pBits: pointer;
  ScaleX: Double;
  ScaleY: Double;
  ppal: PLOGPALETTE;
  pal: hPalette;
  Oldpal: hPalette;
  i: integer;
begin
  {Get the screen dc}
  dc := GetDc(0);
  {Create a compatible dc}
  MemDc := CreateCompatibleDc(dc);
  {create a bitmap}
  MemBitmap := CreateCompatibleBitmap(Dc, form1.width, form1.height);
  {select the bitmap into the dc}
  OldMemBitmap := SelectObject(MemDc, MemBitmap);
  {Lets prepare to try a fixup for broken video drivers}
  isDcPalDevice := false;
  if GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, pPal^.palPalEntry);
    if pPal^.PalNumEntries <> 0 then
    begin
      pal := CreatePalette(pPal^);
      oldPal := SelectPalette(MemDc, Pal, false);
      isDcPalDevice := true
    end
    else
      FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
  end;
  {copy from the screen to the memdc/ bitmap}
  BitBlt(MemDc, 0, 0, form1.width, form1.height, Dc, form1.left, form1.top, SrcCopy);
  if isDcPalDevice = true then
  begin
    SelectPalette(MemDc, OldPal, false);
    DeleteObject(Pal);
  end;
  {unselect the bitmap}
  SelectObject(MemDc, OldMemBitmap);
  {delete the memory dc}
  DeleteDc(MemDc);
  {Allocate memory for a DIB structure}
  hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
  {get a pointer to the alloced memory}
  pDibHeader := GlobalLock(hDibHeader);
  {fill in the dib structure with info on the way we want the DIB}
  FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize := sizeof(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
  {find out how much memory for the bits}
  GetDIBits(dc, MemBitmap, 0, form1.height, nil, TBitmapInfo(pDibHeader^),
    DIB_RGB_COLORS);
  {Alloc memory for the bits}
  hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
  {Get a pointer to the bits}
  pBits := GlobalLock(hBits);
  {Call fn again, but this time give us the bits!}
  GetDIBits(dc, MemBitmap, 0, form1.height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS);
  {Lets try a fixup for broken video drivers}
  if isDcPalDevice = true then
  begin
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
    end;
    FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
  end;
  {Release the screen dc}
  ReleaseDc(0, dc);
  {Delete the bitmap}
  DeleteObject(MemBitmap);
  {Start print job}
  Printer.BeginDoc;
  {Scale print size}
  if Printer.PageWidth < Printer.PageHeight then
  begin
    ScaleX := Printer.PageWidth;
    ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
  end
  else
  begin
    ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
    ScaleY := Printer.PageHeight;
  end;
  {Just in case the printer driver is a palette device}
  isDcPalDevice := false;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
    RC_PALETTE = RC_PALETTE then
  begin
    {Create palette from dib}
    GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
    isDcPalDevice := true
  end;
  {send the bits to the printer}
  StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(scaleX), Round(scaleY), 0, 0,
    Form1.Width, Form1.Height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS, SRCCOPY);
  {Just in case you printer driver is a palette device}
  if isDcPalDevice = true then
  begin
    SelectPalette(Printer.Canvas.Handle, oldPal, false);
    DeleteObject(Pal);
  end;
  {Clean up allocated memory}
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);
  {End the print job}
  Printer.EndDoc;
end;

How to parse a line from a comma-separated file into a record

Problem/Question/Abstract:

How to parse a line from a comma-separated file into a record

Answer:

{ ... }
type
  TRec = record
    lastname, firstname: string[30];
    age: Integer;
    position: string[40];
    salary: Single;
  end;

procedure ParseLine(const Line: string; var rec: TRec);
var
  i, start, field: Integer;

  procedure CopyField(currPos: Integer);
  var
    len, err: Integer;
    temp: string;
  begin
    len := currpos - start;
    if len > 0 then
    begin
      temp := Copy(Line, start, len);
      err := 0;
      with rec do
        case field of
          0: lastname := temp;
          1: firstname := temp;
          2: Val(temp, age, err);
          3: position := temp;
          4: Val(temp, salary, err)
        else
          { too much data in this line, issue error message }
        end;
      if err <> 0 then
      begin
        {issue error message}
      end;
    end
    else
      {no data in this field, issue error message or leave the default }
  end;

begin
  {set defaults for the fields, init variables}
  FillChar(rec, sizeof(rec), 0);
  field := 0; {fields keeps track of which field to fill next}
  start := 1; {fencepost for start of field data}
  for i := 1 to Succ(Length(Line)) do
  begin
    if i > Length(Line) then
    begin
      {copy the last section of the line to the last field}
      CopyField(i);
    end
    else
      {test for separator character} if Line[i] = ',' then
      begin
        {found one, copy data from current fencepost to this separator}
        CopyField(i);
        {advance fencepost to position after separator}
        start := i + 1;
        {next field}
        Inc(field);
      end;
  end;
end;

Copying files in delphi using streams

Problem/Question/Abstract:

I'd like to be able to copy files in Delphi, but am having trouble figuring out how to do it. I've been using operating system level calls, but don't want to limited by them. Is there a way to do it in Delphi?

Answer:

This is one of those topics that I've gotten asked about frequently enough that I decided it's time to write a short article on how to do it. It's funny that something as basic as this is not as visible as might be expected. It falls into a category that I call, "You gotta know what you're looking for..." Essentially, it means that the technique may not be hard to implement, it's just hard to find. In any case, once you know how to do it, it's not that difficult at all.

There are actually a number of ways to copy files. One way is to use untyped files along with BlockRead and BlockWrite. This also entails the use of an intermediary buffer. It works, but it can be a bit unwieldy, especially for novices. An easier way to accomplish file copying in Delphi is to use streams. As the term implies, a stream is sequential stream of data. When copying a file, you stream the file into a buffer, then stream buffer out to another file. Pretty simple in concept. Now in Delphi there are several types of streams which descend from the abstract base class TStream. I encourage you to look them up in the online help since they are beyond the scope of this discussion. But for our purposes, the descendant class that we're interested in is called TFileStream. This class allows applications to read from and write to files on disk. For simplicity's sake, I won't be going into the various intricacies of the class; again, encouraging you to study the online help. Or better yet, Ray Lischner's Book Secrets of Delphi 2 has a great discussion about streams as well (don't worry, the material applies to Delphi 3).

Quick and Dirty File Copying

The easiest method of copying a file with streams is called stream to stream copying. Essentially, this method involves creating a stream for the source file, and creating one for the destination file. Once that's done, it's a simple matter of copying the contents of the source stream to the destination stream. Listing 1 below shows a procedure that encapsulates stream to stream copying:

{Quick and dirty stream copy}

procedure FileCopy(const FSrc, FDst: string);
var
  sStream,
    dStream: TFileStream;
begin
  sStream := TFileStream.Create(FSrc, fmOpenRead);
  try
    dStream := TFileStream.Create(FDst, fmCreate);
    try
      {Forget about block reads and writes, just copy
       the whole darn thing.}
      dStream.CopyFrom(sStream, 0);
    finally
      dStream.Free;
    end;
  finally
    sStream.Free;
  end;
end;

Undoubtedly, you can get a lot more sophisticated with this. But for now, we'll leave it at this...

Changing properties for all components of a certain type

Problem/Question/Abstract:

Changing properties for all components of a certain type

Answer:

To change the font color of all the labels of a form to a certain color, call the following procedure. In the call itself, you have to replace NewColor with an existing color, e.g. SetLabelsFontColor(clRed) sets all the labels' font color to red.

procedure TForm1.SetLabelsFontColor(NewColor: TColor);
var
  i: Integer;
begin
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TLabel then
      TLabel(Components[i]).Font.Color := NewColor;
end;

Of course, you can use this technique to change other properties of other components. To change the color of all edits, the code would be:

procedure TForm1.SetEditsColor(NewColor: TColor);
var
  i: Integer;
begin
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TEdit then
      TEdit(Components[i]).Color := NewColor;
end;

How to create gradient color schemes

Problem/Question/Abstract:

How to create gradient color schemes

Answer:

Just cut and paste the routines below into a unit somewhere and make the function declarations at the top of your unit.

You can use GetGradientColor2 to get a color that is somewhere between two other colors. For example, to get the color that is 50% between Red and Blue, do this:


var
  MyColor: TColor;
begin
  R1 := 255;
  G1 := 0;
  B1 := 0;
  R2 := 0;
  G2 := 0;
  B2 := 0;
  Percent := 0.5;
  MyNewColor := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent);


You could put percent in a loop from 0 to 1, and get all the colors as a nice gradient.

Function GetGradientColor3 works in a similar manner, except that you can do a gradient between 3 colors, such as between red to yellow to blue. This can help prevent the colors from loosing intensity when you go between say blue and red, where the purple would otherwise be darker.



function ColorFromRGB(Red, Green, Blue: Integer): Integer;
{Returns the color made up of the red, green, and blue components. Red, Green, and Blue can
be from 0 to 255.}
begin
  {Convert Red, Green, and Blue values to color.}
  Result := Red + Green * 256 + Blue * 65536;
end;

function GetPigmentBetween(P1, P2, Percent: Double): Integer;
{Returns a number that is Percent of the way between P1 and P2}
begin
  {Find the number between P1 and P2}
  Result := Round(((P2 - P1) * Percent) + P1);
  {Make sure we are within bounds for color.}
  if Result > 255 then
    Result := 255;
  if Result < 0 then
    Result := 0;
end;

function GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent: Double): Integer;
{Gets a color that is inbetween the colors defined by (R1,G1,B1) and (R2,G2,B2)
Percent ranges from 0 to 1.0 (i.e. 0.5 = 50%)
If percent =0   then the color of (R1,G1,B1) is returned
If Percent =1   then the color of (R2,G2,B2) is returned
if Percent is somewhere inbetween, then an inbetween color is returned.}
var
  NewRed, NewGreen, NewBlue: Integer;
begin
  {Validate input data in case it is off by a few thousanths.}
  if Percent > 1 then
    Percent := 1;
  if Percent < 0 then
    Percent := 0;
  {Calculate Red, green, and blue components for the new color.}
  NewRed := GetPigmentBetween(R1, R2, Percent);
  NewGreen := GetPigmentBetween(G1, G2, Percent);
  NewBlue := GetPigmentBetween(B1, B2, Percent);
  {Convert RGB to color}
  Result := ColorFromRGB(NewRed, NewGreen, NewBlue);
end;

function GetGradientColor3(R1, G1, B1, R2, G2, B2, R3, G3, B3, Percent: Double): Integer;
{Gets a color that is inbetween the color spread defined (R1,G1,B1), (R2,G2,B2) and (R3,G3,B3).
This is similar to GetGradientColor2, except that it allows you to specify 3 colors instead of 2.}
begin
  {Use GetGradient2 to do most the work}
  if Percent < 0.5 then
    Result := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent * 2)
  else
    Result := GetGradientColor2(R2, G2, B2, R3, G3, B3, (Percent - 0.5) * 2);
end;

How to specify a wildcard character for date parameters

Problem/Question/Abstract:

I'd like to do something like this:

select * from Person where Surname like '%'

but with DOB instead. Is there a way to specify a wildcard character for date parameters? I keep getting type mismatch errors.

Answer:

The LIKE predicate can only be used with CHAR (or VARCHAR) type values. To use LIKE with a value of any other data type, you would need to use the SQL function CAST to convert the value to CHAR type. For example, converting a DATE type column to CHAR(10):

SELECT *
FROM Person
WHERE(CAST(DOB as CHAR(10))LIKE "%94")

However, if this is performed on a TIMESTAMP type column, the time portion of the column's value can interfere with this. Convert the column first to DATE and then that to CHAR(10).

SELECT *
FROM Person
WHERE(CAST(CAST(DOB as DATE) as CHAR(10))LIKE "%94")

But SQL provides a function specifically for extracting a single element of a DATE or TIMESTAMP value for making such partial-value comparisons: EXTRACT. The EXTRACT function can be applied to a DATE or TIMESTAMP value to retrieve the year, month, or day portion of the date. For example:

SELECT *
FROM Person
WHERE(EXTRACT(YEAR FROM DOB) = 1994)

Note: all of the above is common to SQL-92. These operations are not specific to local SQL.

Hyphenation - Dividing Spanish words in syllables

Problem/Question/Abstract:

A simple hyphenation algorithm to syllabicate Spanish words.

Answer:

Sometimes we need to display or print a text, and we'd like to hyphenate long words that don't fit at the end of a line, to prevent them from falling entirely into the next line leaving too much space unused.

The main problem that arises is how to divide a Spanish word in syllables. If your are interested in syllabication for English words, read the note at the end of this article.

procedure Syllabify(Syllables: TStringList; s: string);
const
  Consonants = ['b', 'B', 'c', 'C', 'd', 'D', 'f', 'F', 'g', 'G',
    'h', 'H', 'j', 'J', 'k', 'K', 'l', 'L', 'm', 'M', 'n', 'N',
    '�', '�', 'p', 'P', 'q', 'Q', 'r', 'R', 's', 'S', 't', 'T',
    'v', 'V', 'w', 'W', 'x', 'X', 'y', 'Y', 'z', 'Z'];
  StrongVowels = ['a', 'A', '�', '�', 'e', 'E', '�', '�',
    '�', '�', 'o', '�', 'O', '�', '�', '�'];
  WeakVowels = ['i', 'I', 'u', 'U', '�', '�'];
  Vowels = StrongVowels + WeakVowels;
  Letters = Vowels + Consonants;
var
  i, j, n, m, hyphen: integer;
begin
  j := 2;
  s := #0 + s + #0;
  n := Length(s) - 1;
  i := 2;
  Syllables.Clear;
  while i <= n do
  begin
    hyphen := 0; // Do not hyphenate
    if s[i] in Consonants then
    begin
      if s[i + 1] in Vowels then
      begin
        if s[i - 1] in Vowels then
          hyphen := 1;
      end
      else if (s[i + 1] in Consonants) and
        (s[i - 1] in Vowels) then
      begin
        if s[i + 1] in ['r', 'R'] then
        begin
          if s[i] in ['b', 'B', 'c', 'C', 'd', 'D', 'f', 'F', 'g',
            'G', 'k', 'K', 'p', 'P', 'r', 'R', 't', 'T', 'v', 'V'] then
            hyphen := 1
          else
            hyphen := 2;
        end
        else if s[i + 1] in ['l', 'L'] then
        begin
          if s[i] in ['b', 'B', 'c', 'C', 'd', 'D', 'f', 'F', 'g',
            'G', 'k', 'K', 'l', 'L', 'p', 'P', 't', 'T', 'v', 'V'] then
            hyphen := 1
          else
            hyphen := 2;
        end
        else if s[i + 1] in ['h', 'H'] then
        begin
          if s[i] in ['c', 'C', 's', 'S', 'p', 'P'] then
            hyphen := 1
          else
            hyphen := 2;
        end
        else
          hyphen := 2;
      end;
    end
    else if s[i] in StrongVowels then
    begin
      if (s[i - 1] in StrongVowels) then
        hyphen := 1
    end
    else if s[i] = '-' then
    begin
      Syllables.Add(Copy(s, j, i - j));
      Syllables.Add('-');
      inc(i);
      j := i;
    end;
    if hyphen = 1 then
    begin // Hyphenate here
      Syllables.Add(Copy(s, j, i - j));
      j := i;
    end
    else if hyphen = 2 then
    begin // Hyphenate after
      inc(i);
      Syllables.Add(Copy(s, j, i - j));
      j := i;
    end;
    inc(i);
  end;
  m := Syllables.Count - 1;
  if (j = n) and (m >= 0) and (s[n] in Consonants) then
    Syllables[m] := Syllables[m] + s[n] // Last letter
  else
    Syllables.Add(Copy(s, j, n - j + 1)); // Last syllable
end;

To test the procedure yon can drop a Textbox and a Label on a form and in the Change event of the Textbox write:

procedure TForm1.Edit1Change(Sender: TObject);
var
  Syllables: TStringList;
begin
  Syllables := TStringList.Create;
  try
    Syllabify(Syllables, Edit1.Text);
    Label1.Caption := StringReplace(Trim(Syllables.Text),
      #13#10, '-', [rfReplaceAll]);
  finally
    Syllables.Free;
  end;
end;

Now that we have a syllabication procedure, we have to note that we can't hyphenate a word in any syllable break. It is usually correct and/or desirable to join small syllables at the left and/or right sides of a word to guarantee for example that there are at least two syllables on either side of the word when it gets hyphenated, or -like in the following example- to make sure that at least we have four characters in either side:

procedure ApplyRules(Syllables: TStringList);
// Guarantee there are at least four letters in the left
// and right parts of the word
begin
  with Syllables do
  begin
    if Count = 1 then
      exit;
    while Count > 1 do
    begin
      if Length(Strings[0]) >= 4 then
        break;
      Strings[0] := Strings[0] + Strings[1];
      Delete(1);
    end;
    while Syllables.Count > 1 do
    begin
      if Length(Strings[Count - 1]) >= 4 then
        break;
      Strings[Count - 2] := Strings[Count - 2]
        + Strings[Count - 1];
      Delete(Count - 1);
    end;
  end;
end;

Finally, it comes the time to parse the text separating the lines of a paragraph determining which words should be hyphenated. The following example does that with a text to be displayed in a Memo:

procedure Hyphenate(Memo: TMemo; OriginalText: TStrings);
var
  paragraph, i, j, k, m, n, MaxLineWidth: integer;
  s, line: string;
  Bitmap: TBitmap;
  Canvas: TCanvas;
  Syllables: TStringList;
begin
  Syllables := TStringList.Create;
  try
    // We need a canvas to use its TextWidth method to get the width
    // of the text to see if it fits in the client area or not. The
    // TMemo class doesn't have a Canvas property, so we have to
    // create one of our own.
    Bitmap := TBitmap.Create;
    Canvas := Bitmap.Canvas;
    try
      Canvas.Font := Memo.Font;
      MaxLineWidth := Memo.ClientWidth - 6; // Maximum width
      Memo.Lines.Clear;
      for paragraph := 0 to OriginalText.Count - 1 do
      begin
        // For each paragraph
        s := OriginalText[paragraph]; // Get the original paragraph
        // Get the lines in which we have to break the paragraph
        while Canvas.TextWidth(s) > MaxLineWidth do
        begin
          // First we find (in "j") the index of the start of the
          // first word that doesn't fit (the one to hyphenate)
          j := 1;
          n := Length(s);
          i := 2;
          while i <= n do
          begin
            if (s[i - 1] = ' ') and (s[i] <> ' ') then
              j := i; // last beginning of a word
            if Canvas.TextWidth(Copy(s, 1, i)) > MaxLineWidth then
              break; // reached a width that doesn't fit
            inc(i);
          end;
          // Where does the break occurs?
          if s[i] = ' ' then
          begin
            // Great! We break on a space
            Memo.Lines.Add(Copy(s, 1, i - 1)); // Add the line
            s := Copy(s, i + 1, n - i); // Remove the line
          end
          else
          begin
            // We break somewhere in a word. Now, we find (in "k")
            // the first space after the word (k)
            k := j + 1;
            while (k <= n) and (s[k] <> ' ') do
              inc(k);
            // Divide the word in Syllables
            Syllabify(Syllables, Copy(s, j, k - j));
            ApplyRules(Syllables);
            // Check (in "m") how many syllables fit
            m := 0;
            Line := Copy(s, 1, j - 1);
            while Canvas.TextWidth(Line + Syllables[m] + '-')
              <= MaxLineWidth do
            begin
              Line := Line + Syllables[m];
              inc(m);
            end;
            if (m <> 0) and (Syllables[m - 1] <> '-') then
            begin
              // Hyphenate
              Line := Line + '-';
              j := Length(Line);
              if Syllables[m] = '-' then
                inc(j);
            end;
            Memo.Lines.Add(Line); // Add the line
            s := Copy(s, j, n - j + 1); // Remove the line
          end;
        end;
        Memo.Lines.Add(s); // Add the last line (it fits)
      end;
    finally
      Bitmap.Free;
    end;
  finally
    Syllables.Free;
  end;
end;

To test the procedure, drop a Memo component on a form, align it for example to the top of the form (Align = alTop) and write the following code in the OnResize event of the form:

procedure TForm1.FormResize(Sender: TObject);
var
  OriginalText: TStringList;
begin
  OriginalText := TStringList.Create;
  try
    OriginalText.Add('Si se ha preguntado c�mo hacen los '
      + 'programas procesamiento de textos para dividir palabras '
      + 'con de guiones al final de una l�nea, he aqu� un '
      + 'ejemplo sencillo (en comparaci�n con los que usan las '
      + 'aplicaciones de procesamiento de textos).');
    OriginalText.Add('Este es un segundo p�rrafo que se provee '
      + 'con fines de ejemplo.');
    Hyphenate(Memo1, OriginalText);
  finally
    OriginalText.Free;
  end;
end;

NOTE:

English words are hyphenated phonetically, so the process would have two phases:

produce a phonetic representation of the word using pronunciation rules; and
perform the hyphenation of the phonetic representation using hyphenation rules (and parallelly apply that to the original word).

There are rules for both things, and also exceptions, so a small exceptions dictionary may be needed. Of course, it's all easier said than done. I realize it is somewhat complex, but I still believe it is possible to syllabicate English words algorithmically.

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

Get a table/SP list using ADO

Problem/Question/Abstract:

How can I receive the list of table names in ADO?

Answer:

If you needs to retrieve the list of available tables in ADO, you can call the GetTableNames method of your TADOConnection component:

{we want to receive the tables including the system tables}
boolSystemTables := True;
yourADOConnection.GetTableNames(yourListBox.Items, boolSystemTables);

if you want to recieve the names of stored procedures, you must call the GetProcedureNames method:

yourADOConnection.GetProcedureNames((yourListBox.Items);

How to iterate through a parent's child controls and enable/ disable them

Problem/Question/Abstract:

I have a question about disabling containers. In my case I have a panel containing a button. When disabling the panel the button is disabled, but not greyed. Why is it not greyed?

Answer:

You have several options. Perhaps the easiest is to use this small routine which iterates through a parent's children controls, enabling / disabling each in turn:


procedure EnableContainer(Parent: TWinControl; AEnabled: Boolean);
var
  I: Integer;
begin
  for I := 0 to Parent.ControlCount - 1 do
    Parent.Controls[I].Enabled := AEnabled;
  Parent.Enabled := AEnabled;
end;


So instead of doing this:


Panel1.Enabled := False;


do this instead:


EnableContainer(Panel1, False);

MDI application without annoying ScrollBars

Problem/Question/Abstract:

I've been trying to create a MDI form without those annoying scrollbars when a child form is moved outside main form area and I couldn't find an easy way. Setting the scrollbars to visible := false won't work!
So, I found an example on a newsgroup... yeah! Here I show how to do it.

Answer:

It's a two step proccess.

Step one : put the code below inside the OnCreate event of the main form.

if ClientHandle <> 0 then
begin
  if (not (GetWindowLong(ClientHandle, GWL_USERDATA) <> 0)) then
  begin
    SetWindowLong(
      ClientHandle,
      GWL_USERDATA,
      SetWindowLong(ClientHandle, GWL_WNDPROC, integer
      (@ClientWindowProc))
      );
  end;
end;

Step two: Put this standalone function inside the unit that contains the main form, before the OnCreate event (once OnCreate references to this function).

function ClientWindowProc(wnd: HWND; msg: Cardinal; wparam, lparam: Integer): Integer;
  stdcall;
var
  f: Pointer;
begin
  f := Pointer(GetWindowLong(wnd, GWL_USERDATA));
  case msg of
    WM_NCCALCSIZE:
      begin
        if (
          GetWindowLong(wnd, GWL_STYLE) and
          (WS_HSCROLL or WS_VSCROLL)) <> 0 then
          SetWindowLong(
            wnd,
            GWL_STYLE,
            GetWindowLong(wnd, GWL_STYLE) and not
            (WS_HSCROLL or WS_VSCROLL)
            );
      end;
  end;
  Result := CallWindowProc(f, wnd, msg, wparam, lparam);
end;

That's it!!!

The code was originally posted by Peter Below in a newsgroup (borland.public.delphi.objectpascal). I've made some little changes.

Display a modal form stored in a DLL

Problem/Question/Abstract:

Anyone know how to display a modal form in a DLL file? Whenever I try, the modal form shows up on the taskbar and stays on top, even when you switch to other windows.

Answer:

procedure ShowDLLForm(appHandle: HWND); stdcall;
begin
  if appHandle = 0 then
    apphandle := GetActiveWindow;
  application.handle := appHandle;
  try
    with TDLLForm.Create(Application) do
    try
      ShowModal
    finally
      free;
    end
  except
    on E: Exception do
      application.HandleException(E);
  end;
  application.handle := 0;
end;

How to create a panel which resizes itself and all components on it at runtime

Problem/Question/Abstract:

How to create a panel which resizes itself and all components on it at runtime

Answer:

Here's the source code for a resizable panel. Give the panel an align property of alClient, throw some controls on it, and watch them resize at run time when you resize the form. There is some code that prohibits resizing during design time, but this can be taken out.

unit Elastic;

interface

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

type
  TElasticPanel = class(TPanel)
  private
    FHorz, FVert: boolean;
    nOldWidth, nOldHeight: integer;
    bResized: boolean;
  protected
    procedure WMSize(var message: TWMSize); message WM_SIZE;
  public
    nCount: integer;
    constructor Create(AOwner: TComponent); override;
  published
    property ElasticHorizontal: boolean read FHorz write FHorz default True;
    property ElasticVertical: boolean read FVert write FVert default True;
  end;

procedure Register;

implementation

constructor TElasticPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHorz := True;
  FVert := True;
  nOldWidth := Width;
  nOldHeight := Height;
  bResized := False;
end;

procedure TElasticPanel.WMSize(var message: TWMSize);
var
  bResize: boolean;
  xRatio: real;
  i: integer;
  ctl: TWinControl;
begin
  Inc(nCount);
  if Align = alNone then
    bResize := TRUE
  else
    bResize := bResized;
  if not (csDesigning in ComponentState) and bResize then
  begin
    if FHorz then
    begin
      xRatio := Width / nOldWidth;
      for i := 0 to ControlCount - 1 do
      begin
        ctl := TWinControl(Controls[i]);
        ctl.Left := Round(ctl.Left * xRatio);
        ctl.Width := Round(ctl.Width * xRatio);
      end;
    end;
    if FVert then
    begin
      xRatio := Height / nOldHeight;
      for i := 0 to ControlCount - 1 do
      begin
        ctl := TWinControl(Controls[i]);
        ctl.Top := Round(ctl.Top * xRatio);
        ctl.Height := Round(ctl.Height * xRatio);
      end;
    end;
  end
  else
  begin
    nOldWidth := Width;
    nOldHeight := Height;
  end;
  bResized := TRUE;
  nOldWidth := Width;
  nOldHeight := Height;
end;

procedure Register;
begin
  RegisterComponents('Additional', [TElasticPanel]);
end;

end.

How to calculate the week from a given date

Problem/Question/Abstract:

How to calculate the week from a given date

Answer:

The code below tells you which week the specified date is in, and also the corresponding day of the week. The date format it handles is "06/25/1996". You have to create a form named "Forma" with a TEdit named "Edit1", four labels and a button named "GetWeekBtn".


unit Forma;

interface

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

type
  TForma1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    GetWeekBtn: TButton;
    Label4: TLabel;
    procedure GetWeekBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    function HowManyDays(pYear, pMonth, pDay: word): Integer;
  public
    { Public declarations }
  end;

var
  Forma1: TForma1;

implementation

{$R *.DFM}

uses
  Inifiles;

procedure TForma1.FormCreate(Sender: TObject);
var
  WinIni: TInifile;
begin
  WinIni := TIniFile.Create('WIN.INI');
  WinIni.WriteString('intl', 'sShortDate', 'MM/dd/yyyy');
  WinIni.Free;
end;

function TForma1.HowManyDays(pYear, pMonth, pDay: Word): Integer;
var
  Sum: Integer;
  pYearAux: Word;
begin
  Sum := 0;
  if pMonth > 1 then
    Sum := Sum + 31;
  if pMonth > 2 then
    Sum := Sum + 28;
  if pMonth > 3 then
    Sum := Sum + 31;
  if pMonth > 4 then
    Sum := Sum + 30;
  if pMonth > 5 then
    Sum := Sum + 31;
  if pMonth > 6 then
    Sum := Sum + 30;
  if pMonth > 7 then
    Sum := Sum + 31;
  if pMonth > 8 then
    Sum := Sum + 31;
  if pMonth > 9 then
    Sum := Sum + 30;
  if pMonth > 10 then
    Sum := Sum + 31;
  if pMonth > 11 then
    Sum := Sum + 30;
  Sum := Sum + pDay;
  if ((pYear - (pYear div 4) * 4) = 30) and (pMonth > 2) then
    inc(Sum);
  HowManyDays := Sum;
end;

procedure TForma1.GetWeekBtnClick(Sender: TObject);
var
  ADate: TDateTime;
  EditAux: string;
  Week, year, month, day: Word;
begin
  EditAux := Edit1.Text;
  ADate := StrToDate(EditAux);
  Label1.Caption := DateToStr(ADate);
  DecodeDate(Adate, Year, Month, Day);
  case DayOfWeek(ADate) of
    1: Label4.Caption := 'Sunday';
    2: Label4.Caption := 'Monday';
    3: Label4.Caption := 'Tuesday';
    4: Label4.Caption := 'Wednesday';
    5: Label4.Caption := 'Thursday';
    6: Label4.Caption := 'Friday';
    7: Label4.Caption := 'Saturday';
  end;
  Week := (HowManyDays(year, month, day) div 7) + 1;
  Label3.Caption := 'Week No. ' + IntToStr(Week);
end;

end.

Fill a TListView with all files of a given directory along with the system icons

Problem/Question/Abstract:

How to fill a TListView with all files of a given directory along with the system icons

Answer:

Here's some code from a recent project. FileList is a TListView. ScanDir() is a function from our product - it's basically a procedure that fills a TStrings object with a list of files matching a mask. You can ignore the TDirInfo(Node.Data) stuff - it's a small class that holds info on each folder as displayed in a TTreeView.TTreeNode.

This routine builds a TListView that's pretty much like the right pane in Windows Explorer, in that it supports both the list and report view, and displays the file type, size, and modified date in columns in report view.

{Gets files in a folder and displays them in the ListView}

procedure TExplorer.GetFilesInFolder(Node: TTreeNode);
var
  SL: TStringList;
  i: Integer;
  Dat: TDirInfo;
  AllSel: Boolean;
  NewItem: TListItem;
  FI: TSHFileInfo;
  Dt: TDateTime;
  TypeDesc: string;
begin
  if not Assigned(Node) then
    Exit;
  SL := TStringList.Create;
  if Screen.Cursor <> crHourglass then
    Screen.Cursor := crHourglass;
  try
    {Need easier access to Node.Data than TDirInfo(Node.Data) typecasts}
                {Grab a local reference to the pointer}
                Dat := TDirInfo(Node.Data);
    {Get files in this folder, but don't include subfolder files}
    ScanDir(Dat.FullPath, '*.*', SL, False);
    SL.Sorted := True;
    {See if this folder has already been fully selected.
                If so, we don't need to add it to the Folders list or increment selection count
                or bytes}
    AllSel := (Folders.IndexOf(Dat.FullPath) > -1) or (Dat.Status = dsFull);
    {Remove stuff that was previously displayed}
    FileList.Items.BeginUpdate;
    FileList.Items.Clear;
    {Is this an empty folder?}
    if SL.Count = 0 then
    begin
      FileList.SmallImages := StateImages;
      NewItem := FileList.Items.Add;
      NewItem.Caption := ' No files ';
      NewItem.ImageIndex := NoFilesIndex;
      FileList.Enabled := False;
      Exit;
    end;
    FileList.SmallImages := SysImages;
    {We have files. Add each one to the ListView}
    for i := 0 to SL.Count - 1 do
    begin
      {Create a new TListItem}
      NewItem := FileList.Items.Add;
      {Assign the filename portion}
      NewItem.Caption := ExtractFileName(SL[i]);
      FillChar(FI, SizeOf(TSHFileInfo), #0);
      {Get the icon for display, as well as the file type, with one function call.        
                        Note the flags:
      SHGFI_SMALLICON - we want the small icon
      SHGFI_SYSICONINDEX - we want the index into the system imagelist
      SHGFI_TYPENAME - we want the file type description if there is one}
      SHGetFileInfo(PChar(SL[i]), 0, FI, SizeOf(FI), SHGFI_ICON or SHGFI_SMALLICON
        or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
      {The subitems are only displayed in the 'detail' view, but they have
                  to be there all the time. See if Windows knows what type file this is}
      TypeDesc := FI.szTypeName;
      if TypeDesc = '' then
        {Windows doesn't know - handle like Explorer does}
        TypeDesc := Upper(ExtractFileExt(SL[i])) + ' file';
      {Delete the period if we need to}
      if Length(TypeDesc) > 1 then
      begin
        if TypeDesc[1] = '.' then
          Delete(TypeDesc, 1, 1);
      end;
      {Display the file type description}
      NewItem.SubItems.Add(TypeDesc);
      {Here's the 'Size' column ...}
      NewItem.SubItems.Add(Comma([GetFileSize(SL[i])], False));
      {Assign the system imagelist index to this item}
      NewItem.ImageIndex := FI.iIcon;
      {Grab the file's time and date stamp and convert to Delphi TDateTime}
      Dt := FileDateToDateTime(FileAge(SL[i]));
      {Add the date column}
      NewItem.SubItems.Add(DateToStr(Dt));
      {Add the time column}
      NewItem.SubItems.Add(FormatDateTime('hh:nn:ss ampm', Dt));
      {If folder was fully selected, or this file was selected in a
                        previous visit to this folder, check it}
      if AllSel or (Files.IndexOf(SL[i]) > -1) then
        NewItem.Checked := True;
    end;
    FileList.Enabled := True;
  finally
    SL.Free;
    FileList.Items.EndUpdate;
    if Screen.Cursor <> crDefault then
      Screen.Cursor := crDefault;
  end;
end;