Load and save a TStringGrid from/ to a stream

Problem/Question/Abstract:

I have a form with 4 StringGrids which I fill at run time with data. It takes some time to enter the data and so I thought it would save me some time if I could save and load the form with its data - something I've never done in Delphi before. I've sorted the menu and the dialogue boxes but what method do I have to write to save the form, its StringGrids and the data therein - simply?

Answer:

You will have noticed that the StringGrid is a control that does not allow you to enter strings into it at design-time. The reason is that the streaming system cannot handle array properties like Cells, so the standard component streaming is no use for your task. But you can write your own routines to save a StringGrids content, of course. Something like this for example:

procedure SaveGridToStream(aStream: TStream; aGrid: TStringGrid);
var
  i, k: Integer;
  iBuf: Integer;
  S: string;

  procedure WrInt(anInt: Integer);
  begin
    aStream.WriteBuffer(anInt, Sizeof(anInt));
  end;

begin
  with aGrid do
  begin
    WrInt(ColCount);
    WrInt(rowCount);
    for i := 0 to rowCount - 1 do
      for k := 0 to colCount - 1 do
      begin
        S := Cells[k, i];
        WrInt(Length(S));
        if Length(S) > 0 then
          aStream.WriteBuffer(S[1], Length(S));
      end;
  end;
end;

procedure LoadGridFromStream(aStream: TStream; aGrid: TStringGrid);
var
  i, k: Integer;
  iBuf: Integer;
  S: string;

  function RdInt: Integer;
  begin
    aStream.ReadBuffer(Result, Sizeof(Result));
  end;

begin
  with aGrid do
  begin
    ColCount := RdInt;
    RowCount := RdInt;
    for i := 0 to rowCount - 1 do
      for k := 0 to colCount - 1 do
      begin
        iBuf := RdInt;
        if iBuf > 0 then
        begin
          SetLength(S, iBuf);
          aStream.ReadBuffer(S[1], iBuf);
          Cells[k, i] := S;
        end;
      end;
  end;
end;

Creating visual objects at run-time

Problem/Question/Abstract:

Sometimes it's necessary to create a visual object, like a button or a label, at run time. Here I'll show how to do it with a simple example.

Answer:

To explain how to create a visual object at run-time, there's some simple notions that is necessary to understood. I'll try to explain it in a simple and fast way (so don't bother with any "less accurate" information). Simplifying things, objects have two things: properties and methods. A visual object is not different, it has properties, methods and can act on event handling.

A visual object's life cycle is just like any other object life cycle, it must be created, will "live" and at the end will die. Follwoing this three basic life cycle steps:

When creating a visual object, it's necessary to say who will be the parent, who will have it has a child. Example: when deploying a TPanel on a TForm, the TForm is the TPanels' parent, when deploying a TLabel on the TPanel, the TPanel is the TLabels' parent.
To give the object some "life", it's necessary to code the answer to an event. Example: the OnKeyUp event on a TForm tells the TForm what to do when the user releases a key.
When the object is no longer needed, it should be removed. Example: when you have a TLabel that you no long need, you delete it.

So, let's take a simple case to exemplefy this. Let's create a TButton and give it some life.

Start a new project, name your main form as "Form1" and specify these private variables:

MyButton: TButton;
IsAlive: Boolean;

Deploy a TButton on Form1, caption it as "Manage Button" and on the OnClick event write the following code:

// create the button
MyButton := TButton.Create(Form1);
with MyButton do
begin
  // setting the buttons' parent
  Parent := Form1;
  // setting the alignment and size
  Top := 50;
  Left := 10;
  Width := 100;
  // showing it
  Caption := "&It Works!";
  Visible := True;
end;

This creates the button when the "Manage Button" is pushed. Run the application and click the "Manage Button".

This is not really usefull util the button created ar run-time actually do anything, so let's give it life. Let's build a procedure able to respond to a OnClick event. On your Form1 private declaration write:

procedure MyButtonOnClickEvent(Sender: TObject);

and write the following code for it:

procedure TForm1.MyButtonOnClickEvent(Sender: TObject);
begin
  ShowMessage("Well, it really works!");
end;

How do we know this will work? Well, if you check the TButton help, you will see that the OnClick event has the same signature as the MyButtonOnClickEvent that was just coded. Whenever you need to build an event, check the documentation on that object's event and make a procedure with the same signature.

Now let's make the MyButtonOnClickEvent the OnClick event of the button, just add

OnClick := MyButtonOnClickEvent;

to the code, it should look like this now:

// create the button
MyButton := TButton.Create(Form1);
with MyButton do
begin
  // setting the buttons' parent
  Parent := Form1;
  // setting the alignment and size
  Top := 10;
  Left := 10;
  Width := 100;
  // making it respond to the OnClick event
  onClick := MyButtonOnClickEvent;
  // showing it
  Caption := "&It Works!";
  Visible := True;
end;

Now run it, click the "Manage Button" and then click the "It Works!" button! ;)

Now that the button has some "life", all it needs is to "die" to have a full life cycle. So, let's kill it by calling the standard destructor. Let's change the "Manage Button" code to create and destroy the MyButton button:

if IsAlive = False then
begin
  // create the button
  MyButton := TButton.Create(Form1);
  with MyButton do
  begin
    // setting the buttons' parent
    Parent := Form1;
    // setting the alignment and size
    Top := 10;
    Left := 10;
    Width := 100;
    // making it respond to the OnClick event
    onClick := MyButtonOnClickEvent;
    // showing it
    Caption := "&It Works!";
    Visible := True;
  end;
  IsAlive := True;
end
else
begin
  MyButton.Free; // kills the button
  IsAlive := False;
end;

The IsAlive flag will tell us if the button is alive or not. To be positive that this has no faults, the IsAlive variable should be initialized, let's fo it on Form1's OnShow event:

IsAlive := False;

Now run the application. Click the "Manage Button", click the "It Works!" button, click the "Manage Button" again.
Simple, isn't it ? :)

Database "index out of date" error

Problem/Question/Abstract:

I was testing a program I wrote and I received an error message saying, "Index is out of date." I have no idea what this error means. I have looked everywhere in my Delphi books for some help on this problem, and can't seem to find any information about it. Can you help me?

Answer:

This is a BDE/Paradox error message. For newbies, BDE error messages are daunting, cryptic messages. Actually, even for seasoned veterans, they can sometimes be real "stumpers." Unfortunately, there's no real good reference available that I know of, so all I can offer with respect to this error message is my experience.

The "Index out of date" message can mean a couple of things:

One of the more common causes of this error is one in which you have a couple of copies of a table existing on your network or machine. For instance, when I develop applications, I have my application tables residing in my development system, then have copies of them on my network. When I need to update my tables, I usually do the updates in my development system, then copy them over to my deployment system on the network. I've run into this exact error when I've copied only the table (.DB) file and not its accompanying index file(s) (.PX, .X01, .Y01, etc) as well. You see, when you update a table by changing it in any way, its index files are also resynched to reflect the changes. So if you copy just the table to a new place on your system and don't include its family members, you'll index files that aren't in synch with your table. Okay that's one cause.
The next cause could be just this: One of your indexes is corrupt. This could be due to sector errors on your hard disk, or the rare, but possible, direct corruption of an index. This usually happens if your program abended while performing an update to a table with an index of some sort. In that case, the index doesn't get updated.

But in any case, the only way I know of to correct the problem is to do the following:

Open up your table in Database Desktop.
Restructure it.
Define/Rebuild all your indexes.
Save the file.

How to filter on substrings within a string field's value

Problem/Question/Abstract:

How to filter on substrings within a string field's value

Answer:

In the TTable OnFilter event:

var
  sp, ss: ShortString
begin
  with DataSet do
  begin
    sp := FilterPosition.Text; {TEdit containing substring to be filtered}
    ss := AnsiUpperCase(FieldByName('MyField').asString);
    Accept := Pos(sp, ss) > 0;
  end;
end;

or with an SQL script:

SELECT * FROM MyTable
WHERE UPPER(MyField)LIKE "%UPPER(MySubstring)%";

How to check if a MDI child has been created or destroyed

Problem/Question/Abstract:

I have to write a kind of task list of all MDI child windows which are opened in the application. For this reason I tried to use the WM_PARENTNOTIFY to get an event, if a MDI child is created or destroyed. But I don't receive a message when the child windows are created or destroyed.

Answer:

Try the following:


const
  WM_AddWin = WM_User + 300;
  WM_DelWin = WM_User + 301;

type
  TForm1
    { ... }
  private

  procedure OnAddWindow(var msg: TMessage); message WM_AddWin;
  procedure OnDelWindow(var msg: TMessage); message WM_DelWin;
    public
end;

procedure TForm1.OnAddWindow(var msg: TMessage);
begin
  List.Add(Strpas(Pointer(msg.lparam)));
