Large DSM files - can they be truncated?

Problem/Question/Abstract:

A quick scan thru my hard disk showed me over 300 megabytes with .DSM files. As I can delete them and Delphi will generate them later when building, is there any reason to keep them on disk?

Answer:

Go to 'Environment Options' and select 'save desktop only' and it won't save DSM files. The only effect is that you need to compile before the symbols are available.

ListBox.Items.Add is slow and flickers

Problem/Question/Abstract:

ListBox.Items.Add is slow and flickers

Answer:

Adding a (larger) group of entries to a ListBox is very slow, because after every "items.add" call the ListBox is repainted.

There are two ways to overcome this:

Use the Windows message WM_SETREDRAW (see Win32.hlp for details). The VCL provides two methods for this: BeginUpdate and EndUpdate. I would assume that this is faster than solve #2.
Read the strings in a temporary TStringList object. Maybe you already have such a list - in this case you should use your existing list. Then use the Assign method to transfer the whole list.

Solve 1:

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
  ListBox1.Items.BeginUpdate;
  for i := 1 to maxitems do
    ListBox1.Items.add(IntToStr(i));
  ListBox1.Items.EndUpate;
end;


Solve 2:

procedure TForm1.Button2Click(Sender: TObject);
var
  i: integer;
  tmp: tstringlist;
begin
  tmp := TStringList.Create;
  for i := 1 to maxitems do
    tmp.add(inttostr(i));
  ListBox1.Items.Assign(tmp);
  tmp.Free;
end;

Display a popup menu at a certain position in a TTreeView

Problem/Question/Abstract:

I want to get the exact position (in terms of x, y coordinates) within a treeview. The reason is that I want a popup menu to appear after a certain keypress.

Answer:

Solve 1:

procedure TForm1.TreeView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
  rect: TRect;
begin
  if assigned(TreeView1.Selected) then
  begin
    rect := TreeView1.selected.DisplayRect(true);
    {Because the popup function pops up on the screen, you need to add the form
          coordinates, the treeview coordinates, and then the displayrect coordinates of
          the item.}
    PopupMenu1.Popup(Form1.Top + TreeView1.Top + rect.Top,
      Form1.Left + TreeView1.Left + rect.Left);
  end;
end;


Solve 2:

Here's an example of a popup menu that launches when a user clicks on a node in a TTreeView.

procedure TfrmExplorer.TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  P: TPoint;
begin
  if Button <> mbRight then
    exit;
  TreeMenu.AutoPopup := False;
  if TreeView.GetNodeAt(X, Y) <> nil then
  begin
    TreeView.Selected := TreeView.GetNodeAt(X, Y);
    P.X := X;
    P.Y := Y;
    P := TreeView.ClientToScreen(P);
    TreeMenu.Popup(P.X, P.Y);
  end;
end;

How to create a lookup field at runtime

Problem/Question/Abstract:

How to create a lookup field at runtime

Answer:

var
  f: TField;
  i: Integer;
begin
  Table1.FieldDefs.Update
    Table1.Close;
  for i := 0 to Table1.FieldDefs.Count - 1 do
    if table1.FindField(table1.FieldDefs[i].Name) = nil then
      {persistent field does not exist}
      Table1.FieldDefs.Items[i].CreateField(Table1);
  f := TStringField.Create(Table1);
  f.Name := 'Table1lookup';
  f.FieldName := 'lookup';
  f.DisplayLabel := 'lookup';
  f.fieldType := fklookup;
  f.Calculated := True;
  f.DataSet := Table1;
  f.lookupDataSet := table2;
  f.Keyfields := 'Keyfield1';
  f.Lookupfields := 'Keyfield1';
  f.LookupResultField := 'ResultField';
  Table1.Open;
end;

How to add data to the columns PickList property of a TDBGrid at runtime

Problem/Question/Abstract:

How can we add data (say, x, y, z) to a DBGrid Column's PickList property at runtime?

Answer:

To add to the third column:

DBGrid1.Columns[2].PickList.Add('x');
DBGrid1.Columns[2].PickList.Add('y');
DBGrid1.Columns[2].PickList.Add('z');

Check if ActiveX is installed on a target machine

Problem/Question/Abstract:

How to check if ActiveX is installed on a target machine

Answer:

Solve 1:

Use the CLSIDFromProgID method:

{ ... }
var
  strOLE: string;
