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.