end;

procedure TForm1.OnDelWindow(var msg: TMessage);
begin
  List.delete(List.indexof(Strpas(Pointer(msg.lparam))));
end;

procedure OnChildFormCreate(Sender: TObject);
begin
  PostMessage(TForm(Owner).handle, WM_AddWin, 0, Integer(PChar('ChildFormname')));
end;

procedure OnChildFormDestroy;
begin
  PostMessage(TForm(Owner).handle, WM_DelWin, 0, Integer(PChar('ChildFormname')));
end;


This will post a message to the owner of a child form to add it to the master list and delete it
when it dies.

How to change file attributes

Problem/Question/Abstract:

How do I change the attributes of a file like write protection, hidden etc. ?

Answer:

var
  F_Attr: Word;

F_Attr := FileGetAttr('MyFile');

{Turn ReadOnly OFF}
FileSetAttr('MyFile', F_Attr and not faReadOnly);

How to implement autocompletion in a TEdit

Problem/Question/Abstract:

How to implement autocompletion in a TEdit

Answer:

Solve 1:

Here is a procedure using the OnKeyDown that will autocomplete an edit box using a lookup source table. Change it to suit your needs but it should give you an idea of how to do the selections and stuff with an edit control. This will work with just about any type of edit control and I use it for combo boxes as well. You just need to change the typecasting.

procedure TForm1.EditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var
  s1: string;
  s2: string;
begin
  if TEdit(Sender).Text = '' then
    exit;
  s1 := TEdit(Sender).Text;
  s2 := s1;
  with mtDM.LookTable do {change here for your own lookup stuff...}
  begin
    if not Locate(LookField, TEdit(Sender).Text, [loPartialKey]) then
    begin
      Key := 0;
      if length(s2) = 1 then
      begin
        TEdit(Sender).Text := '';
        exit;
      end;
      System.delete(s2, length(s2), 1);
      TEdit(Sender).Text := s2;
      s1 := s2;
      Locate(LookField, TEdit(Sender).Text, [loPartialKey]);
    end;
    s1 := FieldByName(LookField).AsString;
    TEdit(Sender).Text := copy(s1, 1, length(s2)) + copy(s1, length(s2) + 1, length(s1));
    TEdit(Sender).SelStart := Length(s2);
    TEdit(Sender).SelLength := length(s1) - length(s2);
  end;
  inherited;
end;

Solve 2:

unit AutoEdit;

interface

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

type
  TAutoEdit = class(TEdit)
  private
    fList: TListBox;
    fItems: TStringList;
    fLabel: TLabel;
    fCaption: string;
    fBackColor: TColor;
    fCaptionColor: TColor;
    fAutoComplete: Boolean;
    fListCount: Integer;
    fOldText: string;
    procedure SetCaption(S: string);
    procedure SetCaptionColor(const Color: TColor);
    procedure SetBackColor(const Color: TColor);
    procedure SetAutoComplete(AutoCompleteOn: Boolean);
    procedure ShowList;
  protected
    procedure CreateWnd; override;
    procedure CreateParams(var params: TCreateParams); override;
    procedure SetParent(AParent: TWinControl); override;
    procedure SetName(const Value: TComponentName); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure ListMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure HideList;
    procedure DoExit; override;
    property Items: TStringList read fItems write fItems;
  published
    procedure KeyPress(var Key: Char); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    property Caption: string read fCaption write SetCaption;
    property CaptionColor: TColor read fCaptionColor write SetCaptionColor;
    property BackColor: TColor read fBackColor write SetBackColor;
    property AutoComplete: Boolean read fAutoComplete write SetAutoComplete;
    property ListCount: Integer read fListCount write fListCount default 5;
  end;

procedure Register;

implementation

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

{ TAutoEdit }

constructor TAutoEdit.Create(AOwner: TComponent);
begin
  inherited;
  fItems := TStringList.Create;
  fList := TListBox.Create(Self);
  fLabel := TLabel.Create(Self);
  fLabel.ParentColor := True;
  fLabel.AutoSize := False;
  fLabel.FocusControl := Self;
  fCaptionColor := fLabel.Font.Color;
  fBackColor := fLabel.Color;
  fList.Parent := Self;
  fList.IntegralHeight := True;
  fList.ParentCtl3D := False;
  fList.Ctl3D := False;
  fList.TabStop := False;
  fList.Visible := False;
  fListCount := 5;
end;

destructor TAutoEdit.Destroy;
begin
  {fList.Free;}
  fItems.Free;
  fLabel.Free;
  inherited;
end;

procedure TAutoEdit.SetParent(AParent: TWinControl);
var
  FirstSetting: Boolean;
begin
  if Parent = nil then
    FirstSetting := True
  else
    FirstSetting := False;
  inherited;
  if Parent <> nil then
  begin
    fList.Parent := Self.Parent;
    fLabel.Parent := Self.Parent;
    if FirstSetting then
    begin
      fLabel.ParentColor := True;
      SetBounds(Left, Top, Width, Height);
    end;
  end;
end;

procedure TAutoEdit.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  if Parent <> nil then
  begin
    if (fCaption > '') and (fLabel.Parent <> nil) then
    begin
      fLabel.Top := ATop - (1 + fLabel.Canvas.TextHeight('lj'));
      fLabel.Height := AHeight + 4 + fLabel.Canvas.TextHeight('lj');
    end
    else
    begin
      fLabel.Top := ATop - 2;
      fLabel.Height := AHeight + 4;
    end;
    fLabel.Left := ALeft - 2;
    fLabel.Width := AWidth + 4;
    if csDesigning in ComponentState then
    begin
      fList.Parent := Self;
      HideList;
    end
    else if fList.Visible then
      ShowList;
  end;
end;

procedure TAutoEdit.SetName(const Value: TComponentName);
begin
  if Name > '' then
    if fCaption = Name then
      Caption := Value;
  inherited SetName(Value);
  if Text = Name then
  begin
    Text := '';
    Caption := Value;
  end;
end;

procedure TAutoEdit.CreateWnd;
begin
  inherited;
end;

procedure TAutoEdit.CreateParams(var params: TCreateParams);
begin
  inherited;
  fList.Color := Self.Color;
  fList.Font := Self.Font;
  fList.OnMouseUp := ListMouseUp;
  HideList;
end;

procedure TAutoEdit.SetCaption(S: string);
begin
  fCaption := S;
  fLabel.Caption := ' ' + S;
  SetBounds(Left, Top, Width, Height)
end;

procedure TAutoEdit.SetCaptionColor(const Color: TColor);
begin
  if fCaptionColor <> Color then
  begin
    fCaptionColor := Color;
    fLabel.Font.Color := Color;
    SetBounds(Left, Top, Width, Height)
  end;
end;

procedure TAutoEdit.SetBackColor(const Color: TColor);
begin
  if fBackColor <> Color then
  begin
    fBackColor := Color;
    fLabel.Color := Color;
    SetBounds(Left, Top, Width, Height)
  end;
end;

procedure TAutoEdit.SetAutoComplete(AutoCompleteOn: Boolean);
begin
  fAutoComplete := AutoCompleteOn;
end;

procedure TAutoEdit.ListMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Text := fList.Items[fList.ItemIndex];
  SelStart := Length(Text);
  HideList;
  fList.Clear;
  PostMessage(Handle, WM_KEYDOWN, VK_TAB, 0);
  PostMessage(Handle, WM_KEYUP, VK_TAB, 0);
end;

procedure TAutoEdit.DoExit;
begin
  if not fList.Focused then
    HideList;
  inherited;
end;

procedure TAutoEdit.KeyPress(var Key: Char);
var
  K, T: string;
  I, S: Integer;