begin
  strOLE = "YourCOMServer.Application" {your ProgID}
  if (CLSIDFromProgID(PWideChar(WideString(strOLE), ClassID) = S_OK) then
    begin
      { ... }
    end;
end;


Solve 2:

Check the registry:

{ ... }
const
  cKEY = '\SOFTWARE\Classes\CLSID\%s\InprocServer32'
  var
  sKey: string;
  sComServer: string;
  exists: boolean;
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    sKey := format(cKEY, [GuidToString(ClassID)]);
    if Reg.OpenKey(sKey, False) then
    begin
      sComServer := Reg.ReadString('');
      if FileExists(sComServer) then
      begin
        { ... }
      end;
    end;
  finally
    Reg.free;
  end;
end;

Editor macro recording in Delphi

Problem/Question/Abstract:

Is there a feature in Delphi 5 that lets you record your keystrokes and then allows you to re-play it any number of times?

Answer:

Ctrl+Shift+R                             : Start Recording
Ctrl+Shift+R  (again)  : Stop Recording
Ctrl+Shift+P                       : Play it

You can't save your recording, though.

It has several features that make it very powerful:

Ability to record copy, cut and paste keystrokes (Ctrl-C, Ctrl-X and Ctrl-V).

Abilty to record Ctrl-Left and Crtl-Right cursor movements - useful for navigating on several lines of similar structure but varying lengths.

Ability to record the Incremental search keystroke (Ctrl-E) which makes it easy to record a macro that will search for the next occurance of a string and then carry out further manipulation of the text.

Another good feature in D5: Quick navigating between class declaration and implementation using Shitf+Control+Cursor Up/Down. That will jump from the definition to the implementation and back. Very handy!

How to color TPanels on a form according to their Tag properties

Problem/Question/Abstract:

How to color TPanels on a form according to their Tag properties

Answer:

{ ... }
var
  ix: Integer;
  pnl: TPanel;
  { ... }

  for ix := 0 to ComponentCount - 1 do
  begin
    if Components[ix] is TPanel then
    begin
      pnl := TPanel(Components[ix]);
      case pnl.Tag of
        1: pnl.Color := clRed;
        2: pnl.Color := clBlue;
      else
        pnl.Color := clBtnFace;
      end;
    end;
  end;

Try placing the above code in a button OnClick event handler (having dropped some TPanels on the form with different Tag values).

How to read very large text files fast

Problem/Question/Abstract:

Does anyone know the fastest way to read large text files (10Mb) into a string. Readln is just too slow.

Answer:

Solve 1:

You may try this:

function R(const FileName: string): string;
var
  M: TFileStream;
begin
  M := TFileStream.Create(FileName, fmOpenRead);
  try
    SetLength(Result, M.Size);
    M.Read(Result[1], M.Size);
  finally
    M.Free;
  end;
end;


Solve 2:

As an alternative to Christian's suggestion, you can also use a memory-mapped file:

function MMFileToString(const AFilename: string): string;
var
  hFile: THandle;
  hFileMap: THandle;
  hiSize: DWORD;
  loSize: DWORD;
  text: string;
  view: pointer;
begin
  Result := '';
  if AFilename = '' then
    Exit;
  if not FileExists(AFilename) then
    Exit;
  {Open the file}
  hFile := CreateFile(PChar(AFilename), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile <> INVALID_HANDLE_VALUE then
  begin
    loSize := GetFileSize(hFile, @hiSize);
    {File was opened successfully, now map it:}
    hFileMap := CreateFileMapping(hFile, nil, PAGE_READONLY, hiSize,
                 loSize, 'TextForString');
    if (hFileMap <> 0) then
    begin
      if (GetLastError() = ERROR_ALREADY_EXISTS) then
      begin
        MessageDlg('Mapping already exists - not created.', mtWarning, [mbOk], 0);
        CloseHandle(hFileMap)
      end
      else
      begin
        try
          {File mapped successfully, now map a view of the file into
                                        the address space:}
          view := MapViewOfFile(hFileMap, FILE_MAP_READ, 0, 0, 0);
          if (view <> nil) then
          begin {View mapped successfully}
            CloseHandle(hFile);
                                                {Close file handle - as long is view is open it will persist}
            SetLength(Result, loSize);
            Move(view^, Result[1], loSize);
          end
          else
            MessageDlg('Unable to map view of file. ' + SysErrorMessage(GetLastError),
              mtWarning, [mbOk], 0);
        finally
          UnmapViewOfFile(view); {Close view}
          CloseHandle(hFileMap); {Close mapping}
        end
      end
    end
    else
    begin
      MessageDlg('Unable to create file mapping. ' + SysErrorMessage(GetLastError),
        mtWarning, [mbOk], 0);
    end;
  end
  else
  begin
    MessageDlg('Unable to open file. ' + SysErrorMessage(GetLastError),
                 mtWarning, [mbOk], 0);
  end;
end;

Display forms full screen

Problem/Question/Abstract:

How can I show a form so that it covers all available screen space including the taskbar?

Answer:

Covering the entire screen with a form is relatively easy to accomplish as shown below.

procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
  { Position form }
  Top := 0;
  Left := 0;

  { Go full screen }
  WindowState := wsmaximized;
  ClientWidth := Screen.Width;
  ClientHeight := Screen.Height;
  Refresh;
end;

If this is a typical form it will have borders which you might consider removing by setting BorderStyle property to bsNone as shown below.

procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
  { Position form }
  Top := 0;
  Left := 0;

  { Go full screen }
  BorderStyle := bsNone;
  WindowState := wsmaximized;
  ClientWidth := Screen.Width;
  ClientHeight := Screen.Height;
  Refresh;
end;

Sometimes the code shown above will go full screen but still display the Windows TaskBar, if this happens we can force the form on top using either SetForeGroundWindow or SetActiveWindow. From my testing it is best to use both if the problem persist.

procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
  { Position form }
  Top := 0;
  Left := 0;

  { Go full screen }
  BorderStyle := bsNone;
  WindowState := wsmaximized;
  ClientWidth := Screen.Width;
  ClientHeight := Screen.Height;
  Refresh;
  SetForegroundWindow(Handle);
  SetActiveWindow(Application.Handle);
end;

Other  considerations (see attachment for code to address these items) If the form is already in maximized window state the above code will not work. Controlling the system menu commands as per above needs to be considered Ghost items in the TaskBar after terminating your application.  

Delphi makes it simple to cover the display screen but what if you need to duplicate the functionality in another programming language such as Microsoft Visual Basic? Well in this case you might want to learn the API methods (again see attachment).


Component Download: KG_FullScreen.zip

Create a virtual drive

Problem/Question/Abstract:

Does anybody know how to create a virtual drive from a Delphi program?

Answer:

You can try this. I tested it in Windows ME and it works ok.

{ ... }
if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then
  ShowMessage('Drive was created successfully')
else
  ShowMessage('Error creating drive");
    { ... }

Storing color values in the registry/INI files

Problem/Question/Abstract:

Storing color values in the registry/INI files

Answer:

The GraphicsUnit has two useful functions:

StringToColor and ColorToString.

StringToColor will receive one of the valid 37 colors (such as clWhite) or a number (as a string) representing the color and return a TColor for it.

ColorToString will do the reverse.

Nice if you want to store colors as a name instead of a number.

Setting read-only columns in StringGrid

Problem/Question/Abstract:

Setting read-only columns in StringGrid

Answer:

In the OnSelectCell event, this works fine (every even column is editable)


if Col mod 2 = 0 then
  grd.Options := grd.Options + [goEditing]
else
  grd.Options := grd.Options - [goEditing];

How to extend the maximum length of a TRichEdit

Problem/Question/Abstract:

I'm trying to load a 200kb file into a richedit but cannot add any new text to it. I can delete and replace, but not add.

Answer:

Probably the MaxLength of the TRichEdit gets set to the file size. Set it to something several times larger than the file after load, e.g.

with richedit1 do
  maxLength := 10 * GetTextLen;

How to connect to a mySQL database

Problem/Question/Abstract:

How to connect to a mySQL database

Answer:

Perhaps you have already seen the uses clause. You may download mySQL.pas from www.fichtner.net/delphi

uses mySQL;

procedure Connect;
var
  myServer: PMysql;
  Tables: PMYSQL_RES;
  TableRows: my_ulonglong;
  Table: PMYSQL_ROW;
begin
  myServer := mysql_init(nil);
  if myServer <> nil then
  begin
    if mysql_options(myServer, MYSQL_OPT_CONNECT_TIMEOUT, '30') = 0 then
    begin
      if mysql_real_connect(myServer, 'host', 'user', 'password', 'database', 3306,
        nil, CLIENT_COMPRESS) <> nil then
      begin
        Tables := mysql_list_tables(myServer, nil);
        if Tables <> nil then
        begin
          TableRows := mysql_num_rows(Tables);
          while TableRows > 0 do
          begin
            Table := mysql_fetch_row(Tables);
            Tabelle := Table[0];
            Dec(TableRows);
          end;
        end;
      end;
    end;
  end;
end;

Get special Windows folder location

Problem/Question/Abstract:

How to get special Windows folder location

Answer:

Solve 1:

uses
...ShlObj...

var
SFolder: pItemIDList;
SpecialPath: array[0..MAX_PATH] of Char;
begin
        SHGetSpecialFolderLocation(Form1.Handle, CSIDL_STARTUP, SFolder);
        SHGetPathFromIDList(SFolder, SpecialPath);
  Label1.Caption := StrPas(SpecialPath);
end;

Other folders :

CSIDL_BITBUCKET
CSIDL_CONTROLS
CSIDL_DESKTOP - WINDOWS\Desktop
CSIDL_DESKTOPDIRECTORY - WINDOWS\Desktop
CSIDL_DRIVES
CSIDL_FONTS - WINDOWS\FONTS
CSIDL_NETHOOD - WINDOWS\NetHood
CSIDL_NETWORK
CSIDL_PERSONAL - X:\My Documents
CSIDL_PRINTERS
CSIDL_PROGRAMS - WINDOWS\StartMenu\Programs
CSIDL_RECENT - WINDOWS\Recent
CSIDL_SENDTO - WINDOWS\SendTo
CSIDL_STARTMENU - WINDOWS\Start Menu
CSIDL_STARTUP - WINDOWS\Start Menu\Programs\StartUp
CSIDL_TEMPLATES - WINDOWS\ShellNew


Solve 2:

function WinAPI_GetWindowsDirectory: string;
begin
  SetLength(Result, MAX_PATH);
  SetLength(Result, GetWindowsDirectory(pchar(Result), MAX_PATH));
end;

function WinAPI_GetSystemDirectory: string;
begin
  SetLength(Result, MAX_PATH);
  SetLength(Result, GetSystemDirectory(pchar(Result), MAX_PATH));
end;

In fact you can get just about every special folder location

function WinAPI_SHGetSpecialFolderLocation(nFolder: integer): string;
var
  pidl: PItemIDList;
begin
  SHGetSpecialFolderLocation(0, nFolder, pidl);
  SetLength(Result, MAX_PATH);
  SHGetPathFromIDList(pidl, pchar(Result));
  SetLength(Result, pchar_StrLen(pchar(Result)));
end;


Solve 3:

function GetSystemPath(Folder: Integer): string;
var
  PIDL: PItemIDList;
  Path: LPSTR;
  AMalloc: IMalloc;
begin
  Path := StrAlloc(MAX_PATH);
  SHGetSpecialFolderLocation(Application.Handle, Folder, PIDL);
  if SHGetPathFromIDList(PIDL, Path) then
    Result := Path;
  SHGetMalloc(AMalloc);
  AMalloc.Free(PIDL);
  StrDispose(Path);
end;

Copy selected data from a TStringGrid to the clipboard

Problem/Question/Abstract:

I have various TStringGrid objects within my application and I want to allow the user to copy selected data to the clipboard for insertion into other programs such as Excel.

Answer:

Solve 1:

var
  S: string;
  i, k: Integer;
begin
  S := EmptyStr;
  with StringGrid1 do
  begin
    for i := FixedRows to RowCount - 1 do
    begin
      for k := FixedCols to ColCount - 1 do
      begin
        if k > FixedCols then
          S := S + #9;
        S := S + Cells[k, i];
      end;
      S := S + #13#10;
    end;
  end;
  Clipboard.AsText := S;

This generates a string in which columns are separated by Tab characters and rows by CR/LF linebreaks. Most spreadsheets are able to paste this into cells correctly.

Same for the selection in a grid:

S := '';
with grid do
  for i := Selection.Top to Selection.Bottom do
  begin
    for k := Selection.Left to Selection.Right do
    begin
      S := S + Cells[k, i];
      if k <> Selection.Right then
        S := S + #9;
    end;
    S := S + #13#10;
  end;
Clipboard.AsText := S;


Solve 2:

Here is how you can copy a selection.

uses
  ClipBrd;

procedure CopyGridSelectionToClipBoard(Grid: TStringGrid; Selection: TGridRect);
const
  TAB = Chr(VK_TAB);
  CR = #13;
var
  r, c: integer;
  S: string;
begin
  S := '';
  for r := Selection.Top to Selection.Bottom do
  begin
    for c := Selection.Left to Selection.Right do
    begin
      S := S + Grid.Cells[c, r];
      if c < Selection.Right then
        S := S + TAB;
    end;
    if r < Selection.Bottom then
      S := S + CR;
  end;
  ClipBoard.SetTextBuf(PChar(S));
end;

Pasting would be the reverse. An idea would be to get the text from the clipboard and assign it to a TStringList. This way you'll know how many rows you have.

var
  F: TStringList;
begin
  F := TStringList.Create;
  F.Text := Clipboard.AsText;
  F.Free;
end;

You'll still need to parse each row to get the columns.

By the way, you can use the text you copied with the above procedure to paste into Excel. Excel knows how to parse it if you use the TAB to delimit columns.

Open a form based on a text value

Problem/Question/Abstract:

In Access and PB applications, I have implemented menus based on database tables. Ie., you select a particular entry and it load a particular form based on the text in the table. The question is, how do I do something similar in Delphi?

Answer:

Solve 1:

Let's assume that you want to show one of the forms of class TForm1, TForm2 or TForm3 and that the classname is held in a string called FormString.

Add the units holding the forms to a Uses statement - implementation section if possible (i.e Uses Form1, Form2, Form3)

Add an initialization section (before final end.):

initialization
  RegisterClasses([TForm1, TForm2, TForm3]);
end.

Write a procedure to show a form. For example:

procedure TForm1.ShowForm(const fname: string);
begin
  with TFormClass(FindClass(fname)).Create(Application) do
  try
    ShowModal;
  finally
    Free;
  end;
end;

Thus you would call this via:

ShowForm(FormString);


Solve 2:

Yes, you can do this. The requirement is that you register all your forms (at least those that need to be created by name) using the RegisterClass method. That adds the form class and its name to an internal list maintained by the VCL. You can now call FindClass or GetClass to get the class reference back using the class name.

var
  fc: TFormClass; {class of TForm, a class reference type}
  form: TForm;
begin
  fc := TFormClass(getClass(formclassnamefromdatabase));
  if Assigned(fc) then
  begin
    form := fc.Create(Application);
    try
      form.ShowModal
    finally
      form.free
    end;
  end;
end;

The main problem here is that you cannot use the default form variables the IDE puts into the form units Interface, so better delete them to prevent accidental references to them. There is no mechanism to find a variable by name build into the VCL, but if you really need to use the form variables you could build your own registration mechanism that would build a list associating form class name, the form class, and the address of the form variable.

Once the form is created you can find a reference to it from elsewhere in the app by iterating through the Screen.Forms array, looking for a form with a specific class name.


Solve 3:

Here are a couple of approaches. As long as you are only accessing Methods and Properties common to TForm, the following will work for you. Pay special attention to the RegisterClasses call in the initialization section:

unit GenericFormCreate;

interface

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

type
  TFrmGenericFormCreate = class(TForm)
    BtnCreateFromString: TButton;
    BtnCreateFromClass: TButton;
    RgrSelect: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure BtnCreateFromStringClick(Sender: TObject);
    procedure BtnCreateFromClassClick(Sender: TObject);
  private
    procedure CreateFromClass(AForm: TClass);
    procedure CreateFromClassName(AForm: string);
  public
  end;

var
  FrmGenericFormCreate: TFrmGenericFormCreate;

implementation

{$R *.DFM}

uses
  Unit2, Unit3;

procedure TFrmGenericFormCreate.FormCreate(Sender: TObject);
begin
  RgrSelect.ItemIndex := 0;
end;

procedure TFrmGenericFormCreate.CreateFromClass(AForm: TClass);
begin
  with TFormClass(AForm).Create(Application) do
  try
    ShowModal;
  finally
    Release;
  end;
end;

procedure TFrmGenericFormCreate.CreateFromClassName(AForm: string);
begin
  try
    with TFormClass(FindClass(AForm)).Create(Application) do
    try
      ShowModal;
    finally
      Release;
    end;
  except
    ShowMessage(Format('Class %s not found', [AForm]));
  end;
end;

procedure TFrmGenericFormCreate.BtnCreateFromStringClick(Sender: TObject);
begin
  CreateFromClassName('TForm' + IntToStr(RgrSelect.ItemIndex + 2));
  RgrSelect.SetFocus;
end;

procedure TFrmGenericFormCreate.BtnCreateFromClassClick(Sender: TObject);
begin
  case RgrSelect.ItemIndex of
    0: CreateFromClass(TForm2);
    1: CreateFromClass(TForm3);
  end;
  RgrSelect.SetFocus;
end;

initialization
  RegisterClasses([TForm2, TForm3]);
end.

How to draw a hexagon

Problem/Question/Abstract:

How to draw a hexagon

Answer:

Solve 1:

procedure PlotPolygon(const Canvas: TCanvas; const N: Integer; const R: Single;
  const XC: Integer; const YC: Integer);
type
  TPolygon = array of TPoint;
var
  Polygon: TPolygon;
  I: Integer;
  C: Extended;
  S: Extended;
  A: Single;
begin
  SetLength(Polygon, N);
  A := 2 * Pi / N;
  for I := 0 to (N - 1) do
  begin
    SinCos(I * A, S, C);
    Polygon[I].X := XC + Round(R * C);
    Polygon[I].Y := YC + Round(R * S);
  end;
  Canvas.Polygon(Polygon);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W: Single;
  H: Single;
  X: Integer;
  Y: Integer;
const
  N = 6;
  R = 10;
begin
  W := 1.5 * R;
  H := R * Sqrt(3);
  for X := 0 to Round(ClientWidth / W) do
    for Y := 0 to Round(ClientHeight / H) do
      if Odd(X) then
        PlotPolygon(Canvas, N, R, Round(X * W), Round((Y + 0.5) * H))
      else
        PlotPolygon(Canvas, N, R, Round(X * W), Round(Y * H));
end;


Solve 2:

unit HexGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Math;

type

  TOrientation = (hxVertical, hxhorizontal);

  THexGrid = class(TCustomPanel)
  private
    FOrientation: TOrientation;
    FHexSize: Integer;
    FPoints: array[0..5] of TPoint;
    FDisplayCaption: Boolean;
    procedure ChangedDimensions;
    procedure SetOrientation(Value: TOrientation);
    procedure SetHexSize(const Value: Integer);
    procedure DrawVerticalGrid;
    procedure DrawhorizontalGrid;
    procedure SetDisplayCaption(Value: Boolean);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
    property Orientation: TOrientation read FOrientation write SetOrientation;
  published
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BiDiMode;
    property BorderWidth;
    property BorderStyle;
    property Caption;
    property Color;
    property Constraints;
    property Ctl3D;
    property UseDockManager default True;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FullRepaint;
    property Font;
    property Locked;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property Left;
    property Top;
    property Width;
    property Height;
    property Cursor;
    property Hint;
    property HelpType;
    property HelpKeyword;
    property HelpContext;
    property HexSize: Integer read FHexSize write SetHexSize;
    property DisplayCaption: Boolean read FDisplayCaption write SetDisplayCaption;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [THexGrid]);
end;

procedure THexGrid.ChangedDimensions;
var
  I: Integer;
begin
  for I := 0 to High(FPoints) do
  begin
    FPoints[I].X := 0;
    FPoints[I].Y := 0;
  end;
  if Orientation = hxhorizontal then
  begin
    FPoints[0].X := Hexsize div 4;
    FPoints[1].X := HexSize - (Hexsize div 4);
    FPoints[2].X := HexSize;
    FPoints[2].Y := HexSize div 2;
    FPoints[3].X := HexSize - (Hexsize div 4);
    FPoints[3].Y := HexSize;
    FPoints[4].X := HexSize div 4;
    FPoints[4].Y := HexSize;
    FPoints[5].Y := HexSize div 2;
  end;
  if Orientation = hxVertical then
  begin
    FPoints[0].X := HexSize div 2;
    FPoints[1].X := HexSize;
    FPoints[1].Y := HexSize div 4;
    FPoints[2].X := HexSize;
    FPoints[2].Y := HexSize - (Hexsize div 4);
    FPoints[3].X := HexSize div 2;
    FPoints[3].Y := HexSize;
    FPoints[4].Y := HexSize - (Hexsize div 4);
    FPoints[5].Y := HexSize div 4;
  end;
end;

procedure THexGrid.SetOrientation(Value: TOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    ChangedDimensions;
    invalidate;
  end;
end;

procedure THexGrid.SetHexSize(const Value: Integer);
begin
  if FHexSize <> Value then
  begin
    FHexSize := Value;
    ChangedDimensions;
    invalidate;
  end;
end;

constructor THexGrid.Create(AOwner: TComponent);
begin
  inherited;
  FOrientation := hxVertical;
  FHexSize := 64;
  ChangedDimensions;
  Width := 128;
  Height := 128;
end;

procedure THexGrid.Paint;
begin
  inherited;
  if Orientation = hxhorizontal then
    DrawhorizontalGrid
  else
    DrawVerticalGrid;
end;

procedure THexGrid.DrawhorizontalGrid;
var
  I: Integer;
  X, Y, Offset: Integer;
  FHex: array[0..5] of TPoint;
begin
  X := 0;
  Y := 0;
  Offset := 0;
  while X + HexSize < Width do
  begin
    Y := 0;
    while Y + HexSize < Height do
    begin
      with Self.Canvas do
      begin
        for I := 0 to High(FPoints) do
        begin
          FHex[I].X := X + FPoints[I].X;
          FHex[I].Y := Y + FPoints[I].Y + Offset;
        end;
        Polygon(FHex);
      end;
      Y := Y + HexSize;
    end;
    if Offset = 0 then
      Offset := (0 - (HexSize div 2))
    else
      Offset := 0;
    X := X + (HexSize - (HexSize div 4));
  end;
end;

procedure THexGrid.DrawVerticalGrid;
var
  I: Integer;
  X, Y, Offset: Integer;
  FHex: array[0..5] of TPoint;
begin
  X := 0;
  Y := 0;
  Offset := 0;
  while Y + HexSize < Height do
  begin
    X := 0;
    while X + HexSize < Width do
    begin
      with Self.Canvas do
      begin
        for I := 0 to High(FPoints) do
        begin
          FHex[I].X := X + FPoints[I].X + Offset;
          FHex[I].Y := Y + FPoints[I].Y;
        end;
        Polygon(FHex);
      end;
      X := X + HexSize;
    end;
    if Offset = 0 then
      Offset := (0 - (HexSize div 2))
    else
      Offset := 0;
    Y := Y + (HexSize - (HexSize div 4));
  end;
end;

procedure THexGrid.SetDisplayCaption(Value: Boolean);
begin
end;

end.

How to save a TJPEGImage to a blob field

Problem/Question/Abstract:

How to save a TJPEGImage to a blob field

Answer:

{ ... }
var
  mem: TMemoryStream;
begin
  mem := tmemorystream.create;
  try
    table1.open;
    table1blobfield.savetostream(mem);
    mem.seek(0, 0);
    jpeg1.loadfromstream(mem);
  finally
    mem.free;
  end;
end;

Sort rows in a TStringGrid

Problem/Question/Abstract:

How to sort rows in a TStringGrid

Answer:

type
  TMoveSG = class(TCustomGrid); {reveals protected MoveRow procedure}

procedure SortGridByCols(Grid: TStringGrid; ColOrder: array of integer);
var
  i, j: integer;
  Sorted: boolean;

  function Sort(Row1, Row2: integer): integer;
  var
    C: integer;
  begin
    C := 0;
    result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1],
      Grid.Cols[ColOrder[C]][Row2]);
    if result = 0 then
    begin
      Inc(C);
      while (C <= High(ColOrder)) and (result = 0) do
      begin
        result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1],
          Grid.Cols[ColOrder[C]][Row2]);
        Inc(C);
      end;
    end;
  end;

begin
  if SizeOf(ColOrder) div SizeOf(i) <> Grid.ColCount then
    exit;
  for i := 0 to High(ColOrder) do
    if (ColOrder[i] < 0) or (ColOrder[i] >= Grid.ColCount) then
      exit;
  j := 0;
  Sorted := false;
  repeat
    inc(j);
    with Grid do
      for i := 0 to RowCount - 2 do
        if Sort(i, i + 1) > 0 then
        begin
          TMoveSG(Grid).MoveRow(i + 1, i);
          Sorted := false;
        end;
  until
    Sorted or (j = 1000);
  Grid.Repaint;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  c, r: integer;
begin
  {just fills with random numbers for example}
  for r := 0 to StringGrid1.RowCount - 1 do
  begin
    for c := 0 to StringGrid1.ColCount - 1 do
    begin
      StringGrid1.Cols[c][r] := Format('%.3d', [Random(255)]);
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {example}
  SortGridByCols(StringGrid1, [1, 0, 2, 3, 4]);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;
end;

How to move a TImage on a scrollbox

Problem/Question/Abstract:

I placed some TImage components on a TScrollBox. Now I would like my users to be able to scroll these images by clicking on them and moving the cursor with the mouse button down.

Answer:

Attach handlers to the OnMouseDown, Move, Up events of the image. Modify as below. The key here is to not use the X and Y mouse positions the handlers get. Each time the image is scrolled the origin for this position moves and that screws up the calculation. The code below uses the screen-relative mouse position.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Image1: TImage;
    Label1: TLabel;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    FLastDown: TPoint;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  GetCursorPos(FLastDown);
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FLastDown := Point(-1, -1);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  pt: TPoint;
begin
  if (ssLeft in Shift) and (FLastDown.X >= 0) then
  begin
    GetCursorPos(pt);
    Scrollbox1.VertScrollBar.Position := Scrollbox1.VertScrollBar.Position + FLastDown.Y - pt.Y;
    Scrollbox1.HorzScrollBar.POsition := Scrollbox1.HorzScrollBar.Position + FLastDown.X - pt.X;
    FLastDown := pt;
    label1.caption := format('%d:%d', [pt.x, pt.y]);
  end;