begin
  if ReadOnly then
  begin
    inherited;
    Exit;
  end;
  K := Key;
  if (Key = #27) and (fList.Visible) then
  begin
    Key := #0;
    Text := Copy(Text, 1, SelStart);
    SelStart := Length(Text);
    fList.Clear;
    HideList;
  end
  else if fAutoComplete then
    if ((K > #27) and (K < #129)) or (K = #8) then
    begin
      if (K = #8) then
        T := Copy(Text, 1, SelStart - 1)
      else
        T := Copy(Text, 1, SelStart) + K;
      K := Uppercase(T);
      fList.Clear;
      if fItems.Count > 0 then
        for I := 0 to fItems.Count - 1 do
        begin
          if (Pos(K, Uppercase(fItems[I])) = 1) then
            fList.Items.Add(fItems[I]);
          if fList.Items.Count > fListCount - 1 then
            Break;
        end;
      S := Length(T);
      if (fList.Items.Count > 0) and (Key <> #8) then
      begin
        Text := Copy(T, 1, S) + Copy(fList.Items[0], S + 1, Length(fList.Items[0]));
      end
      else
        Text := T;
      Key := #0;
      SelStart := S;
      SelLength := Length(Text) - S;
      fOldText := Copy(Text, 1, SelStart);
    end;
  if fList.Items.Count > 0 then
    ShowList
  else
    HideList;
  inherited;
end;

procedure TAutoEdit.KeyDown(var Key: Word; Shift: TShiftState);
var
  I, S: Integer;
begin
  if Key = VK_DELETE then
  begin
    fList.Clear;
    HideList;
  end
  else if fList.Visible then
    if (Key = VK_DOWN) or (Key = VK_UP) then
    begin
      S := SelStart;
      if Key = VK_DOWN then
        I := fList.ItemIndex + 1
      else
        I := fList.ItemIndex - 1;
      if I < -1 then
        I := fList.Items.Count - 1;
      if I > fList.Items.Count - 1 then
        I := -1;
      fList.ItemIndex := I;
      if I = -1 then
      begin
        Text := fOldText;
        SelStart := Length(Text);
        SelLength := 0;
      end
      else
      begin
        Text := fList.Items[fList.ItemIndex];
        SelStart := S;
        SelLength := Length(Text) - S;
      end;
      Key := 0;
    end;
  if (not fList.Visible) and ((Key = VK_LEFT) or (Key = VK_RIGHT)) then
    if SelLength = Length(Text) then
      if (Shift = []) and (Length(Text) > 0) then
      begin
        SelLength := 0;
        {if (Key = VK_LEFT) and (SelStart > 1) then
          SelStart := SelStart - 1
        else
          if (Key = VK_RIGHT) and (SelStart < Length(Text)) then
            SelStart := SelStart + 1;}
        Key := 0;
      end;
  inherited;
end;

procedure TAutoEdit.ShowList;
begin
  if Parent <> nil then
  begin
    fList.Top := Top + ClientHeight;
    fList.Left := Left;
    fList.Width := Width;
    fList.Height := fList.ItemHeight * (fList.Items.Count + 1);
    fList.BringToFront;
    fList.Show;
  end;
end;

procedure TAutoEdit.HideList;
var
  I: Integer;
begin
  if (Text > '') then
    for I := 0 to fList.Items.Count - 1 do
      if Uppercase(fList.Items[I]) = Uppercase(Text) then
      begin
        Text := fList.Items[I];
        Break;
      end;
  fList.Hide;
  fList.Top := Top;
  fList.Height := 0;
  fList.Left := Left;
  fList.Width := 0;
end;

initialization
  begin
    RegisterClass(TLabel);
  end;

end.

How to make a palette and a pf1bit bitmap not necessary in B/W

Problem/Question/Abstract:

How to make a palette and don't bother about Range Checking ON or OFF ({$R+/-}?
How to convert a bitmap to a pf1bit bitmap, but not necessary in B/W?

Answer:

// This method will give an error if Range Checking is on
// ======================================================

var
  LogPal: PLogPalette;
  Palette: HPalette;
  PalSize: LongInt;

begin
  { ... }
  PalSize := 2 * SizeOf(Word) + n_Colors * SizeOf(TPaletteEntry));
{2 * SizeOf(Word) to get space for palVersion and palNumEntries,  n_Colors is the number
of colors in the palette}
GetMem(LogPal, PalSize);
LogPal^.palVersion := $0300;
LogPal^.palNumEntries := n_Colors;
LogPal^.palPalEntry[0] := {Some colour};
LogPal^.palPalEntry[1] := {Some other colour};
{ etc. }
FreeMem(LogPal, PalSize);
{ ... }
end;

// This method will NOT give a Range Check Error!
// =============================================

var
  pal: TMaxLogPalette;
  hpal: HPalette;
  DummyImage: TImage;

begin
  pal.palVersion := $300; // Magic number
  pal.palNumEntries := 2; // Palette for 1bit images not black and white!

  // Set foreground color
  pal.palPalEntry[0].peRed := GetRValue(Color1);
  pal.palPalEntry[0].peGreen := GetGValue(Color1);
  pal.palPalEntry[0].peBlue := GetBValue(Color1);
  pal.palPalEntry[0].peFlags := 0;

  // Set backGroundColor
  pal.palPalEntry[1].peRed := GetRValue(Color2);
  pal.palPalEntry[1].peGreen := GetGValue(Color2);
  pal.palPalEntry[1].peBlue := GetBValue(Color2);
  pal.palPalEntry[1].peFlags := 0;

  // Create the palette
  hpal := CreatePalette(PLogPalette(@pal)^);

  // Create a new image
  DummyImage := TImage.Create(Self);
  DummyImage.Picture.Bitmap.Width := Image1.Picture.Bitmap.Width;
  DummyImage.Picture.Bitmap.Height := Image1.Picture.Bitmap.Height;
  DummyImage.Picture.Bitmap.PixelFormat := pf1bit;
  DummyImage.Picture.Bitmap.Palette := hpal; // Assign the palette
  DummyImage.Picture.Bitmap.Canvas.Draw(0, 0, Image1.Picture.Graphic); // Draw it
  {...}
  {...}
end;

// DummyImage now holds the pf1bit represenation of Image1.
// Yes! A pf1bit image has a palette and it doesn't have to be black and white either!

How to handle bitmap layers

Problem/Question/Abstract:

I want to overlay bitmap2 over bitmap. The bitmap2 should be on top of bitmap1, i.e. the end result should be that bitmap2 should also show bits of bitmap1. What is the best way in Delphi to handle this?

Answer:

There are two methods. One works using a TImageList the other without. So the latter will work with other file types besides BMP's. Here's the code for both, it's pretty clear how both work. The key thing is you must specify a transparent color:

procedure DrawTrans(DestCanvas: TCanvas; X, Y: smallint; SrcBitmap: TBitmap; AColor: TColor);
var
  ANDBitmap, ORBitmap: TBitmap;
  CM: TCopyMode;
  Src: TRect;
begin
  ANDBitmap := nil;
  ORBitmap := nil;
  try
    ANDBitmap := TBitmap.Create;
    ORBitmap := TBitmap.Create;
    Src := Bounds(0, 0, SrcBitmap.Width, SrcBitmap.Height);
    with ORBitmap do
    begin
      Width := SrcBitmap.Width;
      Height := SrcBitmap.Height;
      Canvas.Brush.Color := clBlack;
      Canvas.CopyMode := cmSrcCopy;
      Canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
    end;
    with ANDBitmap do
    begin
      Width := SrcBitmap.Width;
      Height := SrcBitmap.Height;
      Canvas.Brush.Color := clWhite;
      Canvas.CopyMode := cmSrcInvert;
      Canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
    end;
    with DestCanvas do
    begin
      CM := CopyMode;
      CopyMode := cmSrcAnd;
      Draw(X, Y, ANDBitmap);
      CopyMode := cmSrcPaint;
      Draw(X, Y, ORBitmap);
      CopyMode := CM;
    end;
  finally
    ANDBitmap.Free;
    ORBitmap.Free;
  end;
end;

The other way:

abitmap := TBitmap.Create;
imagelist1.Clear;
abitmap.LoadFromFile('1.bmp');
imagelist1.AddMasked(abitmap, clNone);
abitmap.Empty;
abitmap.LoadFromFile('e1.bmp');
imagelist1.AddMasked(abitmap, clWhite);
abitmap.Empty;
abitmap.LoadFromFile('h1.bmp');
imagelist1.AddMasked(abitmap, clWhite);
imagelist1.Draw(image1.Canvas, 0, 0, 0);
imagelist1.Draw(image1.Canvas, 0, 0, 1);
imagelist1.Draw(image1.Canvas, 0, 0, 2);
abitmap.free;

Retrieve all table names from an Interbase database

Problem/Question/Abstract:

How to retrieve all table names from an Interbase database

Answer:

unit InterbaseDbTables;

interface

uses
  IbDatabase, IbCustomDataSet, SysUtils;

type
  TTableType = (ttTable, ttView, ttSystemTable);

type
  TTableTypes = set of TTableType;

type
  TTableItem = record
    ItemName: string;
    ItemType: string;
  end;

type
  TTableItems = array of TTableItem;

function addFilter(string1, string2: string): string;
function IbDbTables(IbDatabase: TIbDatabase; types: TTableTypes): TTableItems;

implementation

function addFilter(string1, string2: string): string;
begin
  if string1 <> '' then
    Result := string1 + ' or ' + string2
  else
    Result := string2;
end;

function IbDbTables(IbDatabase: TIbDatabase; types: TTableTypes): TTableItems;
var
  IbDataSet: TIbDataSet;
  IbTransaction: TIbTransaction;
  i: integer;
  Filtro: string;
begin
  IbDataSet := TIbDataSet.Create(nil);
  IbTransaction := TIbTransaction.Create(nil);
  IbTransaction.DefaultDatabase := IbDatabase;
  IbDataSet.Transaction := IbTransaction;
  IbDataSet.SelectSQL.Text := 'SELECT RDB$RELATION_NAME, RDB$SYSTEM_FLAG,
    RDB$VIEW_SOURCE FROM RDB$RELATIONS';
    if (ttTable in types) then
    Filtro := addFilter(Filtro, '((RDB$VIEW_SOURCE IS NULL) and
      ((RDB$SYSTEM_FLAG = 0) or (RDB$SYSTEM_FLAG is NULL)))');
      if (ttView in types) then
      Filtro := addFilter(Filtro, '(RDB$VIEW_SOURCE IS NOT NULL)');
  if (ttSystemTable in types) then
    Filtro := addFilter(Filtro,
      '((RDB$SYSTEM_FLAG <> 0) and (RDB$SYSTEM_FLAG IS NOT NULL))');
  if Filtro <> '' then
    IbDataSet.SelectSQL.Text := IbDataSet.SelectSQL.Text + ' where ' + Filtro;
  IbDataSet.Open;
  IbDataSet.Last;
  SetLength(Result, IbDataSet.RecordCount);
  i := 0;
  with IbDataSet do
  begin
    First;
    while not Eof do
    begin
      with Result[i] do
      begin
        ItemName := Trim(FieldByName('RDB$RELATION_NAME').AsString);
        if (not FieldByName('RDB$VIEW_SOURCE').IsNull) then
          ItemType := 'VIEW'
        else if (FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 0) and
          (not FieldByName('RDB$SYSTEM_FLAG').IsNull) then
          ItemType := 'SYSTEM'
        else
          ItemType := 'TABLE';
      end;
      Inc(i);
      Next;
    end;
  end;
  IbDataSet.Close;
  IbTransaction.CommitRetaining;
  IbDataSet.Free;
  IbTransaction.Free;
end;

end.


Example:
Create a new project and add a TIbDatabase (IbDatabase1), a TButton (Button1) and a TMemo (Memo1). Assign the DatabaseName property of the IbDatabase1 component and set "IbDatabase1.Connected := True".

procedure TForm1.Button1Click(Sender: TObject);
var
  output: TTableItems;
  i: integer;
begin
  output := IbDbTables(IbDatabase1, [ttTable, ttView]);
  { output := IbDbTables(IbDatabase1, [ttView]);
  output := IbDbTables(IbDatabase1, [ttSystemTable]); }
  for i := low(output) to high(output) do
  begin
    Memo1.Lines.Add(output[i].ItemName + '---' + output[i].ItemType);
  end;
  output := nil;
end;

Edit *.pif files programmatically

Problem/Question/Abstract:

Does anybody know how to create and/ or modify a *.pif programmatically? Windows creates *.pif files for all DOS programs but does not provide any method to edit it except manually. Is that right?

Answer:

procedure CreateShortcut(const FileName: string; Location: ShortcutType);
{Procedure to create a shortcut on the desktop or startmenu}
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory: string;
  LinkName: string;
  IconName: string;
  DirName: string;
  pifName: WideString;
  WFileName: WideString;
  QuickLaunchReg: TRegIniFile;
  aPidl: PItemIDList;
  Res: HResult;
  Buf: PByteArray;
  PPif: pif_record_ref_type absolute Buf;
  Flag: boolean;
  i, j: integer;
  n: longint;
  PHeading: section_heading_record_ref_type;
  PVMMSection: windows_vmm_section_ref_type;
  PW386Section: ^windows_386_section_type;
  f: file;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;
  MySLink.SetPath(PChar(FileName));
  LinkName := ChangeFileExt(FileName, '.lnk');
  LinkName := ExtractFileName(LinkName);
  case Location of
    _DESKTOP:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_DESKTOPDIRECTORY,
        aPidl);
    _STARTMENU:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_STARTMENU, aPidl);
    _SENDTO:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_SENDTO, aPidl);
    _QUICKLAUNCH:
      Res := 0;
  end;
  if Res <> NOERROR then
  begin
    case Location of
      _DESKTOP:
        Directory := 'ShellFolders->Desktop';
      _STARTMENU:
        Directory := 'ShellFolders->Start Menu';
      _SENDTO:
        Directory := 'ShellFolders->SendTo';
      _QUICKLAUNCH:
        Directory := 'MapGroups->Quick Launch';
    end;
    ShowMessage(Directory + ': Failed');
  end
  else
  begin
    {Get the actual path from the PItemIDList}
    SetLength(Directory, MAX_PATH);
    SHGetPathFromIDList(aPidl, PChar(Directory));
    SetLength(Directory, StrLen(PChar(Directory)));
    WFileName := Directory + '\' + LinkName;
    if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
    begin
      pifName := ExtractFilePath(FileName);
      Res := MyPFile.Load(PWChar(pifName + 'SYS\PauLita.pif'), 0);
      if Res = E_OUTOFMEMORY then
        ShowMessage('.PIF LOAD: Out of Memory')
      else if Res = E_FAIL then
        ShowMessage('.PIF LOAD: Failed');
      IconName := pifName + 'SYS\PAULITA.ICO';
      Res := MySLink.SetIconLocation(PChar(IconName), 0);
      if Res <> NOERROR then
        ShowMessage('SetIconLocation: Failed');
    end;
    MySLink.SetPath(PChar(FileName));
    DirName := ExtractFilePath(FileName);
    DirName := Copy(DirName, 1, Length(DirName) - 1);
    MySLink.SetWorkingDirectory(PChar(DirName));
    Res := MyPFile.Save(PWChar(WFileName), FALSE);
    if Res <> S_OK then
      ShowMessage('Save ' + WFileName + ' Failed');
    if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
    begin
      Buf := nil;
      Assign(f, Directory + '\PAULITA.PIF');
      try
        Reset(f, 1);
        n := FileSize(f);
        GetMem(Buf, n);
        BlockRead(f, Buf^, n);
        PW386Section := nil;
        Flag := FALSE;
        i := $187;
        while i + SizeOf(section_heading_record_type) <= n do
        begin
          PHeading := @Buf^[i];
          {ShowMessage(PHeading^.Name); }
          {Look for WINDOWS 386 3.0 group}
          if StrPas(@PHeading^.Name) = 'WINDOWS 386 3.0' then
          begin
            PW386Section := @Buf^[i + SizeOf(section_heading_record_type)];
          end;
          {Look for WINDOWS VMM 4.0 group}
          if StrPas(@PHeading^.Name) = 'WINDOWS VMM 4.0' then
          begin
            Flag := TRUE;
            Break;
          end;
          i := i + SizeOf(section_heading_record_type) + PHeading^.Len;
        end;
        if not Flag then
        begin
          ShowMessage('WINDOWS VMM 4.0 not Found in' + Directory + '\PAULITA.PIF');
        end
        else
        begin
          Flag := FALSE;
          if (PPif^.Flags1 and CLOSE_ON_EXIT) = $0000 then
          begin
            PPif^.Flags1 := PPif^.Flags1 or CLOSE_ON_EXIT;
            Flag := TRUE;
          end;
          j := Pos('PAULITA.EXE', PPif^.FileName);
          if j > 0 then
          begin
            StrPCopy(PPif^.FileName, Copy(StrPas(@PPif^.FileName), 1, j - 1) +
              'LITA.BAT'#0);
            Flag := TRUE;
          end;
          if PW386Section <> nil then
          begin
            if (PW386Section^.Flags1 and $00000008) = $0000 then
            begin
              {Used}
              PW386Section^.Flags1 := PW386Section^.Flags1or $00000008;
                {Full screen mode}
              Flag := TRUE;
            end;
            if (PW386Section^.MaxEMS <> $FFFF) or (PW386Section^.ReqEMS <> $0000) or
              (PW386Section^.MaxXMS <> $FFFF) or (PW386Section^.ReqXMS <> $0000) then
            begin
              PW386Section^.MaxEMS := $FFFF;
              PW386Section^.ReqEMS := $0000;
              PW386Section^.MaxXMS := $FFFF;
              PW386Section^.ReqXMS := $0000;
              Flag := TRUE;
            end;
          end;
          PVMMSection := @Buf^[i + SizeOf(section_heading_record_type)];
          if (PVMMSection^.Flags2 and FULL_SCREEN_MODE) = $0000 then
          begin
            {Not used}
            PVMMSection^.Flags2 := PVMMSection^.Flags2 or FULL_SCREEN_MODE;
            Flag := TRUE;
          end;
          if Flag then
          begin
            Seek(f, 0);
            BlockWrite(f, Buf^, n);
          end;
        end;
      finally
        Close(f);
        if Buf <> nil then
          FreeMem(Buf, n);
      end;
    end;
  end;
end;

How to iterate through the fields of a TTable

Problem/Question/Abstract:

How to iterate through the fields of a TTable

Answer:

There are a number of reasons why a program might need to query the structure of a table used in the application. One reason is a prelude to creating TField components at run-time that represent the fields in the table. The information gleaned from the structure of the table form the basis of the TField components to be created.

The example below demonstrates how to iterate through the fields available in a TTable or TQuery. The example extracts information about the available fields and displays the information in a TListBox, but the same methodology can be used to provide information necessary for the dynamic building of TField descendants. The example uses a TTable as the data set, but a TQuery can be used in the same manner as both TTable and TQuery components incorporate the FieldDefs property the same way.

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  F: TFieldDef;
  D: string;
begin
  Table1.Active := True;
  ListBox1.Items.Clear;
  with Table1 do
  begin
    for i := 0 to FieldDefs.Count - 1 do
    begin
      F := FieldDefs.Items[i];
      case F.DataType of
        ftUnknown: D := 'Unknown';
        ftString: D := 'String';
        ftSmallint: D := 'SmallInt';
        ftInteger: D := 'Integer';
        ftWord: D := 'Word';
        ftBoolean: D := 'Boolean';
        ftFloat: D := 'Float';
        ftCurrency: D := 'Currency';
        ftBCD: D := 'BCD';
        ftDate: D := 'Date';
        ftTime: D := 'Time';
        ftDateTime: D := 'DateTime';
        ftBytes: D := 'Bytes';
        ftVarBytes: D := '';
        ftBlob: D := 'BLOB';
        ftMemo: D := 'Memo';
        ftGraphic: D := 'Graphic';
      else
        D := '';
      end;
      ListBox1.Items.Add(F.Name + ', ' + D);
    end;
  end;
  Table1.Active := False;
end;

How to clip a TBitmap inside an irregular shape

Problem/Question/Abstract:

If I have an irregular shape, say a rectangle with the top corners rounded. How can I fill the inside of that shape with a bitmap or limit pen drawing to inside the area of the shape?

Answer:

Below is a small sample of how the problem can be resolved, using a Path converting the Path to a Region and setting the ClippingRgn:

procedure DrawHeader
var
  Bmp: TBitmap;
  clEnd, clStart: TColor;
  R: TRect;
  Rd: Integer;
  Rgn: HRGN;
begin
  Rd := spnTest.IntValue;
  GetActiveColors(clStart, clEnd);
  Bmp := TBitmap.Create;
  try
    R.Left := btnClipGradient.Left + btnClipGradient.Width + 20;
    R.Top := btnClipGradient.Top;
    R.Right := R.Left + 100;
    R.Bottom := R.Top + 100;
    with Bmp do
    begin
      Height := 20;
      Width := 100;
      DrawGradient(Canvas, Rect(0, 0, 100, 20), 50, goHorizontal, clStart, clEnd);
    end;
    with Canvas do
    begin
      BeginPath(Handle);
      Pen.Color := clYellow;
      Pen.Style := psSolid;
      {Bottom line}
      MoveTo(R.Left, R.Bottom);
      LineTo(R.Right, R.Bottom);
      {Right Line}
      LineTo(R.Right, R.Top + (Rd div 2));
      {Top Right}
      ArcTo(Handle, R.Right - Rd + 1, R.Top, R.Right + 1, R.Top + Rd, R.Right + 1,
        R.Top + (Rd div 2), R.Right - (Rd div 2) + 1, R.Top);
      {Top Line}
      LineTo(R.Right - (Rd div 2), R.Top);
      {Top Left}
      ArcTo(Handle, R.Left, R.Top, R.Left + Rd, R.Top + Rd, R.Left + (Rd div 2),
        R.Top, R.Left, R.Top + (Rd div 2));
      {Left line}
      LineTo(R.Left, R.Top + (Rd div 2));
      EndPath(Handle);
      Rgn := PathToRegion(Handle);
      SelectClipRgn(Handle, Rgn);
      Draw(R.Left + 1, R.Top + 1, Bmp);
      SelectClipRgn(Handle, HRGN(nil));
      Pen.Color := clYellow;
      Pen.Style := psSolid;
      {Bottom line}
      MoveTo(R.Left, R.Bottom);
      LineTo(R.Right, R.Bottom);
      {Right Line}
      LineTo(R.Right, R.Top + (Rd div 2));
      {Top Right}
      ArcTo(Handle, R.Right - Rd + 1, R.Top, R.Right + 1, R.Top + Rd, R.Right + 1,
        R.Top + (Rd div 2), R.Right - (Rd div 2) + 1, R.Top);
      {Top Line}
      LineTo(R.Right - (Rd div 2) + 1, R.Top);
      {Top Left}
      ArcTo(Handle, R.Left, R.Top, R.Left + Rd, R.Top + Rd, R.Left + (Rd div 2),
        R.Top, R.Left, R.Top + (Rd div 2));
      {Left line}
      LineTo(R.Left, R.Bottom);
      DeleteObject(Rgn);
    end;
  finally
    Bmp.Free;
  end;
end;

Create a transparent form using regions

Problem/Question/Abstract:

When I override the CreateParams method of the TForm class and put an "or" clause to include a WS_EX_TRANSPARENT effect, all work fine. My Form appears with a transparent effect (or better, it does not appear. Only controls appear). But if I change the icons positions on the Desktop screen, my form does not get the changes and redraws itself. Well, I call redraw manually, but the form cannot get the desktop screen rectangle to correct the background of the form. How do I solve this problem? Is there a way to get a selected rectangle of the desktop screen to be copied to the canvas on the form?

Answer:

Here's a transparent form method that uses regions. It's so transparent, you can click right through to the underlying windows:

unit Unit1;

{The transparent form effect is done with regions. First create a region that encompasses the entire form. Then, find the client area of the form (Client vs. non-Client) and combine with the full region with RGN_DIFF to make the borders and title bar visible.  Then create a region for each of the controls and combine them with the original (FullRgn) region.}

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
    procedure DoVisible;
    procedure DoInvisible;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FullRgn, ClientRgn, CtlRgn: THandle;

implementation

{$R *.DFM}

procedure TForm1.DoInvisible;
var
  AControl: TControl;
  A, Margin, X, Y, CtlX, CtlY: Integer;
begin
  Margin := (Width - ClientWidth) div 2;
  {First, get form region}
  FullRgn := CreateRectRgn(0, 0, Width, Height);
  {Find client area region}
  X := Margin;
  Y := Height - ClientHeight - Margin;
  ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight);
  {'Mask' out all but non-client areas}
  CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);
  {Now, walk through all the controls on the form and 'OR' them into the existing Full region}
  for A := 0 to ControlCount - 1 do
  begin
    AControl := Controls[A];
    if (AControl is TWinControl) or (AControl is TGraphicControl) then
      with AControl do
      begin
        if Visible then
        begin
          CtlX := X + Left;
          CtlY := Y + Top;
          CtlRgn := CreateRectRgn(CtlX, CtlY, CtlX + Width, CtlY + Height);
          CombineRgn(FullRgn, FullRgn, CtlRgn, RGN_OR);
        end;
      end;
  end;
  {When the region is all ready, put it into effect:}
  SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {Clean up the regions we created}
  DeleteObject(ClientRgn);
  DeleteObject(FullRgn);
  DeleteObject(CtlRgn);
end;

procedure TForm1.DoVisible;
begin
  {To restore complete visibility:}
  FullRgn := CreateRectRgn(0, 0, Width, Height);
  CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
  SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  {We start out as a transparent form ...}
  DoInvisible;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  {This button just toggles between transparent and not transparent}
  if Button1.Caption = 'Show Form' then
  begin
    DoVisible;
    Button1.Caption := 'Hide Form';
  end
  else
  begin
    DoInvisible;
    Button1.Caption := 'Show Form';
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  {Need to address the transparency if the form gets resized. Also, note that Form1 scroll bars are set to VISIBLE/FALSE. I did that to save a little coding here....}
  if Button1.Caption = 'Show Form' then
    DoInvisible
  else
    DoVisible;
end;

end.

Some remarks on working with very large images

Problem/Question/Abstract:

I have a function that reads about 100 images of about 3000 x 2000 pixels and makes a small image of 200 x 100 of each. My problem is that I can only read 10 or 15 and then the application crashes. I have inspected the memory and it maintains stable and enough, so I don't know where the problem is. If the images that I load are smaller, I can read all.

Answer:

Differing versions of Windows, graphics drivers, and hardware will fail at some point when working with "huge bitmaps" or "huge DIBs".

I define a "huge bitmap/dib" as a bitmap or DIB that either exceeds the screen's width and or height, or exceeds the memory allocationof one single screen at the native color depth of screen (ie even though a 24 bit bitmap was the same size as the screen in width, it would be considered to be "huge" if it was more than one third the height of the screen when used under a 8 bit (256 color) video mode.