end;

end.

How to search a string with wildcards

Problem/Question/Abstract:

I have a body of text. I want to allow the user to enter a string that could contain wildcards (well, just the " * ") and search for it.

Answer:

Your first task is to split the paragraph into words (since i take it from your description that the match has to be inside a word). The next is to match each word to the mask. The following implementation is certainly not the fastest possible but it should make the algorithm clear.


procedure SplitTextIntoWords(const S: string; words: TStringlist);
var
  startpos, endpos: Integer;
begin
  Assert(Assigned(words));
  words.clear;
  startpos := 1;
  while startpos <= Length(S) do
  begin
    {skip non-letters }
    while (startpos <= Length(S)) and not IsCharAlpha(S[startpos]) do
      Inc(startpos);
    if startpos <= Length(S) then
    begin
      {find next non-letter}
      endpos := startpos + 1;
      while (endpos <= Length(S)) and IsCharAlpha(S[endpos]) do
        Inc(endpos);
      words.add(Copy(S, startpos, endpos - startpos));
      startpos := endpos + 1;
    end;
  end;
end;

function StringMatchesMask(S, mask: string; case_sensitive: Boolean): Boolean;
var
  sIndex, maskIndex: Integer;
begin
  if not case_sensitive then
  begin
    S := AnsiUpperCase(S);
    mask := AnsiUpperCase(mask);
  end;
  Result := True; {blatant optimism}
  sIndex := 1;
  maskIndex := 1;
  while (sIndex <= Length(S)) and (maskIndex <= Length(mask)) do
  begin
    case mask[maskIndex] of
      '?':
        begin
          {matches any character}
          Inc(sIndex);
          Inc(maskIndex);
        end;
      '*':
        begin
          {matches 0 or more characters, so need to check for next character in mask}
          Inc(maskIndex);
          if maskIndex > Length(mask) then
            { * at end matches rest of string}
            Exit
          else if mask[maskindex] in ['*', '?'] then
            raise Exception.Create('Invalid mask');
          {look for mask character in S}
          while (sIndex <= Length(S)) and (S[sIndex] <> mask[maskIndex]) do
            Inc(sIndex);
          if sIndex > Length(S) then
          begin
            {character not found, no match}
            Result := false;
            Exit;
          end;
        end;
    else
      if S[sIndex] = mask[maskIndex] then
      begin
        Inc(sIndex);
        Inc(maskIndex);
      end
      else
      begin
        {no match}
        Result := False;
        Exit;
      end;
    end;
  end;
  {if we have reached the end of both S and mask we have a complete match,
  otherwise we only have a partial match}
  if (sIndex <= Length(S)) or (maskIndex <= Length(mask)) then
    Result := false;