I make this definition of "huge", as we know that it is safe to work with bitmaps/dibs that are screensize or smaller, and the failures will generally occur at some size that is larger. This is not ment to say that working with bitmaps that are screensize or smaller will always work, as that depends on the amount GDI resources already in use when compared with the GDI resources that might be available at a given time. I am also not saying that you will always get a failure when working with a huge bitmap, only that it is very common (as you have already found out).

Let me quickly mention that resizing can bring one other possible limitation to the table. Certain versions of Windows (and/or Drivers) may be limited to stretching an image to a minimum of 8 times its original size.

Your only safe solution for "huge bitmaps/dibs" is to work with them without getting Windows and its drivers involved in the process until you actually display them. This means you would work with the bitmaps as DIBS (device independent bitmaps) (for example in the raw form that they exist on the disk), and do all resizing using internal code that does not depend on Windows or its drivers.

I will mention that it requires a large amount of low level code to work with the differing bitmap formats, where you might want to copy, and resize between them. The trick for drawing to huge dibs is you would need to copy workable sized sections from the DIB, convert the section to a bitmap (or use a DIB section) draw on it, convert back to a DIB, and copy the section back to the original huge DIB.

How to draw disabled (greyed-out) text on a TCanvas

Problem/Question/Abstract:

Is there any way I can set some flags for Canvas.TextOut or something similar to draw text in disabled mode, or do I need to do this by writing my own routine?