end;

procedure FindMatchingWords(const S, mask: string; case_sensitive: Boolean;
  matches: TStringlist);
var
  words: TStringlist;
  i: Integer;
begin
  Assert(Assigned(matches));
  words := TStringlist.Create;
  try
    SplitTextIntoWords(S, words);
    matches.clear;
    for i := 0 to words.count - 1 do
    begin
      if StringMatchesMask(words[i], mask, case_sensitive) then
        matches.Add(words[i]);
    end;
  finally
    words.free;
  end;
end;

{Form has one memo for the text to check, one edit for the mask, one checkbox
(check = case sensitive), one listbox for the results, one button }

procedure TForm1.Button1Click(Sender: TObject);
begin
  FindMatchingWords(memo1.text, edit1.text, checkbox1.checked, listbox1.items);
end;

How to make a popup menu appear at a certain position over the Windows Taskbar

Problem/Question/Abstract:

I create my popup menu items dynamically (not ownerdrawn). To place the popup menu at the right position (above a component), I need to determine (read) the menu item height. How would I do this?

Answer:

It's quite shocking but the API offers no way to do this. The API method to get a menu to pop up in a given area is TrackPopupMenuEx. Unfortunately it is not easily applicable with a Delphi popup menu, since you cannot get the handle of the tool window the Menus unit uses to process the menu messages. So you would have to duplicate that windows message processing in another window you can get at, e.g. the form.