Answer:

procedure DrawDisabledCaption(aCanvas: TCanvas; X, Y: Integer; aCaption: string);
var
  oldcolor: TColor;
begin
  { ... }
  with aCanvas do
  begin
    oldcolor := font.color;
    font.color := clBtnHighlight;
    TextOut(X, Y, aCaption);
    font.color := clBtnShadow;
    TextOut(X + 1, Y + 1, aCaption);
  end;
end;

How to fix BDE Error "2B04 Too many open files"

Problem/Question/Abstract:

What should I do with error 11012 ("2B04 Too many open files"). You may need to increase MAXFILEHANDLE limit in IDAPI configuration.

Answer:

Open the tool 'BDE Administrator' and choose the right tab 'Configuration'. There open the node 'System' and click on subnode 'INIT'. Then update 'MaxFileHandles' on the right side (it is 48 by default).

How to list all links of a page of a TWebbrowser.txt

Problem/Question/Abstract:

How to list all links of a page of a TWebbrowser

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do
    Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));
end;

{*****************}

{ if there are frames }

procedure TForm1.Button2Click(Sender: TObject);
var
  u: variant;
  v: IDispatch;
  s: string;

  procedure RecurseLinks(htmlDoc: variant);
  var
    BodyElement: variant;
    ElementCo: variant;
    HTMLFrames: variant;
    HTMLWnd: variant;
    j, i: integer;
  begin
    if VarIsEmpty(htmlDoc) then
      exit;
    BodyElement := htmlDoc.body;
    if BodyElement.tagName = 'BODY' then
    begin
      ElementCo := htmlDoc.links;
      j := ElementCo.Length - 1;
      for i := 0 to j do
      begin
        u := ElementCo.item(i);
        s := u.href;
        listLinks.Items.Add(s);
      end;
    end;
    HTMLFrames := htmlDoc.Frames;
    j := HTMLFrames.length - 1;
    for i := 0 to j do
    begin
      HTMLWnd := HTMLFrames.Item(i);
      RecurseLinks(HTMLWnd.Document);
    end;
  end; // RecurseLinks
begin
  v := WebBrowser1.document;
  listLinks.Clear;
  RecurseLinks(v);
end;

How to find values in a string

Problem/Question/Abstract:

I have a string which contains values separated by "," and not necessarily in numeric order (1, 50, 100, 2, 5, 10, ...). What is the best and fastest way to search through this string to find a value, for example 100?

Answer:

type
  TIntArray = array of integer

procedure StringToIntArray(const S: string; var List: TIntArray);
{ Converts "S" to an array of integer -> "List" }
const
  ValidChars: set of char = ['0'..'9', '-'];
var
  Ix, Ix2, Len, C: Integer;
  SubStr: string;
  Value, Code: Integer;
begin
  Len := Length(S);
  SetLength(List, Len);
  if Len = 0 then
    Exit;
  C := 0;
  Ix := 1;
  while Ix <= Len do
  begin
    while (Ix <= Len) and (not (S[Ix] in ValidChars)) do
      Inc(Ix);
    Ix2 := Ix;
    while (Ix <= Len) and (S[Ix] in ValidChars) do
      Inc(Ix);
    SubStr := Copy(S, Ix2, Ix - Ix2);
    Val(SubStr, Value, Code);
    if Code = 0 then
    begin
      List[C] := Value;
      Inc(C);
    end;
  end;
  SetLength(List, C);
end;

function FindValue(Value: Integer; List: TIntArray): Integer;
{ Returns index of requested value, or -1 if not found. }
var
  Ix: Integer;
begin
  Result := -1;
  Ix := 0;
  while Ix < Length(List) do
  begin
    if List[Ix] = Value then
    begin
      Result := Ix;
      Exit;
    end;
    Inc(Ix);
  end;
end;

Example:

StringToIntArray('(1, 50, 100, 2, 5, 10,.....)', MyIntArray)

sets the contents of MyIntArray to [1,50,100,2,5,10].
then FindValue(100, MyIntArray) returns 2, as MyIntArray[2] = 100;

How to jump to a specific line in a text file and return the line in a string

Problem/Question/Abstract:

I'm trying to write a function that, given a FileName and a line number, returns the entire line in a string.

Answer:

This technique is useful for high-speed processing. Save the sample program file with a .pas or .dpr file name and compile it with dcc32:

{$APPTYPE CONSOLE}
uses
  SysUtils, Classes;

function GrabLine(const AFileName: string; ALine: Integer): string;
var
  fs: TFileStream;
  buf: packed array[0..4095] of Char;
  bufRead: Integer;
  bufPos: PChar;
  lineStart: PChar;
  tmp: string;