Make a popup menu pop up over the taskbar, bottom aligned to taskbar top:

procedure TForm1.Button1Click(Sender: TObject);
var
  pm: TTPMParams;
  DisplayPoint: TPoint;
  r: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
  r.top := r.bottom + 1;
  r.bottom := screen.height;
  DisplayPoint := Point(699, r.top);
  with pm, pm.rcexclude do
  begin
    Top := r.top;
    Bottom := r.bottom;
    Left := 0;
    Right := screen.width;
    cbSize := SizeOf(pm);
  end;
  TrackPopupMenuEx(PopupMenu1.Handle, TPM_VERTICAL or TPM_HORIZONTAL,
    DisplayPoint.x, DisplayPoint.y, Handle, @pm);
end;

How to determine the RAM size of the display adapter

Problem/Question/Abstract:

Which Win API function can give me the amount of memory of my computer's display adapter?

Answer:

EnumDisplaySettings gives you the different settings for the adapter. The amount of RAM can then be calculated (width * height * colors).


procedure TForm1.Button1Click(Sender: TObject);
var
  DevMode: TDeviceMode;
  i, m, max: Integer;
begin
  max := 0;
  i := 0;
  while EnumDisplaySettings(nil, i, DevMode) do
  begin
    with DevMode do
      m := Round(dmPelsWidth * dmPelsHeight * (dmBitsPerPel / 8));
    if m > max then
      max := m;
    inc(i);
  end;
  label1.caption := IntToStr(max);