begin
  fs := TFileStream.Create(AFileName, fmOpenRead);
  try
    Dec(ALine);
    bufRead := 0;
    bufPos := nil;
    { read the first line specially }
    if ALine = 0 then
    begin
      bufRead := fs.Read(buf, SizeOf(buf));
      if bufRead = 0 then
        raise Exception.Create('Line not found');
      bufPos := buf;
    end
    else
      while ALine > 0 do
      begin
        { read in a buffer }
        bufRead := fs.Read(buf, SizeOf(buf));
        if bufRead = 0 then
          raise Exception.Create('Line not found');
        bufPos := buf;
        while (bufRead > 0) and (ALine > 0) do
        begin
          if bufPos^ = #10 then
            Dec(ALine);
          Inc(bufPos);
          Dec(bufRead);
        end;
      end;
    { Found the beginning of the line at bufPos... scan for end.
      Two cases:
        1) we'll find it before the end of this buffer
        2) it'll go beyond this buffer and into n more buffers }
    lineStart := bufPos;
    while (bufRead > 0) and (bufPos^ <> #10) do
    begin
      Inc(bufPos);
      Dec(bufRead);
    end;
    { if bufRead is positive, we'll have found the end and we can leave. }
    SetString(Result, lineStart, bufPos - lineStart);
    { determine if there are more buffers to process }
    while bufRead = 0 do
    begin
      bufRead := fs.Read(buf, SizeOf(buf));
      lineStart := buf;
      bufPos := buf;
      while (bufRead > 0) and (bufPos^ <> #10) do
      begin
        Inc(bufPos);
        Dec(bufRead);
      end;
      SetString(tmp, lineStart, bufPos - lineStart);
      Result := Result + tmp;
    end;
  finally
    fs.Free;
  end;
end;

function GrabLine2(const s: string; ALine: Integer): string;
var
  sl: TStringList;
begin
  sl := TStringList.Create;
  try
    sl.LoadFromFile(s);
    Result := sl[ALine - 1]; { index off by one }
  finally
    sl.Free;
  end;
end;

begin
  Writeln(GrabLine(ParamStr(1), StrToInt(ParamStr(2))));
  Writeln(GrabLine2(ParamStr(1), StrToInt(ParamStr(2))));
end.

Call it like 'getline testfile.txt 20000', depending on what you call the .pas (or .dpr) file. For large (i.e. tens of megabytes) files, the (rather complex) scanning function easily beats the memory expensive StringList version.

Enable and disable sound from your application

Problem/Question/Abstract:

Ever needed to completely disable and then re-enable audio capabilities from your application? There's the way to simple do it.

Answer:

unit AudioCtrl;

interface

procedure EnableAudio;
procedure DisableAudio;

implementation

uses
  MMSystem;

var
  MyVolume: array[0..10] of LongInt;
  mDevs: Integer;

procedure EnableAudio;
var
  I: Integer;
begin
  for I := 0 to mDevs do
  begin
    auxSetVolume(I, MyVolume[I]);
  end;
end;

procedure DisableAudio;
var
  I: Integer;
begin
  mDevs := auxGetNumDevs;
  for I := 0 to mDevs do
  begin
    auxGetVolume(I, Addr(MyVolume[I]));
    auxSetVolume(I, LongInt(9000) * 65536 + LongInt(9000));
  end;
end;

end.

How to search a TQuery result set

Problem/Question/Abstract:

The TQuery component does not offer the index-based search capabilities of the TTable component (FindKey, GotoKey, and GotoNearest). So how do you search within the result data set from a TQuery to find a row with a specific field value?

Answer:

One way to search a query result set is a sequential search. This type of search starts at the first row in the data set and, in a While loop, sequentially compares the value of a field in the row with a search value. One of two results are possible: a value will be found (success) or the end of the data set will be reached (failure). The problem with this way of searching the data set is that the further into the data set a row with a matching value is, the longer it takes to arrive at that row. And, a failed search takes longest of all because it must go all the way to the last row in the data set. If the data set being searched is a large one, this process may take a considerable amount of time.

Here is a function that will perfoorm a sequential search of the result set from a TQuery:

function SeqSearch(AQuery: TQuery; AField, AValue: string): Boolean;
begin
  with AQuery do
  begin
    First;
    while (not Eof) and (not (FieldByName(AField).AsString = AValue)) do
      Next;
    SeqSearch := not Eof;
  end;
end;

This function takes three parameters:

AQuery: type TQuery; the TQuery component in which the search is to be executed.
AField: type String; the name of the field against which the search value will be compared.
AValue: type String; the value being searched for. If the field is of a data type other than String, this search value should be changed to the same data type.

The Boolean return value of this function indicates the success (True) or failure (False) of the search.

An alternative is using a bracketing approach. On a conceptual level, this method acts somewhat like a bb-tree index. It is based on the given that for a row at a given point in the data set, the value of the field being searched compared to the search value will produce one of three possible conditions:

The field value will be greater than the search value, or
The field value will be less than the search value, or
The field value will be equal to the search value.

A bracketing search process uses this means of looking at the current row in respect to the search value and uses it to successively reduce the rows to be search by half, until only one row remains. This search field value for this sole remaining row will either be a match to the search value (success) or it will not (failure, and no match exists in the data set).

Functionally, this process lumps the condition of the search field being less than or equal to the search value into a single condition. This leaves only two possible results for the comparison of the current search field valuue with the search value: less than/equal to or greater than. Initially, a range of numbers is established. The low end of the range is represented by an Integer, at the start of the search process set to 0 or one less than the first row in the data set. The far end of the range is also an Integer, with the value of the RecordCount property of the TQuery. The current row pointer is then moved to a point half way between the low and high ends of the range. The search field value at that row is then compared to the search value. If the field value is less than or equal to the search value, the row being sought must be in the lower half of the range of rows so the high end of the range is reduced to the current row position. If the field value is greater than the search value, the sought value must be in the higher half of the range and so the low end is raised to the current point. By repeating this process, the number of rows that are encompassed in the range are successivelly reduced by half. Eventually, only one row will remain.

Putting this into a modular, transportable function, the code would look like that below:

function Locate(AQuery: TQuery; AField, AValue: string): Boolean;
var
  Hi, Lo: Integer;
begin
  with AQuery do
  begin
    First;
    {Set high end of range of rows}
    Hi := RecordCount;
    {Set low end of range of rows}
    Lo := 0;
    {Move to point half way between high and low ends of range}
    MoveBy(RecordCount div 2);
    while (Hi - Lo) > 1 do
    begin
      {Search field greater than search value, value in first half}
      if (FieldByName(AField).AsString > AValue) then
      begin
        {Lower high end of range by half of total range}
        Hi := Hi - ((Hi - Lo) div 2);
        MoveBy(((Hi - Lo) div 2) * -1);
      end
        {Search field less than search value, value in far half}
      else
      begin
        {Raise low end of range by half of total range}
        Lo := Lo + ((Hi - Lo) div 2);
        MoveBy((Hi - Lo) div 2);
      end;
    end;
    {Fudge for odd numbered rows}
    if (FieldByName(AField).AsString > AValue) then
      Prior;
    Locate := (FieldByName(AField).AsString = AValue)
  end;
end;

Because there will never be a difference of less than one between the low and high ends of the range of rows, a final fudge was added to allow the search to find the search value in odd numbered rows. This function takes the same three three parameters as the SeqSearch function described earlier.

The return value of this function is of type Boolean, and reflects the success or failure of the search. As the search does move the row pointer, the effects of this movement on the implicit posting of changed data and on where the desired position of the row pointer should be after a failed search should be taken into account in the calling application. For instance, a TBookmark pointer might be used to return the row pointer to where it was prior to a search if that search fails.

How is this process better than a sequential search? First, in bracketing the search value, only a fraction of the number of rows will be visited as would be the case in a sequential search. Unless the row with the value being sought is in the first 1,000 rows, this search method will be faster than a sequential search. Because this process always uses the same number of records, the search time will be consistent whether searching for the value in row 1,000 or row 90,000. This is in contrast with the sequential search that takes longer the farther into the data set the desired row is.

Can this method be used with any TQuery result set? No. Because of the way this method works in basing the direction of the search as either high or low, it depends on the row being ordered in a descending manner based on the field in which the search will be conducted. This means that it can only be used if the data set is naturally in a sequential order or an ORDER BY clause is used in the SQL statement for the TQuery. The size of the result set will also be a factor when deciding whether to perform a sequential or bracketing search. This process is most advantageous for speed when used with larger result sets. With smaller sets (1,00 or less rows), though, a sequential search will often be as fast or faster.

Move/ Resize components in IDE without the mouse

Problem/Question/Abstract:

Move/ Resize components in IDE without the mouse

Answer:

You can move visual components on a form with Ctrl+Arrow Key, and resize them with Shift+Arrow Key.

How to detect if a menu as a whole is currently open or selected

Problem/Question/Abstract:

How to detect if a menu as a whole is currently open or selected

Answer:

{ ... }
type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    item01: TMenuItem;
    item11: TMenuItem;
    item21: TMenuItem;
  private
    { Private declarations }
  public
    procedure WMMENUSELECT(var M: TWMMENUSELECT); message WM_MENUSELECT;
  end;
  {...}

procedure TForm1.WMMENUSELECT(var M: TWMMENUSELECT);
begin
  inherited;

  {This beeps even if it is the sysmenu (control menu) and/or on any selected item: }
  { messagebeep(MB_ICONASTERISK);  }

  { This beeps when MainMenu1 is opened, but only beeps on item[0]: }
  if M.menu = Mainmenu1.handle then
    messagebeep(MB_ICONASTERISK);
end;

end.

How to create a TStatusBar with resizable panels

Problem/Question/Abstract:

How to create a TStatusBar with resizable panels

Answer:

In this demo the TStatusBar has three panels. Only panels 1 and 2 need to be adjustable and each has a set minimum width of 20. The StatusBar OnResize event is used to keep the panels in view, regardless of form resizing, except where the StatusBar width is less than 40.

{ ... }
private
{Private declarations}
StatusMouseDown: Boolean;
Split: Integer;
{ ... }

procedure TMainForm.FormCreate(Sender: TObject);
begin
  StatusMouseDown := false;
end;

procedure TMainForm.StatusBar1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  StatusMouseDown := false;
end;

procedure TMainForm.StatusBar1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  S1, S2: Integer;
begin
  if Button = mbLeft then
  begin
    StatusMouseDown := true;
    Split := 0;
    S1 := StatusBar1.Panels[0].Width;
    S2 := StatusBar1.Panels[1].Width + S1;
    if ((X > S1 - 3) and (X < (S1 + 3))) then
      Split := 1
    else if ((X > S2 - 3) and (X < (S2 + 3))) then
      Split := 2;
  end;
end;

procedure TMainForm.StatusBar1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  S1, S2, S3: Integer;
  Split1, Split2: Boolean;
begin
  Split1 := false;
  Split2 := false;
  S1 := StatusBar1.Panels[0].Width;
  S2 := StatusBar1.Panels[1].Width + StatusBar1.Panels[0].Width;
  S3 := StatusBar1.Width;
  if ((X > S1 - 3) and (X < (S1 + 3))) then
    Split1 := true
  else if ((X > S2 - 3) and (X < (S2 + 3))) then
    Split2 := true;
  if (Split1 or Split2) then
    StatusBar1.Cursor := crHSplit
  else
    StatusBar1.Cursor := crDefault;
  if StatusMouseDown then
  begin
    if (Split = 1) then
    begin
      if (X < 20) then
        StatusBar1.Panels[0].Width := 20
      else if (X > (S3 - 40)) then
      begin
        StatusBar1.Panels[0].Width := S3 - 40;
        StatusBar1.Panels[1].Width := S3 - S1 - 20;
      end
      else if (X >= 20) and (X <= S3 - 20) then
      begin
        StatusBar1.Panels[0].Width := X;
        if ((X + StatusBar1.Panels[1].Width + 20) >= S3) then
          StatusBar1.Panels[1].Width := S3 - X - 20;
      end;
    end;
    if (Split = 2) then
    begin
      if (X < (S1 + 20)) then
        StatusBar1.Panels[1].Width := 20
      else if (X > (S3 - 20)) then
        StatusBar1.Panels[1].Width := S3 - S1 - 20
      else if (X >= S1 + 20) and (X <= S3 - 20) then
        StatusBar1.Panels[1].Width := X - S1;
    end;
  end;
end;

procedure TMainForm.StatusBar1Resize(Sender: TObject);
var
  S1, S2, S3: Integer;
begin
  S1 := StatusBar1.Panels[0].Width;
  S2 := StatusBar1.Panels[1].Width + StatusBar1.Panels[0].Width;
  S3 := StatusBar1.Width;
  if (S1 >= (S3 - 40)) then
  begin
    StatusBar1.Panels[0].Width := S3 - 40;
    StatusBar1.Panels[1].Width := 20;
  end
  else if (S2 >= (S3 - 20)) then
    StatusBar1.Panels[1].Width := S3 - S1 - 20;
end;

Display a *.hlp file on a TForm

Problem/Question/Abstract:

Is there some sort of component that allows me to show a certain page from a normal *.hlp file (non HTML) in a form?

Answer:

As far as I know it cannot be done. The closest you can come to it is to take the standard WinHelp window and parent it to your form via Windows.SetParent. The WinHelp main window has a classname of 'MS_WINDOC', you can use that with FindWindow to find its window handle.

procedure TForm1.Button1Click(Sender: TObject);
var
  wnd: HWND;
begin
  wnd := FindWindow('MS_WINDOC', nil);
  if wnd <> 0 then
  begin
    Windows.SetParent(wnd, handle);
    Windows.MoveWindow(wnd, 0, 0, clientwidth, clientheight, true);
  end;
end;

How to create only one instance of a MDI child form (2)

Problem/Question/Abstract:

I am writing a MDI application. In this application, I just want to create one instance of the MDI child form. That is, if the user clicks New the first time, a MDI child form is created, but on subsequent click, no MDI child will be created. How can I do this and how can I refer to the MDI child that I have created.

Answer:

I assume you know the method to create an instance of a MDIChild form, but I'm going to go through it just in case:

Create your form, set its formstyle property to fsMDIChild, remove it from the autocreate list in your Project|Options.
Use the following code to create the form at run-time (I'm using Button1.Click to create the event):


procedure TMainForm.Button1Click(Sender: TObject);
var
  MyChildForm: TMDIChild {where TMDIChild is TNameOfYourForm}
begin
  MyChildForm := TMDIChild.Create(Application);
end;


Now, to ensure that only 1 instance of a MDIChild is created change the above code to read:


begin
  if MDIChildCount < 1 then
    MyChildForm := TMDIChild.Create(Application);
end;


This code will ensure that only one MDIChild can be open at a given time. Remember to place Action:=caFree in the OnClose event handler of your MDIChild to free memory and resources when it's closed.

To access properties of your MDIChild (Even though there's only going to be 1 in existence) you must use the following type of code (Here an event of the MDIParent is going to disable a component on the MDIChild):


procedure TMainForm.TurnItOffClick(Sender: TObject);
begin
  MyChildForm(ActiveMDIChild).Button1.Enabled := False;
end;


Now, you didn't state whether you only wanted 1 MDIChild form open in the parent form or only 1 of each particular type. If it's the latter, you'll need to access the classes of all your MDI children to see if an instance already exists.

Debugging a DLL

Problem/Question/Abstract:

Debugging a DLL

Answer:

This is done by setting a host application and choosing Delphi 5 (delphi32.exe) itself as the host application. Theoretically very easy - available since Delphi 3.
But there are two catches:

It seems that

the DLL has to be in the same directory as its DPR file (in other words: don't have a separate output directory)

your project path should not contain directories with a space in the name. There seems to be a problem with debugging DLL's with spaces in the project path.

Delphi hangs on startup

Problem/Question/Abstract:

There is a bug in some video cards in the way they handle the ImageList API. When an ImageList is being built in memory that cards will freeze the computer or corrupt the images when they have to swap the ImageList back out to main memory to complete the building on large imagelist's like the 180+ image component pallet list. The S3 chipset has been particularly problematic (Win98 is even worse).

Answer:

Try these:

Apply SP2 and SP3 to your Delphi4 at http://www.inprise.com/devsupport/delphi/downloads/index.html. SP2 tries to work around the problem by pre building the imagelist large enough so it should not start in internal memory and start in main memory.

Get the latest driver (www.s3.com or your vendor if your vendors doesn't work, try the S3 as they tend to be more compliant)

Start Delphi with the -ns switch

Under the [display] section of the SYSTEM.INI file add the following line BusThrottle=1 (reboot afterwards)

Reboot in safe mode and start Delphi. Goto the properties of the component pallet and hide all the controls that you rarely use. This will reduce the imagelist that is getting built and might get you under the threshold.

Reduce the hardware acceleration for the card. (display->properties->settings->advances->performance)

Play with color depth/resolution 1024x768 in 16 bit color seems the worse (particularly with Delphi 3).

Get the latest DirectX drivers.


Also Delphi 4 can not run in Win98 under 16 color mode. You must be at least at 256 colors.

Both SP2 and SP3 try to work around this by creating the initial ImageList large enough so that it either
a) starts in main memory or
b) will not have to grow while adding.
There really is not much more that Borland can do. This is a driver bug and the work around have actually exposed bugs in other drivers that deal with creating large initial ImageLists. In this case Borland was damned if they did, damned if they didn't. SP1 was included in SP2 so when you installed SP2 you also got the first patch. If the BusThrottle works for you this is by far the best solution. All it does is instruct the driver that it must give a
little time slice to the OS so affects on performance are not noticable (so far no one has reported back to me that they can even tell a difference between using and not using the BusThrottle setting except that Delphi runs). Unfortunately not all drivers respect this setting.

Select a recipient from addressbook

Problem/Question/Abstract:

How can I select a recipient from addressbook?

Answer:

Today I want to post a tip about copying of recipients from default addressbook. For example, user must select a list of recipients and you'll process this list in own code (to send a message to these recipients or just import them into own database).

For this task you can use the MAPIAddress procedure from MAPI. This procedure requires a handle of current session (which you'll receive from MAPILogOn procedure), custom caption of dialog, structure for recepient attributes and variable where you'll receive a number of selected recipients.

If MSPIAddress returns SUCCESS_SUCCESS, this mean that user closed a dialog and selected some recipients. After that you must navigater by recipient structure (which you defined as parameter) and process the each recipient.

For example:

var
  lpRecip: TMapiRecipDesc;
  intRecips: ULONG;
  lpRecips: PMapiRecipDesc;
  i: Integer;
begin
  if (MAPIAddress(intMAPISession, 0, 'Select the recipients', 4, '', 0, lpRecip, 0, 0,
    @intRecips, lpRecips) = SUCCESS_SUCCESS) then
  begin
    for i := 0 to intRecips - 1 do
      yourListBox.Items.Add(PMapiRecipDesc(PChar(lpRecips) + i *
        SizeOf(TMapiRecipDesc))^.lpszAddress);
    MAPIFreeBuffer(lpRecips)
  end;
end;

I hope that this tip will help you and save some time. At least when I wrote (in October 2000) this code for own GroupMail, I spent a lot of time for correct work without errors:-)

How to reset the content of a TDBMemo

Problem/Question/Abstract:

I have a form with a TDBMemo control. I also have an "Abort" button which, when pressed, will reset the contents of the TDBMemo control. I know that if you hit the escape key in a TDBMemo this will reset the contents. However, my users are used to hitting the Esc key to exit forms, so I disabled this feature so that they would not lose everything they entered. I did this by changing the value of the Key code in the OnKeyPress event:

if key = #27 then
begin
  key := #0;

I have looked in the VCL and have noticed that when ESC is pressed FDataLink.Reset is invoked. However, this is private, so there is not way to reset the contents. Is there another way around this?

Answer:

All DbCtrls have a "procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;" which can be executed to return the TFieldDataLink as follows:

procedure TForm1.SpeedButton1Click(Sender: TObject);
{must be TSpeedButton so Focus change does take place first}
var
  fDataLink: TFieldDataLink;
begin
  fDataLink := TFieldDataLink(DBMemo1.Perform(CM_GETDATALINK, 0, 0));
  if assigned(fDataLink) then
    fDataLink.Reset;
end;