end;

How to create a TComboBox with incremental search capabilities

Problem/Question/Abstract:

Is there a way to let a TComboBox do incremental search in its drop down list? Currently it uses only the first letter so if multiple items start with the same letter it's not very useful.

Answer:

Create a new Combo inherited from class(TcustomComboBox) and change the Change Event to the following few lines:

{...}
protected

procedure Change; override;
{...}

  procedure TExtComboBox.Change;
  var
    str: string;
    Index: Integer;
  begin
    inherited Change;
    str := Text;
    if (FLastKey = VK_DELETE) or (FLastKey = VK_BACK) then
    begin
      SelStart := Length(str);
      SelLength := 0;
      Exit;
    end;
    {try to find the closest matching item}
    Index := Perform(CB_FINDSTRING, -1, LPARAM(str));
    if Index <> CB_ERR then
    begin
      ItemIndex := Index;
      SelStart := Length(str);
      SelLength := Length(Items[Index]) - SelStart;
    end
    else
      Text := str;
    {call standard event}
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end.

Get the width and height of a bitmap without opening the file

Problem/Question/Abstract:

How to get the width and height of a bitmap without opening the file

Answer:

A bitmap starts with a file header (TBitmapFileHeader). Then followed by a bitmap info header, dependent on the bitmap version. The first DWORD contains the size of the info structure, so you can read and analyze this to chose the correct handling. Bitmap version 2 uses a TBitmapCoreHeader. The width and height value follow in the next two Words. Version 3 uses a TBitmapInfoHeader, version 4 a TBitmapV4Header and version 5 a TBitmapV5Header. In all these headers the width and height follow in the next two LongInts.

You can use this information to build a function to get at the width and height data. The following is untested and you should add a check, to see whether the file is a bitmap or not:

function GetBitmapSizeFromFile(const Filename: string; var Width, Height: Integer):
  Boolean;
type
  TBitmapHeaders = packed record
    FileHeader: TBitmapFileHeader;
    case Integer of
      2: (CoreHeader: TBitmapCoreHeader);
      3: (InfoHeader: TBitmapInfoHeader);
  end;
var
  fs: TFileStream;
  Headers: TBitmapHeaders;
begin
  Result := False;
  fs := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
  try
    f.ReadBuffer(Headers, SizeOf(Headers));
    {Check the bitmap}
    { ... }
    {Get the size}
    case Headers.CoreHeader.bcSize of
      SizeOf(TBitmapCoreHeader):
        begin
          Width := Headers.CoreHeader.bcWidth;
          Height := Headers.CoreHeader.bcHeight;
          Result := True;
        end;
      SizeOf(TBitmapInfoHeader), SizeOf(TBitmapV4Header), SizeOf(TBitmapV5Header):
        begin
          Width := Headers.InfoHeader.biWidth;
          {Negative Height values are possible -> Abs}
          Height := Abs(Headers.InfoHeader.biHeight);
          Result := True;
        end;
    else
      {Place a special error message, i.e. wrong header, here}
    end;
  finally
    f.Free;
  end;
end;

The pixel data start at the file position Headers.FileHeader.bfOffBits. Read the data from the file. For more information on the pixel data, read the WinAPI help, e.g. the topic BITMAPINFOHEADER.

How to get the first visible line in a TRichEdit

Problem/Question/Abstract:

How can I get the number of the first line that is shown in a TRichEdit when it has been scrolled down?

Answer:

Take a look at source of messages.pas unit and search for "EM_" to see a list of related messages.

RichEdit1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0)

How to create a MessageBox with a timeout

Problem/Question/Abstract:

I need to create a messagebox asking the user to reply either Yes or No, but with a timeout. Is there a way to use a messagebox function with some timeout, like open messagebox with Yes or No, and after 20 seconds reply with other information to know that user is out?

Answer:

Solve 1:

Show the MessageBox in another thread and kill the thread when you want to remove the messagebox under program control:

{ ... }
var
  ThreadId: Integer;
  ThreadHandle: Integer;
  MsgResult: Integer;

function thread_proc(p: Pointer): integer; stdcall;
begin
  MsgResult := MessageBox(0, 'Some question?', 'Hey', MB_ICONQUESTION or MB_YESNO);
  ThreadHandle := 0;
  EndThread(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  counter: integer;
begin
  MsgResult := IDNO; {default answer}
  {show MessageBox}
  ThreadHandle := BeginThread(nil, 0, @Thread_proc, nil, 0, ThreadID);
  counter := 20; {wait for 20 seconds}
  while (ThreadHandle <> 0) and (counter > 0) do
  begin
    Sleep(1000);
    counter := counter - 1;
  end;
  {if MessageBox is still visible after 20 seconds, remove it}
  if Counter = 0 then
    TerminateThread(ThreadHandle, 0);
  if MsgResult = IDYES then
    { ... }
  else
    { ... }
end;


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  R: Integer;
begin
  Timer1.Interval := 20000;
  Timer1.Enabled := true;
  R := MessageDlg('Yes or no?', mtConfirmation, [mbYes, mbNo], 0);
  Caption := IntToStr(R);
  Timer1.Enabled := false;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  F: TForm;
begin
  F := Screen.ActiveForm;
  if fsModal in F.FormState then
    F.ModalResult := mrYesToAll;
end;

Force a drop-down combo to drop its list down

Problem/Question/Abstract:

How can I force a drop-down combo to drop its list down?

Answer:

This is done by using a Windows message called CB_SHOWDROPDOWN.

I recommend that you look in the WinAPI help under messages to see what else you can do with them.

The nice thing about messaging in Windows is that the calls are all handled through the Windows API SendMessage routine, which requires four parameters:

Parameters of SendMessage function
Window Handle (can be an object handle)
Message &#8212; specifies the message to be sent (in our case, CB_SHOWDROPDOWN)
wParam, a 16-bit message-dependent parameter
lParam, a 32-bit message-dependent parameter (see WinHelp for specifics on what goes into wParam and lParam)

The gist of this is that Windows messages are performed in a very standard way, so if you haven't done them much, I encourage you to investigate ways to employ them in your code.

To get a combo-box list to automatically drop down when you enter it, put the following code into the OnEnter event:

procedure TForm1.ComboBox1Enter(Sender: TObject);
begin
  SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;

Likewise, you can close the drop-down when you exit by putting the following code into the OnExit event of the combo box:

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
  SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(False), 0);
end;

This is probably how the Intuit guys did it with Quicken. So go for it!

How to create a random "Tip of the Day" from a Paradox table

Problem/Question/Abstract:

How to create a random "Tip of the Day" from a Paradox table

Answer:

Here's a rather simple example of how to reduce your exe size by randomly retrieving a typical "Tip of the Day" (with associated image) from a table instead of getting it from a resource file. It uses a Paradox table with the following structure:


Number (FieldName)
(Type: Alpha)
Text (FieldName)
(Type: Blob)
Image (FieldName)
(Type: Blob)
1 (Variable I)
RTF
JPG Image
2
RTF
JPG Image
3
RTF
JPG Image




The code should be self-explanatory, but you can also download a little sample project at the bottom of this page if you like. Please note, that there are only four records in the table. The same tip might therefore appear several times in a row when you click on the "Next Tip" button.

Here are the basic steps:

Create a new project and drop a TDataSource, a TTable and a TPanel on the main form. Place a TImage and a TDBRichEdit on the panel. Hook Table1 and DBRichEdit1 to Datasource1 and assign the field "Text" of Table1 to the DBRichEdit control. Finally, set table1.active to true.

Put JPEG into the Uses clause and in the private declarations of the main form, add this procedure ...

private
{Private Declarations}

procedure RandomTip;

... and define it as follows:

procedure TForm1.RandomTip;
var
  Stream1: TBlobStream;
  TipImage: TJPEGImage;
  I: Integer;
begin
  {Random(I) would pick a free random number}
  I := Random(4) + 1;
  {Take the random number, locate it in the field "Number" and jump to the record}
  table1.Locate('Number', I, [loPartialKey]);
  begin
    {Create a blobstream and read the stored jpg image from the blob
                 field into the stream}
    Stream1 := TBlobStream.Create(Table1.FieldByName('Image') as TBlobField, bmRead);
    TipImage := TJPEGImage.create;
    try
      {Load the JPEGImage from the blob stream and assign it to the TImage}
      TipImage.LoadFromStream(Stream1);
      Image1.Picture.Assign(TipImage);
    finally
      Stream1.Free;
      TipImage.Free;
    end;
  end;
end;

To initialize the random number generator, we need to call it (for example) in the OnCreate event handler of Form1. Randomize should only be called once in your application - best done probably in the main units Initialization section.

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize; {Call the random number generator}
end;

To fill the Tip of the Day from the table the first time, we call the RandomTip procedure in the OnShow event handler of Form1:

procedure TForm1.FormShow(Sender: TObject);
begin
  RandomTip;
end;

That's all there is to do. Dead easy, isn't it? This simple technique could also be used to display random splash screens or random backgrounds for forms in your program. Just use your imagination ...

Download sample project (32K)