How to insert data in Paradox memo fields using SQL INSERT statements

Problem/Question/Abstract:

How to insert data in Paradox memo fields using SQL INSERT statements

Answer:

Assuming you are using at least Delphi 3, you need to represent the memo field in the SQL statement with a parameter.

INSERT INTO YourTable
(StrField, MemoField)
VALUES("AAA", : MemoParam)

The parameter would need to be the appropriate data type: the TParam.DataType property would need to be ftMemo. Then, before executing the SQL statement, provide the parameter with a value. How you provide the parameter value will vary depending on the form the source data is in.

If the source is a file, use the TParam.LoadFromFile method.

Query1.ParamByName('MemoParam').LoadFromFile('c:\windows\network.txt');

If the source is a PChar (or equivalent) buffer, use direct assignment of the value to the parameter with the TParam.AsMemo property.

Query1.ParamByName('MemoParam').AsMemo := Buffer;

If the source is in the form of a memory stream, use the TParam.LoadFromStream method.

Query1.ParamByName('MemoParam').LoadFromStream(YourMemoryStream);

A 'MetaBalls' Demo

Problem/Question/Abstract:

A 'MetaBalls' Demo

Answer:

I've been tinkering around with MetaBalls and have made a demo program. To use it just create a new project, save the form as MetaBallsForm and replace the form code with the code below.

unit MetaBallsForm;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Timer1: TTimer;
    procedure SetupMetaBallSystem;
    procedure DrawMetaBalls;
  end;

  TMetaBall = class
  private
    { Private declarations }
    FX, FY: Integer;
    FDx, FDy: Integer;
    FRadius: Integer;
  public
    { Public declarations }
    constructor Create;
    destructor Destroy; override;
    procedure SetRadius(Radius: Integer);
    procedure SetPos(x, y: Integer);
    procedure SetDeltaXY(dx, dy: Integer);
    procedure Update;
    function GetIntensity(x, y: Integer): Double;
    function PointIsInside(x, y: Integer): Boolean;
    function GetBoundingRect: TRect;
  end;

  TMetaBallSystem = class
  private
    { Private declarations }
    FThreshold: Double;
    FBlockRes: Integer;
    FCurrentIntensity: Double;
    FCurrentCount: Integer;
    FMetaBallList: array of TMetaBall;
  public
    { Public declarations }
    constructor Create;
    destructor Destroy; override;
    procedure SetThreshold(Threshold: Double);
    procedure SetBlockRes(BlockRes: Integer);
    procedure AddMetaBall(x, y, Radius, dx, dy: Integer);
    procedure Update;
    function GetBlockRes: Integer;
    function Count: Integer;
    function GetMetaBallBoundingRect(Index: Integer): TRect;
    function GetIntensity: Double;
    function PointIsInside(x, y: Integer): Boolean;
    procedure Clear;
    property CurrentCount: Integer read FCurrentCount write FCurrentCount;
  end;

var
  Form1: TForm1;
  MetaBitmap: TBitmap;
  UsedBitmap: TBitmap;
  MetaBallSystem: TMetaBallSystem;
  IntensityTable: array[0..255] of Double;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  Timer1 := TTimer.Create(nil);
  Timer1.OnTimer := Timer1Timer;
  Timer1.Interval := 50;
  for i := 0 to 255 do
    IntensityTable[i] := (Cos(i * PI / 255) + 1) / 2;
  MetaBitmap := TBitmap.Create;
  MetaBitmap.Width := ClientWidth;
  MetaBitmap.Height := ClientHeight;
  MetaBitmap.PixelFormat := pf15Bit;
  UsedBitmap := TBitmap.Create;
  UsedBitmap.Width := ClientWidth;
  UsedBitmap.Height := ClientHeight;
  UsedBitmap.PixelFormat := pf8Bit;
  MetaBallSystem := TMetaBallSystem.Create;
  SetupMetaBallSystem;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Timer1.Enabled := False;
  MetaBallSystem.Clear;
  FreeAndNil(UsedBitmap);
  FreeAndNil(MetaBitmap);
  FreeAndNil(MetaBallSystem);
  FreeAndNil(Timer1);
end;

procedure TForm1.SetupMetaBallSystem;
var
  i: Integer;
  x, y, r, dx, dy: Integer;
begin
  Randomize;
  MetaBallSystem.Clear;
  MetaBallSystem.SetThreshold(0.4);
  for i := 1 to 5 do
  begin
    x := Random(ClientWidth);
    y := Random(ClientHeight);
    r := (Random(50) + 50);
    x := x + Ord((x - r) < 0) * r;
    y := y + Ord((y - r) < 0) * r;
    x := x - Ord((x + r) >= ClientWidth) * r;
    y := y - Ord((y + r) >= ClientHeight) * r;
    dx := Random(11) - 5;
    dy := Random(11) - 5;
    MetaBallSystem.AddMetaBall(x, y, r, dx, dy);
  end;
end;

constructor TMetaBall.Create;
begin
  inherited Create;
  FDx := 0;
  FDy := 0;
end;

destructor TMetaBall.Destroy;
begin
  inherited Destroy;
end;

procedure TMetaBall.SetRadius(Radius: Integer);
begin
  FRadius := Radius;
end;

procedure TMetaBall.SetPos(x, y: Integer);
begin
  FX := x;
  FY := y;
end;

procedure TMetaBall.SetDeltaXY(dx, dy: Integer);
begin
  FDx := dx;
  FDy := dy;
end;

procedure TMetaBall.Update;
var
  r: TRect;
begin
  Inc(FX, FDx);
  Inc(FY, FDy);
  r := GetBoundingRect;
  if (r.Left < 0) then
  begin
    Inc(FX, 0 - r.Left);
    FDx := -FDx;
  end;
  if (r.Bottom < 0) then
  begin
    Inc(FY, 0 - r.Bottom);
    FDy := -FDy;
  end;
  if (r.Right >= Form1.ClientWidth) then
  begin
    Dec(FX, r.Right - Form1.ClientWidth);
    FDx := -FDx;
  end;
  if (r.Top >= Form1.ClientHeight) then
  begin
    Dec(FY, r.Top - Form1.ClientHeight);
    FDy := -FDy;
  end;
end;

function TMetaBall.GetBoundingRect: TRect;
begin
  Result := Rect(FX - FRadius, FY + FRadius, FX + FRadius, FY - FRadius);
end;

function TMetaBall.GetIntensity(x, y: Integer): Double;
var
  d: Integer;
begin
  Result := 0;
  d := Trunc(Sqrt((FX - x) * (FX - x) + (FY - y) * (FY - y)) * 255 / FRadius);
  if (d > 255) then
    Exit;
  Result := IntensityTable[d];
end;

function TMetaBall.PointIsInside(x, y: Integer): Boolean;
var
  xxyy: Integer;
begin
  xxyy := (FX - x) * (FX - x) + (FY - y) * (FY - y);
  Result := (FRadius <> 0) and (xxyy <= (FRadius * FRadius));
end;

constructor TMetaBallSystem.Create;
begin
  SetLength(FMetaBallList, 0);
end;

destructor TMetaBallSystem.Destroy;
var
  i: Integer;
begin
  for i := 0 to High(FMetaBallList) do
    if (FMetaBallList[i] <> nil) then
      FreeAndNil(FMetaBallList[i]);
  SetLength(FMetaBallList, 0);
end;

procedure TMetaBallSystem.Update;
var
  i: Integer;
begin
  for i := 0 to High(FMetaBallList) do
    if (FMetaBallList[i] <> nil) then
      FMetaBallList[i].Update;
end;

procedure TMetaBallSystem.SetThreshold(Threshold: Double);
begin
  FThreshold := Threshold;
end;

procedure TMetaBallSystem.SetBlockRes(BlockRes: Integer);
var
  Size: Double;
begin
  Size := ln(BlockRes) / ln(2);
  if (Frac(Size) > 0) then
    FBlockRes := 1 shl Trunc(Size + 1)
  else
    FBlockRes := 1 shl Trunc(Size);
end;

function TMetaBallSystem.GetBlockRes: Integer;
begin
  Result := FBlockRes;
end;

procedure TMetaBallSystem.AddMetaBall(x, y, Radius, dx, dy: Integer);
begin
  SetLength(FMetaBallList, High(FMetaBallList) + 2);
  FMetaBallList[High(FMetaBallList)] := TMetaBall.Create;
  FMetaBallList[High(FMetaBallList)].FX := x;
  FMetaBallList[High(FMetaBallList)].FY := y;
  FMetaBallList[High(FMetaBallList)].FDx := dx;
  FMetaBallList[High(FMetaBallList)].FDy := dy;
  FMetaBallList[High(FMetaBallList)].FRadius := Radius;
end;

function TMetaBallSystem.Count: Integer;
begin
  Result := High(FMetaBallList) + 1;
end;

function TMetaBallSystem.GetMetaBallBoundingRect(Index: Integer): TRect;
begin
  Result := Rect(-1, -1, -1, -1);
  if (Index < 0) or (Index > High(FMetaBallList)) then
    Exit;
  Result := FMetaBallList[Index].GetBoundingRect;
end;

function TMetaBallSystem.PointIsInside(x, y: Integer): Boolean;
var
  i: Integer;
  r: Double;
  c: Integer;
begin
  r := 0;
  c := 0;
  for i := 0 to High(FMetaBallList) do
  begin
    if (FMetaBallList[i].PointIsInside(x, y)) then
    begin
      r := r + FMetaBallList[i].GetIntensity(x, y);
      Inc(c);
    end;
  end;
  FCurrentCount := c;
  FCurrentIntensity := r;
  Result := (FCurrentIntensity >= FThreshold);
end;

function TMetaBallSystem.GetIntensity: Double;
begin
  Result := FCurrentIntensity;
end;

procedure TMetaBallSystem.Clear;
var
  i: Integer;
begin
  for i := 0 to High(FMetaBallList) do
    if (FMetaBallList[i] <> nil) then
      FreeAndNil(FMetaBallList[i]);
  SetLength(FMetaBallList, 0);
end;

procedure TForm1.DrawMetaBalls;
type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = array[word] of record
    b, g, r: Byte;
  end;
var
  x, y, i: Integer;
  Pixel: PWordArray;
  UsedPixel: PByteArray;
  r: TRect;
  c: Byte;
begin
  MetaBitmap.Width := ClientWidth;
  MetaBitmap.Height := ClientHeight;
  MetaBitmap.PixelFormat := pf15Bit;
  MetaBitmap.Canvas.Brush.Color := RGB(0, 0, 0);
  MetaBitmap.Canvas.Pen.Color := RGB(0, 255, 0);
  MetaBitmap.Canvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
  UsedBitmap.Width := ClientWidth;
  UsedBitmap.Height := ClientHeight;
  UsedBitmap.PixelFormat := pf8Bit;
  for y := 0 to ClientHeight - 1 do
  begin
    UsedPixel := UsedBitmap.ScanLine[y];
    for x := 0 to ClientWidth - 1 do
      UsedPixel[x] := 0;
  end;
  for i := 0 to MetaBallSystem.Count - 1 do
  begin
    r := MetaBallSystem.GetMetaBallBoundingRect(i);
    if (r.Left < 0) then
      r.Left := 0;
    if (r.Bottom < 0) then
      r.Bottom := 0;
    if (r.Right >= ClientWidth) then
      r.Right := ClientWidth - 1;
    if (r.Top >= ClientHeight) then
      r.Top := ClientHeight - 1;
    for y := r.Bottom to r.Top do
    begin
      Pixel := MetaBitmap.ScanLine[y];
      UsedPixel := UsedBitmap.ScanLine[y];
      for x := r.Left to r.Right do
      begin
        if (UsedPixel[x] = 0) then
        begin
          if (MetaBallSystem.PointIsInside(x, y)) then
          begin
            c := Trunc(31 * MetaBallSystem.GetIntensity);
            if (c > 31) then
              c := 31;
            Pixel[x] := (c shl 5);
            UsedPixel[x] := 1;
          end;
        end;
      end;
    end;
  end;
  Canvas.Draw(0, 0, MetaBitmap);
  MetaBallSystem.Update;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  DrawMetaBalls;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Timer1.Enabled := True;
end;

end.

How to save a TFont in a stream

Problem/Question/Abstract:

How can I save a font (including all its properties like color, angle, etc.) to a stream?

Answer:

{ ... }
type
  FontRec = packed record
    Color: TColor;
    LogFont: TLogFont;
  end;

procedure ReadFont(s: TStream; font: TFont);
var
  fRec: FontRec;
  sz: integer;
begin
  s.Read(sz, SizeOf(Integer));
  if sz = SizeOf(fRec.LogFont) then
  begin
    s.Read(fRec, SizeOf(fRec));
    font.Handle := CreateFontIndirect(fRec.LogFont);
    font.Color := fRec.Color;
  end;
end;

procedure WriteFont(s: TStream; font: TFont);
var
  fRec: FontRec;
  sz: integer;
begin
  sz := SizeOf(fRec.LogFont);
  if Windows.GetObject(font.Handle, sz, @fRec.LogFont) > 0 then
  begin
    s.Write(sz, SizeOf(Integer));
    fRec.Color := font.Color;
    s.Write(fRec, SizeOf(fRec));
  end
  else
  begin
    sz := 0;
    s.Write(sz, SizeOf(Integer));
  end;
end;

Implement Net Send

Problem/Question/Abstract:

How to implement netsend?

Answer:

function NetSend(dest, Source, Msg: string): Longint; overload;
type
  TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;
    buf: PWideChar; buflen: Cardinal): Longint; stdcall;
var
  NetMessageBufferSend: TNetMessageBufferSendFunction;
  SourceWideChar: PWideChar;
  DestWideChar: PWideChar;
  MessagetextWideChar: PWideChar;
  Handle: THandle;
begin
  Handle := LoadLibrary('NETAPI32.DLL');
  if Handle = 0 then
  begin
    Result := GetLastError;
    Exit;
  end;
  @NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');
  if @NetMessageBufferSend = nil then
  begin
    Result := GetLastError;
    Exit;
  end;

  MessagetextWideChar := nil;
  SourceWideChar := nil;
  DestWideChar := nil;

  try
    GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
    GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);
    StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
    StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);

    if Source = '' then
      Result := NetMessageBufferSend(nil, DestWideChar, nil,
        MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1)
    else
    begin
      GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);
      StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1);
      Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,
        MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
      FreeMem(SourceWideChar);
    end;
  finally
    FreeMem(MessagetextWideChar);
    FreeLibrary(Handle);
  end;
end;

function NetSend(Dest, Msg: string): Longint; overload;
begin
  Result := NetSend(Dest, '', Msg);
end;

function NetSend(Msg: string): Longint; overload;
begin
  Result := NetSend('', '', Msg);
end;

Example:

procedure TForm1.Button1Click(Sender: TObject);
const
  NERR_BASE = 2100;
  NERR_NameNotFound = NERR_BASE + 173;
  NERR_NetworkError = NERR_BASE + 36;
  NERR_Success = 0;
var
  Res: Longint;
  sMsg: string;
begin
  Res := NetSend('LoginName', 'Your Message...');
  case Res of
    ERROR_ACCESS_DENIED: sMsg :=
      'user does not have access to the requested information.';
    ERROR_INVALID_PARAMETER: sMsg := 'The specified parameter is invalid.';
    ERROR_NOT_SUPPORTED: sMsg := 'This network request is not supported.';
    NERR_NameNotFound: sMsg := 'The user name could not be found.';
    NERR_NetworkError: sMsg := 'A general failure occurred in the network hardware.';
    NERR_Success: sMsg := 'Message sent!';
  end;
  ShowMessage(sMsg);
end;

How to isolate text between two HTML tags

Problem/Question/Abstract:

I have a TRichEdit.Lines (TStrings) where I want to extract a string and copy it to another string. I use ScanF to find begining of string which is '<a href' and almost end of string which is '</ a>'. Then I need to find either next '<' or end of Line. Once I do all this, how do I extract this string and copy it to another string?

Answer:

See the Copy function. Perhaps the following routine can be of use for you, it uses the diverse PChar-based string functions instead of the standard String Pos and Copy, basically because it is a bit easier in this case to work with pointers.

procedure IsolateTextBetweentags(const S: string; Tag1, Tag2: string; list: TStrings);
var
  pScan, pEnd, pTag1, pTag2: PChar;
  foundText: string;
  searchtext: string;
begin
  {Set up pointers we need for the search. HTML is not case sensitive, so
  we need to perform the search on a uppercased copy of S}
  searchtext := Uppercase(S);
  Tag1 := Uppercase(Tag1);
  Tag2 := Uppercase(Tag2);
  pTag1 := PChar(Tag1);
  pTag2 := PChar(Tag2);
  pScan := PChar(searchtext);
  repeat
    {Search for next occurence of Tag1}
    pScan := StrPos(pScan, pTag1);
    if pScan <> nil then
    begin
      {Found one, hop over it, then search from that position forward for the
                        next occurence of Tag2}
      Inc(pScan, Length(Tag1));
      pEnd := StrPos(pScan, pTag2);
      if pEnd <> nil then
      begin
        {Found start and end tag, isolate text between, add it to the list. We need to
        get the text from the original S, however, since we
                                want the un-uppercased version!}
        SetString(foundText, Pchar(S) + (pScan - PChar(searchtext)), pEnd - pScan);
        list.Add(foundText);
        {Continue next search after the found end tag}
        pScan := pEnd + Length(tag2);
      end
      else
        {Error, no end tag found for start tag, abort}
        pScan := nil;
    end;
  until
    pScan = nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with opendialog1 do
  begin
    filter := 'HTML files|*.HTM; *.HTML';
    if execute then
    begin
      richedit1.PlainText := true;
      richedit1.lines.loadfromfile(filename);
      memo2.clear;
      IsolateTextBetweenTags(richedit1.text, '<H1>', '</H1>', memo2.lines);
    end;
  end;
end;

Custom Datasets

Problem/Question/Abstract:

Writing Custom Datasets

Answer:

Introduction

The release of Delphi 3 introduced one of the most powerful features available in Delphi, the ability to create custom datasets. Prior to Delphi 3, developers had to jump through hoops to get the data aware controls to work with anything other then the BDE. In Delphi 3, Borland wisely separated the TDataset component from the BDE thus enabling anyone to write custom data access components.

Unfortunately, writing TDataset descendants has a reputation of being difficult, largely due to three facts: it's undocumented, it often involves pointers and memory manipulation, and finally there are a lot of methods in the TDataset class to override.

Thus the purpose of this lecture is two fold. The first purpose, and the obvious one, is to learn how to write a custom dataset. The second purpose is to write a TDataset descendant that can be reused as an ancestor for other datasets and handles all of the day to day drudgery involved with writing datasets.

I'm going to be honest here and admit that I'm foisting a bit of an experiment on my audience. Typically at these sort of presentations you usually get a simple example that seems easy to understand but doesn't go nearly far enough in explaining how to implement it beyond the simple example. I'm going to do the opposite.

This is the experiment. The base dataset, called TGXBaseDataset, that we are going to create is actually pretty complicated since it exposes a lot of features of the TDataset class. However, having a complicated intermediary base class in TGXBaseDataset greatly reduces the complexity of the Outlook dataset that is based on TGXBaseDataset. I'm hoping this will bridge both extremes by providing a simple entry point to exploring the world of custom datasets while giving a sufficiently complicated example to push the envelope when you are ready to do so.

Overview of Writing a Custom TDataset

Normally when you talk to people about writing custom datasets the first thing that pops into their mind is databases. However, the fact is that writing a custom dataset can be a powerful tool for displaying data from all sorts of sources. For example, how many times have you had to fill a listview with information from a collection? A reusable alternative would be to write a custom dataset that accesses information in a collection and enables you to display the information in a grid.

Writing custom datasets is about leveraging RAD to the maximum extent possible. It is about writing code once instead of many times. It is about easily moving information between visual controls and containers of information in an easy and efficient manner.

So now that we want to write one, how do we do it? Writing a custom dataset involves overriding a variety of abstract methods of the TDataset class. Typically, the more functionality that the custom dataset exposes the more methods you need to override. At a minimum, you will usually need to override the following methods:

AllocRecordBuffer
InternalAddRecord
InternalInitFieldDefs
IsCursorOpen
FreeRecordBuffer
InternalClose
InternalInitRecord
SetBookmarkFlag
GetBookmarkData
InternalDelete
InternalLast
SetBookmarkData
GetBookmarkFlag
InternalFirst
InternalOpen
SetFieldData
GetRecord
InternalGotoBookmark
InternalPost
SetFieldData
GetRecordSize
InternalHandleException
InternalSetToRecord



The majority of these methods fall into one of two categories, navigation management and buffer management. Navigation management is fairly self explanatory, these are the methods that are called in response to the dataset being navigated through first, prior, next, etc. Methods that fall into this category include InternalFirst, InternalLast and GetRecord.

Buffer management is a little more complicated to explain. In order to accomplish it's work, the TDataset manages a set of buffers. These buffers are used by the TDataset as both a cache and a means of temporarily storing information during the editing process. As a user modifies fields during the edit process, the changes the user makes are stored into one of these record buffers, not the underlying data source. If the user elects to cancel the changes, the TDataset retrieves a fresh copy of the buffer to revert the buffer back to it's original state. If the user posts the changes, then the changes are copied from the buffer into the underlying data source.

Methods that involve buffer management include AllocRecordBuffer, FreeRecordBuffer, GetRecord, GetRecordSize, GetFieldData, SetFieldData and InternalPost. Note that GetRecord is a bit unusual in that it is both a navigation and buffer management method.

It's important to realize that the TDataset class itself does not care how the buffer is structured. The buffer could be a pointer to an object, a mapped memory block, a variant list, etc, it doesn't matter to the TDataset. This gives us a lot of freedom in how we design our TDataset descendants.

A record buffer will typically be composed of three pieces of information:

Navigational information. Each buffer must be able to hold a bookmark flag and a unique identifier that links the buffer to the corresponding row in the dataset. Additionally, it can also contain bookmark information. If you don't provide a mechanism to identify a buffer from a row, your dataset will not work with grids.

Field values. The buffer must contain a copy of the field values for the row it represents.

Calculated field values. The buffer must contain an area that is used to store values for calculated fields.

Generally speaking, when it comes to buffer management and creating a custom TDataset, one of two scenarios will prevail. In the first case, you are writing a custom dataset for something that already supports the concept of record buffers. In this case, managing record buffers within the custom dataset is merely a case of placing a thin veneer on the facility already available. Examples of this case include writing a dataset to wrap the BDE or writing a dataset that provides native access to Interbase. Both the BDE and the Interbase API provide an easy mechanism for creating and maintaining a buffer based on a given cursor.

The other scenario is when we are creating a custom dataset to wrap something that doesn't provide any help in creating and managing record buffers. In this case, the custom dataset will have to be responsible for devising an appropriate buffer scheme and managing them within the context of the TDataset environment.

It is this second scenario that we will be examining in this presentation. In this second scenario, an easy way to manage the record buffer is as a single chunk of memory organized as follows:

Field Values
Navigational Information
Calculated Fields


Most dataset examples you will see layout their buffers in this way, including the TextData demo shipped with Delphi.

Having to work with these record buffers is probably one of the largest reasons why people have difficulty in creating custom datasets. It can get quite complicated managing these buffers and fetching and storing information in each buffer as needed. Many programmers are turned off my having to manipulate pointers and move memory.

In the next part of this presentation, we will examine the various dataset methods that need to be overridden in descendant classes and what the TDataset class expects these methods to do.

TDataset Methods

Allocating and freeing record buffers

TDataset handles the allocation and disposal of record buffers through two methods, AllocRecordBuffer and FreeRecordBuffer. Descendant classes override these methods and create an appropriate buffer. Remember that the TDataset class does not care about how the buffer itself is structured. The buffer could be something as simple as a pointer to an object or as complex as a block of memory containing a mapped layout of all fields.

In terms of memory management, you are guaranteed that buffers will only be created and freed through the aforementioned methods and that the TDataset class will never alter the internal contents of the buffer on it's own. Thus it is safe to stuff pointers and other things into the buffer without worrying about generating memory leaks.

GetRecord

This is probably the single most important method that descendant TDataset classes must override. GetRecord is a combination navigation and data retrieval method that is prototyped as follows:

function TDataset.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean):
  TGetResult;

This function is called with three parameters. The GetMode parameter tells the dataset to perform a navigation operation and can be one of three values as follows:

gmCurrent. This tells the descendant class to return the current record in the buffer.

gmNext. This tells the descendant class to return the next record in the buffer. If there is no next record, grEof must be returned as the Result.

gmPrior. This tells the descendant class to return the previous record in the buffer. If there is no prior record, grBOF must be returned.

As is obvious from the preceding paragraph, since GetRecord also performs a navigational function, descendant classes must be able to pass back whether or not the navigational operation succeeded. For example, if gmNext is passed as the GetMode but the dataset is positioned on the last record, we must be able to pass back the fact that we can't go to the next record. This is done through the result of the function which is of the type TGetResult and can be one of the following values:

grEof. This is returned when the GetMode is gmNext but we are already on the last record.

grBof. This is returned when the GetMode is gmPrior but we are already on the first record.

grOK. The operation specified by GetMode was performed successfully and the buffer parameter is valid.

grError. An unexpected error occurred.

This function passes in a buffer variable which the descendant class must fill in with the current field values. How these field values are mapped into the buffer doesn't matter, but the field values must be there since the values in this buffer are what is used during edit operations. Note that this button only needs to be filled in when the result of the function is grOK.

The DoCheck parameter, if true, tells the database to raise an exception if an error has occurred. This usually only occurs during filtering operations.

GetFieldData and SetFieldData

As we have discussed, the TDataset class doesn't know anything about how our record buffer is organized. The next question then becomes that if the TDataset class doesn't know about our record structure, how it does it pull out field values from this structure? How it does it put them back in when the user is editing a record?

The answer is that it uses the GetFieldData and SetFieldData methods which a custom dataset class must override. These methods are called by the dataset when it needs to retrieve or set a specific field value from the current record buffer.

GetFieldData is prototyped as follows:

function TDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;

The Field parameter is the field for which the value needs to be retrieved. The Field parameter is only passed for reference and should never be altered by this routine.

The Buffer parameter is where the field value needs to be copied to. Looking at the buffer parameter results in a question that doesn't have an obvious answer at first glance. That question is "What size is that buffer and what needs to be copied into it?". The only way of determining this is by looking at the various TField types in DB.pas and examining their GetValue and GetDataSize methods.

Here is a partial table with some values used in the base dataset we will create later on:

Field Type
Buffer Result
ftInteger,ftDate,ftTime
Integer
ftBoolean
Boolean
ftDateTime
TDateTimeRec
ftFloat,ftCurrency
Double
ftString
PChar


As we can see, most types map pretty cleanly with the noteable exception of TDateTime which requires some translation into a TDateTimeRec.

GetFieldData function returns True if a value was copied into the buffer by the method and False if no value was copied.

That covers the GetFieldData method. SetFieldData is the exact reverse operation of GetFieldData. It is passed a buffer with some field value in the buffer that must then be copied back into your record buffer. Note that if your dataset is a readonly dataset, then there is no need to implement SetFieldData. SetFieldData is prototyped as follows:

procedure TDataset.SetFieldData(Field: TField; Buffer: Pointer);

In the case of SetFieldData, the Field parameter is once again the field whose value needs to be copied into the record buffer. The buffer parameter contains the actual value to be copied. Once again, the size and nature of the Buffer will vary depending on the field type but is identical to the buffer type used for each field type in GetFieldData.

GetRecordSize

GetRecordSize returns the size of the record buffer that the TDataset is managing. Descendants override this function and return the size of the buffer they will be allocating in AllocRecordBuffer. Note that all buffers must be sized identically, you cannot allocate one buffer of twenty bytes and then allocate the next buffer at forty bytes. GetRecordSize is prototyped as follows:

function TDataset.GetRecordSize: Word;

GetCanModify

This function determines whether or not the dataset is read only and is prototyped as follows:

function TDataset.GetCanModify: Boolean;

Return True if the dataset can be modified and False if it is readonly.

InternalOpen

Descendant datasets override InternalOpen and perform the necessary logic to open the underlying datasource. Additionally several standard steps are also performed in this method such as initializing the field definitions, creating the default fields if required and binding the fields. Here is a sample InternalOpen method from TGXBaseDataset.

procedure TGXBaseDataset.InternalOpen;
begin
  if DoOpen then

  begin
    BookmarkSize := GetBookMarkSize; //Bookmarks not supported
    InternalInitFieldDefs;
    if DefaultFields then
      CreateFields;
    BindFields(True);
    FisOpen := True;
    FillBufferMap;
  end;

end;

Obviously, InternalOpen must be overrided in all descendant datasets.

InternalClose

InternalClose is called by the TDataset whenever the dataset is closed. Descendants should perform any necessary cleanup in this method. Note that no cleanup of buffers is required as the TDataset manages this automatically by calling FreeRecordBuffer as needed. Additionally, and default fields that were created should be destroyed and fields should be unbound by calling BindFields(False).

InternalHandleException

This procedure is called by the TDataset when an exception occurs. Most of the time, you will simply call Application.HandleException(Self) in this procedure.

InternalInitRecord

This procedure is called whenever the dataset needs to reinitialize a buffer that has been previously allocated. It is prototyped as follows:

procedure TDataset.InternalInitRecord(Buffer: PChar);

This procedure passes one parameter, Buffer, which is the buffer that needs to be reinitialized. If your using a simple memory block for the buffer, it can be initialized using FillChar(Buffer^,GetRecordSize,0) which zeroes out all information in the buffer.

Bookmark Flags

Bookmark flags are used by the dataset to store row positioning information within the dataset. Bookmark flags can be on of the following values: bfCurrent, bfBOF, bfEOF, bfInserted. In order to handle bookmark flags correctly, a custom dataset must support reading and writing this flag to a specified record buffer. This is done by overriding the methods GetBookMarkFlag and SetBookMarkFlag which are prototyped as follows:

function TDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
  procedure TDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);

BookMark Data

The bookmark data methods are used by the dataset to support, surprise, bookmarks. The way bookmarks work within the dataset is that a custom dataset specifies the size of the bookmark. The dataset then takes care of allocating this space and passes a pointer to the GetBookMarkData whenever it needs to fetch a copy of the bookmark data for a given record buffer. GetBookMarkData is prototyped as follows:

procedure TDataset.GetBookmarkData(Buffer: PChar; Data: Pointer);

The Data parameter is where you copy the bookmark data into. Remember that the dataset has already allocated the space required to stuff the bookmark data into the Data parameter.

The method SetBookMarkData is called when the bookmark needs to be stored into a specified record buffer by the dataset. You should copy the bookmark from the Data parameter into the appropriate location in the record buffer.

InternalSetToRecord

As mentioned in the overview of record buffers, each buffer must have an identifier which enables the dataset to be positioned on that buffer based on that identifier. The dataset performs this positioning operation by calling InternalSetToRecord which is prototyped as follows:

procedure TDataset.InternalSetToRecord(Buffer: PChar);

This function is passed a single parameter, Buffer. Based on the buffer passed to InternalSetToRecord, the internal cursor of the dataset must be set to whatever record this buffer represents.

IsCursorOpen

This function enables the dataset to determine whether or not data is available while the dataset is being opened, even if the state is dsInactive. It takes no parameters and returns a Boolean. Return True if data is available or False if it isn't.

InternalFirst

The InternalFirst procedure positions the dataset on the first row, descendants should override this method and take appropriate action.

InternalLast

The InternalLast procedure positions the dataset on the first row, descendants should override this method and take appropriate action.

InternalPost

This method is called whenever the user posts the current record. It is called for both inserts and edits. A TDataset descendant must copy the data from the current record buffer into the underlying datasource in this method. If this method is being called with an insert operation pending, the custom dataset is responsible for inserting a new record prior to saving the buffer contents.

Writing a Generic TDataset Descendant

Introduction

In the previous section we covered what is required to create a custom dataset. In this section we are going to put this information to good use and create a generic TDataset descendant that will greatly simplify writing custom datasets.

The intent of creating this custom dataset is to automate the whole process of having to manually manage record buffers in those scenarios where no buffer management facilities are available. The key to doing this is to realize that there is a finite number of field types defined in DB.pas and thus it is quite possible to create a generic record buffer system that saves and loads field values to the buffer based on the field type of each individual field.

After having written numerous TDataset descendants, I've come to the conclusion that buffer management is where you spend most of your time debugging the descendant and working to get it right. By creating a generic TDataset descendant that already includes a buffer management facility we will be able to greatly reduce the amount of work required to create custom datasets.

Our generic TDataset descendant, called TGXBaseDataset will therefore export a smaller and simpler set of abstract and virtual methods that must be overridden to create a dataset. In the first section of this part of the presentation we will cover the various TDataset methods that we override in TGXBaseDataset. In the second part of this presentation we will examine the TGXBaseDataset methods and how we use them to create a custom dataset by creating a dataset that accesses Outlook mail folders.

Creating TGXBaseDataset

Buffer Management

As mentioned in the introduction of this section, the point of the TGXBaseDataset is to automate the management of record buffers required by TDataset. Our generic buffer in the TGXBaseDataset will be a block of memory and will be laid out as below:

Field Values
Navigational Information
Calculated Fields


The navigational information is defined in a record structure as follows:

type
  PRecordInfo = ^TRecordInfo;
  TRecordInfo = record
    RecordID: Pointer;
    BookMark: Pointer;
    BookMarkFlag: TBookmarkFlag;
  end;

The Bookmark is what is used to uniquely identify the buffer and will enable the dataset to match a row to the buffer in the InternalSetToRecord method. The BookMarkFlag is defined in DB.pas and is used by the dataset to hold navigational information.

The size of the buffer required to hold the field values is determined in the method GetDataSize that is introduced in TGXBaseDataset.

function TGXBaseDataset.GetDataSize: Integer;
var
  Index: Integer;
begin
  Result := 0;
  for Index := 0 to FieldCount - 1 do
    case Fields[Index].DataType of
      ftString: Result := Result + Fields[Index].Size + 1;
      //Leave space for terminating null
      ftInteger, ftSmallInt, ftDate, ftTime:
        Result := Result + sizeof(Integer);
      ftFloat, ftCurrency, ftBCD, ftDateTime:
        Result := Result + sizeof(Double);
      ftBoolean: Result := Result + sizeof(Boolean);
      ftMemo, ftGraphic: Result := Result + sizeof(Pointer);
    end;
end;

Examining the code above, we can see that we are simply cycling through the field definitions. We determine the size required to hold each field and then append that to the result. Once we have finished going through each field we will have the size required to hold the field values in the record buffer. One interesting thing to note in the code is that we are storing BLOB fields (ftMemo and ftGraphic) as pointers. Managing BLOB fields in custom datasets is covered in detail in Appendix 1 of this presentation.

This GetDataSize method is then used within the TDataset method GetRecordSize as follows:

function TGXBaseDataset.GetRecordSize: Word;
begin
  Result := GetDataSize + sizeof(TRecordInfo) + CalcFieldsSize;
  FStartCalculated := GetDataSize + sizeof(TRecordInfo);
end;

Thus the size of the record buffer is the size of the buffer needed to hold the field values (GetDataSize) plus the navigation record (TRecordInfo) plus the size needed to hold calculated field values (CalcFieldsSize). CalcFieldsSize is a method of TDataset. We also set a private variable called FStartCalculated that indicates where the start of the calculated fields buffer starts in the record buffer.

Buffers are allocated in the TDataset method AllocRecordBuffer which is implemented as follows in TGXBaseDataset:

function TGXBaseDataset.AllocRecordBuffer: PChar;
begin
  GetMem(Result, GetRecordSize);
  FillChar(Result^, GetRecordSize, 0);
  AllocateBlobPointers(Result);
end;

This is quite straight forward as we are basically allocating an amount of memory determined by GetRecordSize using the Delphi GetMem procedure. See Appendix 1 for information on AllocateBlobPointers.

Now that we have allocated our buffer, we need to be able to get information into this buffer. We do this by overriding the TDataset method GetRecord as follows:

function TGXBaseDataset.GetRecord(Buffer: PChar;
  GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
  Result := Navigate(GetMode);
  if (Result = grOk) then
  begin
    RecordToBuffer(Buffer);
    ClearCalcFields(Buffer);
    GetCalcFields(Buffer);
  end
  else if (Result = grError) and DoCheck then
    DatabaseError('No Records');
end;

The first thing that this routine does is call the Navigate method. This is a new method introduced in TGXBaseDataset that is overridden by descendants. Descendants use this method to tell the TGXBaseDataset whether or not the navigation function specified in the GetMode parameter was successful. Navigate is prototyped as follows:

function Navigate(GetMode: TGetMode): TGetResult;

If the Navigate method returns grOK, the TGXBaseDescendant starts the process of filling the record buffer by calling it's RecordToBuffer method. RecordToBuffer performs two tasks as follows:

a. It fills in the navigational record, PRecordInfo, in the record buffer. It does this by calling the method AllocateRecordID which a descendant dataset overrides to return an ID. b. It fills in the record buffer with the field values by calling GetFieldValue for each field in the dataset. GetFieldValue is prototyped as follows:

function GetFieldValue(Field: TField): Variant;

The whole point of this exercise is that a dataset descending from TGXBaseDataset need only override GetFieldValue and AllocateRecordID instead of having to worry about managing buffers. It's a lot easier to return a variant for the field data in GetFieldValue then it would be to manage the copying of the field value into the buffer manually. Also, there will be no need to override the TDataset GetFieldData and SetFieldData methods in TGXBaseDataset descendants since it already handles these methods for us automatically.

Let's take a moment to talk about AllocateRecordID. This method is introduced in TGXBaseDataset and is used to get a unique identifier for each record buffer. AllocateRecordID returns a pointer, however if the dataset you are creating uses record numbers then just cast the record number as a pointer and return that. If you need a more complicated identifier, you can return an object or something else as the pointer, however you may need to override DisposeRecordID to free this object or memory as required.

Getting back to record buffer operations, the TGXBaseDataset also has a method called BufferToRecord, which is the reverse operation of RecordToBuffer. It handles copying the field values from the record buffer back to the underlying data source. It does this by calling the method SetFieldValue for each field in the dataset. SetFieldValue is prototyped as follows:

procedure SetFieldValue(Field: TField; Value: Variant);

BufferToRecord passes the field for which the value needs to be saved and the actual value to be saved as a variant.

If your dataset allows inserts, it will need to override the DoBeforeSetFieldValue method. This method is called by the TGXBaseDataset just before the copying of fields from the buffer with SetFieldValue starts. It provides an opportunity for descendant datasets to make any special preparations before saving the field values. In the case of inserting, the special preparation would likely be inserting a new, blank row into the data source. DoBeforeSetFieldValue is prototyped as follows:

procedure DoBeforeSetFieldValue(Inserting: Boolean);

If the dataset is in the process of inserting, then the Inserting parameter will be set to True.

Navigational methods

TGXBaseDataset introduces several methods to manage navigation through the dataset. These methods must be overridden by descendant datasets in order for navigation to be available.

DoFirst

This method moves to the first record in the dataset. It is functionaly equivalent to the InternalFirst method in the TDataset class.

DoLast

This method moves to the last record in the dataset. It is functionaly equivalent to the InternalLast method in the TDataset class.

Navigate

This method is called by the TGXBaseDataset in the GetRecord method and is used to provide the navigational capabilities of GetRecord that we discussed previously in the TDataset section. Descendants override this method and perform the navigation has specified by the GetMode parameter.

GotoRecordID

This method is passed the buffer identifier allocated in AllocateRecordID. Descendant datasets must position the dataset on whatever row that this buffer ID represents.

Creating the Outlook Dataset

Finally, after all that work and discussion we are at the stage of actually creating a practical dataset. For the purpose of this presentation, I have opted to create a dataset which displays information from outlook mail folders. Our TGXOutlookMail dataset will descend from the TGXBaseDataset class.

The first thing we need to do in creating our outlook dataset is to override the TGXBaseDataset method DoOpen as follows:

function TGXOutlookMail.DoOpen: Boolean;
begin
  FCurRec := -1;
  FApp := CoOutlookApplication.Create;
  if FApp <> nil then
    FNmSpace := FApp.GetNameSpace('MAPI');
  if FNmSpace <> nil then
    FFolder := FNmSpace.GetDefaultFolder(Folders[FOutlookFolder]);
  if FFolder <> nil then
    FItems := FFolder.Items;
  Result := (FItems <> nil);
end;

The outlook dataset will use record numbers, thus we represent the record number with the private variable FCurRec. FCurRec is initialized to -1. Next we get an instance of Outlook, the outlook namespace and the folder. Note that depending on how your copy of outlook is setup, you may need to change the code above to log into the outlook namespace.

The next step is to override the TGXBaseDataset method, DoClose. This appears as follows:

procedure TGXOutlookMail.DoClose;
begin
  FMailItem := nil;
  FItems := nil;
  FFolder := nil;
  FNMSpace := nil;
  FApp := nil;
end;

All we are doing in this method is releasing the interfaces we hold to the various outlook objects.

The next thing that must be done is defining what fields will be available in our dataset. This is done by overriding the TGXBaseDataset method DoCreateFieldDefs. In our outlook dataset, we implement this as follows:

procedure TGXOutlookMail.DoCreateFieldDefs;
begin
  FieldDefs.Add('ENTRYID', ftString, 40, False);
  FieldDefs.Add('SUBJECT', ftString, 255, False);
  FieldDefs.Add('RECEIVEDTIME', ftDateTime, 0, False);
  FieldDefs.Add('BODY', ftMemo, 0, False);
end;

Once we have defined our fields, we must provide the means to get the field data into the buffer. This is accomplished by overriding GetFieldValue from the TGXBaseDataset.

function TGXOutlookMail.GetFieldValue(Field: TField): Variant;
begin
  if FMailItem = nil then
    exit;
  if Field.FieldName = 'RECEIVEDTIME' then
    Result := FMailItem.ReceivedTime;
  if Field.FieldName = 'ENTRYID' then
    Result := FMailItem.EntryID;
  if Field.FieldName = 'SUBJECT' then
    Result := FMailItem.Subject;
end;

All this function is doing is checking what field is requested and copying the appropriate value from the mail item to the Result of the method. The variable FMailItem is actually set in DoBeforeGetFieldValue. While the FMailItem could be set in the GetFieldValue each time it is called, it is more efficient to do this once in DoBeforeGetFieldValue.

The next thing we need to do is handle the writing of the field values back to the mail item after the user has modified a record and posted the changes. To do this, we first need to override DoBeforeSetFieldValue to check to see if we are inserting a record, and if we are, create an appropriate mail item.

procedure TGXOutlookMail.DoBeforeSetFieldValue(
  Inserting: Boolean);
begin
  if Inserting then
    FMailItem := FItems.Add(olMailItem) as MailItem
  else
    FMailItem := FItems.Item(FCurRec + 1) as MailItem;
end;

As we can see above, if the Inserting parameter is set to True, we create a new mail item otherwise we set the mail item to be whatever the current one is indicated by FCurRec.

We can now move on to SetFieldValue which appears as follows:

procedure TGXOutlookMail.SetFieldValue(Field: TField;
  Value: Variant);
begin
  if FMailItem <> nil then
  begin
    if Field.FieldName = 'SUBJECT' then
      FMailItem.Subject := Value;
  end;
end;

Again this is a very simple method, as we are simply checking what the field name is and then assigning it to the appropriate property of the mail item. Note that the only editable non-blob property in our example is Subject as both EntryID and ReceivedTime are not editable in Outlook mail items.

We then override the DoAfterSetFieldValue method to save the mail item.

procedure TGXOutlookMail.DoAfterSetFieldValue(Inserting: Boolean);
var
  Index: Integer;
begin
  FMailItem.Save;
  if Inserting then
  begin
    FMailItem := FMailItem.Move(FFolder) as MailItem;
    Index := EntryIDToIndex(FMailItem.EntryID);
    if Index >= 1 then
      FCurRec := Index - 1;
  end;
  FMailItem := nil;
end;

Finally we move on to the navigation methods which appear as follows:

procedure TGXOutlookMail.DoFirst;
begin
  FCurRec := -1;
end;

procedure TGXOutlookMail.DoLast;
begin
  FCurRec := RecordCount;
end;

function TGXOutlookMail.Navigate(GetMode: TGetMode): TGetResult;
begin
  if RecordCount < 1 then
    Result := grEOF
  else
  begin
    Result := grOK;
    case GetMode of
      gmNext:
        begin
          if FCurRec >= RecordCount - 1 then
            Result := grEOF
          else
            Inc(FCurRec);
        end;
      gmPrior:
        begin
          if FCurRec <= 0 then
          begin
            Result := grBOF;
            FCurRec := -1;
          end
          else
            Dec(FCurRec);
        end;
      gmCurrent:
        if (FCurRec < 0) or (FCurRec >= RecordCount) then
          Result := grError;
    end;
  end;
end;

The methods DoFirst and DoLast are very simple and are self explanatory. The Navigate method is somewhat more complicated. When the navigate method is called, it is passed the GetMode parameter which indicates what navigate should do. GetMode will be gmNext, gmPrior or gmCurrent. Navigate then attempts to set the current row accordingly through FCurRec. If it can't, it returns a suitable response indicating what happened such as grEOF or grBOF. If everything is allright, it returns grOK.

Conclusion

In this presentation we have covered how to create a custom dataset. We have created a reusable base class which enables to perform this task very easily. We have then proved the concept by creating a simple dataset example to access Outlook mail items.

Interested parties can read Appendix 1 for information on how to handle BLOB fields.

Appendix 1 Handling BLOB fields in TDataset descendants

I have explicitly decided not cover BLOB fields in the main presentation. After starting to write this presentation it became obvious that it was going to be complicated and in an attempt to simplify things, I elected to move the discussion of handling BLOB fields to this appendix.

BLOB fields are binary large object fields which can be of varying length. They present a special problem when you are attempting to create a dataset which manages it's own record buffers. This problem arises because the space allocated to the record buffers is fixed in length whereas the data in a BLOB field is not.

The easy way to solve this problem is to allocate pointers in the record buffer to another chunk of memory that holds the BLOB field. Care must be taken when using this technique to not overwrite these pointers in the buffer otherwise memory leaks and access violations will ensue.

The TGXBaseDataset that we presented in this presentation supports BLOB fields of type ftMemo and ftGraphic. To support BLOB fields, we have added some additional code to various methods.

The first method we will look at is AllocRecordBuffer. As you may recall, it was implemented as follows in the TGXBaseDataset:

function TGXBaseDataset.AllocRecordBuffer: PChar;
begin
  GetMem(Result, GetRecordSize);
  AllocateBlobPointers(Result);
end;

As explained earlier, the first line allocates memory for the buffer. The second line, which calls AllocateBlobPointers, creates the various BLOB pointers and stuffs them into the record buffer.

procedure TGXBaseDataset.AllocateBLOBPointers(Buffer: PChar);
var
  Index: Integer;
  Offset: Integer;
  Stream: TMemoryStream;
begin
  for Index := 0 to FieldDefs.Count - 1 do
    if FieldDefs[Index].DataType in [ftMemo, ftGraphic] then
    begin
      Offset := GetFieldOffset(Index);
      Stream := TMemoryStream.Create;
      Move(Pointer(Stream), (Buffer + Offset)^, sizeof(Pointer));
    end;
end;

As we can see above, we simply iterate through the fielddefs of the dataset and for any BLOB fields we come across we create a memory stream and stuff a pointer to the memory stream in the appropriate position in the record buffer.

A companion method, FreeBlobPointers, performs the reverse operation by freeing all Blob pointers in the record buffer.

Now that we are allocating a spot to hold the Blob fields, we need to move the Blob information in and out of our memory stream. The first step in doing this is in the TGXBaseDataset methods RecordToBuffer. When we load the record into the buffer in this method, if the field is a ftMemo or ftGraphic, we call the TGXBaseDataset method GetBlobField.

procedure GetBlobField(Field: TField; Stream: TStream);

Descendant datasets override the GetBlobField method and copy the Blob field data into the stream. This stream is the stream whose pointer is stored in the record buffer for that field.

The second step is done by overriding the method CreateBlobStream in TDataset. It has been implemented as follows:

function TGXBaseDataSet.CreateBlobStream(Field: TField;
  Mode: TBlobStreamMode): TStream;
begin
  Result := TGXBlobStream.Create(Field as TBlobField, Mode);
end;

This function is called whenever the dataset needs to read or write the data in the blob field. The field parameter is the field which needs to be handled while Mode specifies whether or not the blob field is being read, written or is in read/write mode.

In the implementation above, we are creating a custom streaming object called TGXBlobStream. This object provides the interface between the blob data and the dataset. In this example TGXBlobStream is derived from TMemoryStream, though in your own implementations this stream can be based on any form of stream.

In order to provide communication between the stream and the dataset, we have added a custom constructor to the stream so that the field the stream works with is passed as a parameter. We have also passed the mode into the constructor as well.

constructor TGXBlobStream.Create(Field: TBlobField;
  Mode: TBlobStreamMode);
begin
  inherited Create;
  FField := Field;
  FMode := Mode;
  FDataSet := FField.DataSet as TGXBaseDataset;
  if Mode <> bmWrite then
    LoadBlobData;
end;

In the constructor above, we save a reference to the field and dataset that the stream will be working with. We also save the blob stream mode that was passed. Finally, if the mode isn't bmWrite, we load the blob data using the method called LoadBlobData.

procedure TGXBlobStream.LoadBlobData;
var
  Stream: TMemoryStream;
  Offset: Integer;
  RecBuffer: PChar;
begin
  Self.Size := 0;
  RecBuffer := FDataset.GetActiveRecordBuffer;
  if RecBuffer <> nil then
  begin
    Offset := FDataset.GetFieldOffset(FField.Index);
    Move((RecBuffer + Offset)^, Pointer(Stream), sizeof(Pointer));
    Self.CopyFrom(Stream, 0);
  end;
  Position := 0;
end;

This method simply locates the Stream pointer we stored in the record buffer earlier in the AllocateBlobPointers method and then reads in the BLOB data from that stream.

We then override the Write method that TGXBlobStream inherits from TStream and set the private variable FModified to True if any information is written. When the stream is destroyed, we check to see if this variable is true, and if so, it indicates that the blob data has changed and must be written back to the record buffer. The stream is written back in the SaveBlobData method of TGXBlobStream.

Finally, when the data is posted in InternalPost, the TGXBaseDataset calls the method SetBlobData. Descendant datasets override SetBlobData and write back the stream passed in this method to the specified Blob field.

Conclusion

While BLOB fields had a bit of extra complexity to implementing a dataset, it is not that difficult once you know what all of the steps are.

Click here to download source files.

Display different hints for each node in a TTreeView

Problem/Question/Abstract:

I want to display a hint on a TTreeView which varies from node to node. So I get the node over which the mouse is in the MouseMove event and change the Hint property of the TreeView.

Answer:

Our ElTree has own hints for every item and we did the following:

{ ... }
if (FHintItemEx <> nil) or (not ShowHint) then
begin
  Application.Hint := FOwner.FRealHint;
  Hint := FOwner.FRealHint;
  TSI := GetItemAt(Message.XPos, Message.YPos, IP, HCol);
  if (TSI <> nil) then
  begin
    if (FHintItemEx <> TSI) then
    begin
      if Length(TSI.Hint) > 0 then
      begin
        Application.Hint := TSI.Hint;
        Hint := TSI.Hint;
      end;
      if ShowHint and (not FInDragging) then
      begin
        P := ClientToScreen(SmallPointToPoint(Message.Pos));
{$IFDEF VCL_5_USED}
        Application.ActivateHint(P);
{$ELSE}
        MoveMemory(@AMsg, @Message, sizeof(AMsg));
        TWMMouse(AMsg).XPos := -10000;
        TWMMouse(AMsg).YPos := -10000;
        Application.HintMouseMessage(Self, AMsg);
        TWMMouse(AMsg).Pos := Message.Pos;
        Application.HintMouseMessage(Self, AMsg);
{$ENDIF}
      end;
    end;
  end;
end;
{ ... }

Check which subitem of a TListView's ListItem was clicked

Problem/Question/Abstract:

I have a listview that is displayed using the vsReport view style. It contains a number of columns, and subsequently, the listitems have corresponding subitems. I want to give the user the ability to edit the text in any of the subitems by just clicking on the subitem. How does one do this? I can't seem to figure out a straight forward way to capture the subitem index when a listitem is clicked.

Answer:

The following is copied and pasted from 2 different units in an old D3 project. The version of ListView_SubItemHitTest in D3 didn't allow for subitems to be "hit-tested" I think because it wasn't available in the version of ComCtl32.DLL at the time.

uses
  CommCtrl, ComCtrls;

type
  { Updated version of TLVHitTestInfo (has also been updated in D5) }
  PLVHitTestInfoNew = ^TLVHitTestInfoNew;
  TLVHitTestInfoNew = record
    Pt: TPoint;
    Flags: Integer;
    iItem: Integer;
    iSubItem: Integer;
  end;

  {Updated version of CommCtrl function}

function ListView_SubItemHitTest(hwndLV: HWND; var lvhti: TLVHitTestInfoNew): Integer;
begin
  Result := SendMessage(hwndLV, LVM_SUBITEMHITTEST, 0, Longint(@lvhti));
end;

function ListViewSubItemHitTest(Handle: HWND; X: Integer; Y: Integer): Integer;
var
  HitTest: TLVHitTestInfoNew;
begin
  HitTest.pt.X := X;
  HitTest.pt.Y := Y;
  {Calls ListView_SubItemHitTest from *this* unit, not from CommCtrl.pas}
  ListView_SubItemHitTest(Handle, HitTest);
  Result := HitTest.iSubItem;
end;

procedure TForm1.ListView1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Item: TListItem;
  iSubItem: Integer;
begin
  Item := ListView1.GetItemAt(X, Y);
  if Assigned(Item) then
  begin
    iSubItem := ListViewSubItemHitTest(ListView1.Handle, X, Y);
    {etc.}
  end;
end;

Work with reports in MS Access

Problem/Question/Abstract:

How I can open a report (in Print Preview mode and also print direct) in an MS Access database?

Answer:

In the next small example I'll demonstrate how you can call the report in MS Access:

var
  Access: Variant;
begin
  // open the Access application
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;

  // open the database
  //The second parameter specifies whether you want to open the database in Exclusive mode

  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

// open the report
{The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which is the default, prints the report immediately. If you are not using the type library, you can define these values like this:

const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;

  The third parameter is for the name of a query in the current
  database.The fourth parameter is for a SQL WHERE clause - the string must be valid
  SQL, minus the WHERE.}

  Access.DoCmd.OpenReport('Titles by Author', acViewPreview,
    EmptyParam, EmptyParam);

  { ... }
    // close the database
  Access.CloseCurrentDatabase;

  // close the Access application
    {const
      acQuitPrompt = $00000000;
      acQuitSaveAll = $00000001;
      acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;

How to assign an EditMask of 000.00 to a TDBEdit

Problem/Question/Abstract:

I have a TDBEdit component linked to a string field. I have an assigned EditMask = '000.00' to capture a $ amount (I cannot make the field numeric). When the user enters 0.00, the data is being stored as '0 .00' in the table. What is the correct EditMask for such an entry? Or do I have to get the data from another property to store in the table?

Answer:

An EditMask can be awkward. I tend toward tidying up with custom formatting.

procedure TForm1.MaskEditEnter(Sender: TObject);
begin
  if Sender is TMaskEdit then
    TMaskEdit(Sender).EditMask := '!999.99;1; ';
end;

procedure TForm1.MaskEditExit(Sender: TObject);
begin
  if Sender is TMaskEdit then
    TMaskEdit(Sender).Text := MyMoneyFormat(TMaskEdit(Sender).Text);
end;

function MyMoneyFormat(S: string): string;
var
  X: Integer;
  R: string;
begin
  R := '0';
  for X := 1 to Length(S) do
    if S[X] <> ' ' then
      R := R + S[X];
  Result := Format('%0.002f', [StrToFloat(R)]);
end;

How to check whether an application is running or not responding

Problem/Question/Abstract:

I'm in the process of writing a service application that needs to check the status of a couple of running programs - so that it can kill/ restart the programs if they become unresponsive. I'm using CreateProcess to start the applications and terminateprocess to kill the applications. What API call can I use to check the status of a running application such as "Running" or "Not Responding" like Taskmanager does?

Answer:

Use SendMessageTimeout to send a message to the window. If the message times out after, say, 10 seconds, you can assume the applcation is not responding (the task manager assumes this after 5 seconds).


procedure TForm1.Button1Click(Sender: TObject);
var
  Res: DWORD;
  H: HWND;
begin
  H := FindWindow(nil, 'FormSomeCaption');
  if H = 0 then
    Label1.Caption := 'Window not found'
  else if SendMessageTimeout(H, WM_NULL, 0, 0, SMTO_NORMAL, 100, Res) <> 0 then
    Label1.Caption := 'Responding'
  else
    Label1.Caption := 'Not responding';
end;


And to kill it, no questions asked, then


procedure TForm1.ButtonClick(Sender: TObject);
var
  ProcessHandle: THandle;
  WinHwnd: HWND;
  ProcessID, ExitCode: Integer;
begin
  ProcessID := 0;
  ExitCode := 0;
  WinHwnd := FindWindow(nil, 'FormSomeCaption');
  if not (IsWindow(WinHwnd)) then
  begin
    ShowMessage('Window not found');
    exit;
  end;
  GetWindowThreadProcessID(WinHwnd, @ProcessID);
  ProcessHandle := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_VM_OPERATION
    or PROCESS_VM_WRITE or PROCESS_VM_READ or PROCESS_TERMINATE,
    False, ProcessID);
  if (ProcessHandle > 0) then
  begin
    GetExitCodeProcess(ProcessHandle, ExitCode);
    { or  GetExitCodeProcess(ProcessHandle, DWORD(ExitCode)); }
    TerminateProcess(ProcessHandle, ExitCode);
    CloseHandle(ProcessHandle);
  end
  else
    ShowMessage('Unable to get proccess Handle');
end;

Paint a border around the selection in a TStringGrid

Problem/Question/Abstract:

Is there any way to draw just borders around the selected cell(s) or row of a string grid? Similar to what you can do in Excel?

Answer:

Using the OnDrawCell event you have full control over how a cell is drawn since you do all the work, including drawing a cells background and content yourself.

Paint a thick border around the selection in a grid:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
      Integer);
  private
    { Private declarations }
    FLastCell: TGridCoord;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

  procedure DrawLine(onCanvas: TCanvas; x1, y1, x2, y2: Integer);
  begin
    onCanvas.MoveTo(x1, y1);
    onCanvas.LineTo(x2, y2);
  end;

begin
  if gdFixed in State then
    Exit;
  with Sender as TStringgrid do
  begin
    Canvas.Brush.Color := $C0FFFF;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(Rect);
    if gdSelected in State then
    begin
      Canvas.Pen.Width := 1;
      Canvas.Pen.Color := clBlue;
      Canvas.Pen.Style := psSolid;
      if aCol = Selection.Left then
      begin
        DrawLine(Canvas, rect.left, rect.top, rect.left, rect.bottom);
        DrawLine(Canvas, rect.left + 1, rect.top, rect.left + 1, rect.bottom);
      end;
      if aCol = Selection.Right then
      begin
        DrawLine(Canvas, rect.right, rect.top, rect.right, rect.bottom);
        DrawLine(Canvas, rect.right - 1, rect.top, rect.right - 1, rect.bottom);
      end;
      if arow = Selection.Top then
      begin
        DrawLine(Canvas, rect.left, rect.top, rect.right, rect.top);
        DrawLine(Canvas, rect.left, rect.top + 1, rect.right, rect.top + 1);
      end;
      if arow = Selection.Bottom then
      begin
        DrawLine(Canvas, rect.left, rect.bottom, rect.right, rect.bottom);
        DrawLine(Canvas, rect.left, rect.bottom - 1, rect.right, rect.bottom - 1);
      end;
      Canvas.Font.Color := clBlack;
    end;
    InflateRect(rect, -2, -2);
    Canvas.TextRect(rect, rect.left, rect.top, Cells[acol, arow]);
  end;
end;

type
  tgridcracker = class(tstringgrid);

procedure TForm1.StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  (Sender as TStringgrid).MouseToCell(X, Y, FLastCell.X, FLastCell.Y);
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  currentcell: TGridCoord;
  i, k: Integer;
begin
  if ssLeft in Shift then
  begin
    (Sender as TStringgrid).MouseToCell(X, Y, currentcell.X, currentcell.Y);
    if (FLastCell.X <> CurrentCell.X) or (FLastCell.Y <> CurrentCell.Y) then
    begin
      with TGridCracker(Sender) do
        for i := Selection.Left to Selection.Right do
          for k := selection.top to Selection.bottom do
            InvalidateCell(i, k);
    end;
  end;
end;

end.

How to paint a TListBox with alternating background colours per row

Problem/Question/Abstract:

I am trying to display a list box that has an alternating background color for each row. I realize I can do this by making the Listbox an owner draw list box and setting the background color for each line when it is drawn. The problem here is only the lines corresponding to existing items will be effected. Even if the listbox has no items in it, I still want it to be displayed with the alternating background colors.

Answer:

Solve 1:

It requires a combination of an OnDrawItem handler (or an overriden DrawItem method) and a handler for WM_ERASEBKGND. See example below. For some reason the WM_ERASEBKGND handler is not called when the listbox contains no items.

unit Unit1;

interface

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

type
  TListbox = class(Stdctrls.TListbox)
  private
    procedure wmEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
  end;
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := listbox1.items.count to listbox1.items.count + 5 do
    listbox1.items.add(format('Item %d', [i]));
end;

{ TListbox }
const
  colors: array[Boolean] of TColor = ($FFFFC0, $C0FFFF);

procedure TListbox.wmEraseBkGnd(var msg: TWMEraseBkGnd);
var
  cv: TCanvas;
  h, max: Integer;
  r: TRect;
  b: Boolean;
begin
  msg.result := 1;
  h := Perform(LB_GETITEMHEIGHT, 0, 0);
  if h = LB_ERR then
    h := ItemHeight;
  cv := TCanvas.Create;
  try
    cv.Handle := msg.DC;
    r := Rect(0, 0, ClientWidth, h);
    b := Odd(TopIndex) and (TopIndex >= 0);
    max := ClientHeight;
    cv.Brush.Style := bsSolid;
    while r.Top < max do
    begin
      cv.Brush.Color := colors[b];
      b := not b;
      cv.FillRect(r);
      OffsetRect(r, 0, h);
    end;
  finally
    cv.Handle := 0;
    cv.free;
  end;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  cb, ct: TColor;
begin
  if not (odSelected in State) then
    with Control as TListbox do
    begin
      canvas.Brush.Color := colors[Odd(index)];
      canvas.Brush.Style := bsSolid;
    end;
  Rect.Right := Control.ClientWidth;
  with Control as TListbox do
  begin
    canvas.FillRect(Rect);
    canvas.Brush.Style := bsClear;
    canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[index]);
  end;
end;

end.

Solve 2:

procedure TFrmAlignText.ListBoxDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  horzOffset: integer;
  vertOffset: integer;
begin
  {ListBox.Style is set to lbOwnerDrawFixed.}
  with ListBox.Canvas do
  begin
    {vertOffset added to Rect.Top causes the string to be vertically centered in the rectangle}
    vertOffset := (((Rect.Bottom - Rect.Top) - TextExtent(ListBox.Items[Index]).CY) div 2);
    {TextWidth('Mi') div 4 gives (roughly) half of an average character width}
    horzOffset := TextWidth('Mi') div 4;
    if not (odSelected in State) then
    begin
      if Odd(Index) then
      begin
        Brush.Color := clBtnFace;
        Font.Color := clBtnText
      end
      else
      begin
        Font.Color := clFuchsia;
      end;
    end;
    FillRect(Rect);
    TextOut(Rect.Left + horzOffset, Rect.Top + vertOffset, ListBox.Items[Index]);
  end;
end;

Write a Screensaver

Problem/Question/Abstract:

How to Write a Screensaver in Delphi

Answer:

In order to write a screensaver we need to include several procedures:

FormShow - hide cursor, setup message processing, start screensaver display
FormHide - stop screensaver display, show cursor
DeactivateScrSaver - process messages, deactivate if keys / mouse pressed

Typical code for these procedures is shown below.

You should ensure that your form is designed with the style fsStayOnTop. You also need to make sure only one instance of your program is running in the usual way. Finally you need to include the compiler directive {$D SCRNSAVE programname Screen Saver} in your project unit (*.dpr).

Once your program is compiled then change it's filename extension to SCR and copy it to your \WINDOWS\SYSTEM folder.

If running on Windows 98 you must disable the screensaver calls when it is running. I have not needed to do this for versions of windows prior to 98 but it should work on all versions. To do this insert the following call into your FormCreate method:

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 0);

You must reverse this in your FormClose method:

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0);

var
  crs: TPoint; {original location of mouse cursor}

procedure TScrForm.FormShow(Sender: TObject);
{starts the screensaver}
begin
  WindowState := wsMaximized; {ensure program fills screen}
  GetCursorPos(crs); {get current cursor position}
  Application.OnMessage := DeactivateScrSaver; {check for Mouse/Keys}
  ShowCursor(false); {hide the cursor}
  {start screensaver display...}
  //
end; {procedure TScrForm.FormShow}

procedure TScrForm.FormHide(Sender: TObject);
{returns control to the user}
begin
  Application.OnMessage := nil; {discard the message}
  {stop the screensaver...}
  //
  ShowCursor(true); {bring the cursor back}
end; {procedure TScrForm.FormHide}

procedure TScrForm.DeactivateScrSaver(var Msg: TMsg; var Handled: boolean);
{detects Mouse movement or Keyboard use}
var
  done: boolean;
begin
  if Msg.message = WM_MOUSEMOVE then {mouse movement}
    done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
      (Abs(HIWORD(Msg.lParam) - crs.y) > 5)
  else {key / mouse button pressed?}
    done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
      (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or
      (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or
      (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or
      (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN);
  if done then
    Close;
end; {procedure TScrForm.DeactivateScrSaver}

How to remove the scrollbar of a TListBox

Problem/Question/Abstract:

I want to remove the scrollbar of a TListBox and control scrolling with a separate scrollbar. Anyone has an idea how to remove it?

Answer:

This requires a somewhat dubious hack. Derive a new component from TListBox, like this:


type
  TNoVScrolllistbox = class(TListBox)
  private
    procedure WMNCCalcSize(var msg: TMessage); message WM_NCCALCSIZE;
  end;

procedure TNoVScrolllistbox.WMNCCalcSize(var msg: TMessage);
var
  style: Integer;
begin
  style := GetWindowLong(handle, GWL_STYLE);
  if (style and WS_VSCROLL) <> 0 then
    SetWindowLong(handle, GWL_STYLE, style and not WS_VSCROLL);
  inherited;
end;


This technique works for nearly any control that uses the standard window scrollbars.

Create a balloon-shaped tooltip

Problem/Question/Abstract:

How to create a balloon-shaped tooltip

Answer:

Solve 1:

You could show a ToolTip control, which would have the appearance of a cartoon "balloon", with rounded corners and a stem pointing to the item. Also, there could be a multiline text and a caption with an icon. But in order to see this, be sure that there are Version 5.80 of Comctl32.dll and version 5.0 of Shlwapi.dll installed on your machine. Below is the code which would force the tooltip to show itself.

{ ... }
var
  FTTHandle: THandle;

const
  TTM_SETTITLE = $0420;
  TTS_BALLOON = $040;

procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  ti: TOOLINFO;
  XRect: TRect;
begin
  FTTHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or
    TTS_NOPREFIX or TTS_BALLOON, 0, 0, 0, 0, Handle, 0, Application.Handle, nil);
  ti.cbSize := sizeof(TOOLINFO);
  ti.uFlags := TTF_SUBCLASS or TTF_DI_SETITEM;
  ti.hwnd := Handle;
  ti.hinst := Application.Handle;
  ti.uId := 0;
  ti.lpszText := 'First line' + #$0D#$0A + 'Second line' + #$0D#$0A + {...}
                + 'Last Line';
  {ti.lpszText := LPSTR_TEXTCALLBACK;}
  XRect := ClientRect;
  ti.rect.left := XRect.left;
  ti.rect.top := XRect.top;
  ti.rect.right := XRect.right;
  ti.rect.bottom := XRect.bottom;
  SendMessage(FTTHandle, TTM_ADDTOOL, 0, integer(@ti));
  SendMessage(FTTHandle, TTM_SETTITLE, 1, integer(PChar('Title')));
  SendMessage(FTTHandle, TTM_SETMAXTIPWIDTH, 0, 100);
  SendMessage(FTTHandle, TTM_SETTIPBKCOLOR, clMoneyGreen, 0);
  SendMessage(FTTHandle, TTM_SETTIPTEXTCOLOR, clNavy, 0);
end;

Basically, you could even perform some custom painting on the tooltip's surface. In order to do this add a WM_NOTIFY message handler to the form and handle the NM_CUSTOMDRAW notification. Below is an example:

{ ... }
type
  TForm1 = class(TForm)
    SpeedButton2: TSpeedButton;
    procedure SpeedButton2Click(Sender: TObject);
  protected
    procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  end;

  { ... }

procedure TForm1.WMNotify(var Message: TWMNotify);
var
  XCanvas: TCanvas;
  XRect: TRect;
begin
  inherited;
  if integer(Message.NMHdr.hwndFrom) = integer(FTTHandle) then
  begin
    case Message.NMHdr.code of
      TTN_POP:
        begin
          {do something here, when tooltip hides}
        end;
      TTN_SHOW:
        begin
          {do something here, when tooltip show itself}
        end;
      TTN_NEEDTEXT:
        begin
          PTOOLTIPTEXT(Message.NMHdr).lpszText := 'some text...';
          {here you could set new text to the tooltip, but only in
                                        case you've specified a LPSTR_TEXTCALLBACK constant
                                        in the lpszText identifier, in the SpeedButton2Click method}
        end;
      NM_CUSTOMDRAW:
        begin
          with PNMCustomDraw(Message.NMHdr)^ do
          begin
            if dwDrawStage = CDDS_PREPAINT then
            begin
              Message.Result := CDRF_NOTIFYPOSTPAINT;
            end
            else if dwDrawStage = CDDS_POSTPAINT then
            begin
              XCanvas := TCanvas.Create;
              try
                XCanvas.Handle := hdc;
                XRect := PNMCustomDraw(Message.NMHdr)^.rc;
                XRect.Left := XRect.Right - 40;
                XRect.Bottom := XRect.Top + 30;
                XCanvas.Brush.Color := clBlue;
                XCanvas.FillRect(RECT(XRect.Left, XRect.Top, XRect.Right,
                                                                        XRect.Top + 15));
                XCanvas.Brush.Color := clYellow;
                XCanvas.FillRect(RECT(XRect.Left, XRect.Top + 15,
                                                                        XRect.Right, XRect.Top + 30));
                XCanvas.Brush.Color := clBlack;
                XCanvas.FrameRect(XRect);
              finally
                XCanvas.Free;
              end;
            end;
          end;
        end;
    end;
  end;
end;


Solve 2:

unit Unit1;

interface

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

const
  TTS_BALLOON = $40;
  TTM_SETTITLE = (WM_USER + 32);

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    {Private declarations}
  public
    {Public declarations}
  end;

var
  Form1: TForm1;
  hTooltip: Cardinal;
  ti: TToolInfo;
  buffer: array[0..255] of char;

implementation

{$R *.dfm}

procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst := hInstance;
  end;
end;

procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title:
  PChar);
var
  Item: THandle;
  Rect: TRect;
begin
  Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then
  begin
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, sizeof(buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then
      IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateToolTips(Form1.Handle);
  AddToolTip(Memo1.Handle, @ti, 1, Memo1.Lines.GetText, 'Memo Text');
end;

end.

Accept files dragged over an application

Problem/Question/Abstract:

If you have an application that works with files, you probably want that users would be able to drag and drop files over your application to open them.

Answer:

For your application be able to accept files when dropped over it, you need to tell windows that your application can accept files. To do this, you have two options:

Make use of Params.ExStyle
  
To be able to accept files without much trouble you have just to override the protected the protected procedure CreateParams and write the following:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  // Register the window to be able to accept dropped files
  Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES;
end;

Use API function DragAcceptFiles
  
The other option is use DragAcceptFiles API function. This way you can control if your application can accept dropped files or not without the need to change Params.ExStyle

Both options of activation activate the WM_DROPFILES windows message, and it's here that you'll have to process the dropped files.

The following routine gives the essential part of what you need to do:

procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
// The WM_DROPFILES message is sent when the user releases the left mouse button
//    while the cursor is in the window of an application that has registered
//    itself as a recipient of dropped files.
var
  FNumFiles: Integer;
  i: Integer;
  BufSize: Integer;
  FFilePath: array of char;
  FFileName: string;

begin
  // How many files were dropped ?
  FNumFiles := DragQueryFile(Message.Drop, $FFFFFFFF, nil, 0);
  // Process all files in the list
  for i := 0 to FNumFiles - 1 do
  begin
    // Get the buffer size to old the filename
    BufSize := DragQueryFile(Message.Drop, i, nil, 0);
    // Get filename. This filename is a null-terminated string.
    SetLength(FFilePath, BufSize + 1);
    DragQueryFile(Message.Drop, i, PChar(FFilePath), BufSize + 1);
    // Check if the dropped file extension can be accepted
    FFileName := ExtractFileName(PChar(FFilePath));

    // DO WHATEVER YOU NEED
  end;
  // The DragFinish function releases memory that Windows allocated for use in
  //    transferring filenames to the application.
  DragFinish(Message.Drop);
end;

Attached is a project sample. It's a small file text viewer and it implement's a bit more than the above, as you can see in the following screen shot.

Detect a form movement

Problem/Question/Abstract:

How to detect a form movement

Answer:

Solve 1:

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE;
    procedure WMENTERSIZEMOVE(var Message: TMessage); message WM_ENTERSIZEMOVE;

implementation

procedure TForm1.WMENTERSIZEMOVE(var Message: TMessage);
begin
  Form1.Caption := 'Starting moving and sizing';
end;

procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
  Form1.Caption := 'Finished moving and sizing';
end;


Solve 2:

Handle the WM_MOVING or WM_WINDOWPOSCHANGING message from windows, i.e.:

{ Private declarations }

procedure WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
  message WM_WINDOWPOSCHANGING;

procedure TForm1.WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
var
  r: TRect;
begin
  if ((SWP_NOMOVE or SWP_NOSIZE) and msg.WindowPos^.flags) <> (SWP_NOMOVE
    or SWP_NOSIZE) then
  begin
    { Window is moved or sized, get usable screen area }
    { Do something here }
  end;
  inherited;
end;

Copy a file using a TFileStream

Problem/Question/Abstract:

How to copy a file using a TFileStream

Answer:

{ ... }
type
  TFileCopyUpdateEvent = procedure(const SrcFile, DestFile: string;
    CurrentPos, MaxSize: Integer) of object;

function Min(Val1, Val2: Integer): Integer;
begin
  Result := Val1;
  if Val2 < Val1 then
    Result := Val2;
end;

{SrcFile and DestFile are the fully qualified filenames to the files to copy function}

MyFileCopy(SrcFile, DestFile: TFilename; OnUpdate: TFileCopyUpdateEvent = nil):
  Boolean;
const
  StreamBuf = 4096;
var
  Src, Dst: TFileStream;
  BufCount: Integer;
begin
  Src := nil;
  Dst := nil; {prevents .Free problems on exception}
  {allow everyone else any access}
  Src := TFileStream.Create(SrcFile, fmOpenRead or fmShareDenyNone);
  if FileExists(DestFile) then
    {this could cause an error if a user has the file open}
    Dst := TFileStream.Create(DestFile, fmOpenWrite or fmShareExclusive)
  else
    Dst := TFileStream.Create(DestFile, fmCreate or fmShareExclusive);
  try
    while Dst.Position < Dst.Size do
    begin
      BufCount := Min(StreamBuf, Dst.Size - Dst.Position);
      Src.CopyFrom(Dst, BufCount);
      if Assigned(OnUpdate) then {report progress every 4k}
        OnUpdate(SrcFile, DestFile, Dst.Position, Dst.Size);
    end;
  finally
    Src.Free;
    Dst.Free;
  end;
end;

Extract swf from Flash Projector (EXE)

Problem/Question/Abstract:

How to extract swf from Flash Projector

Answer:

procedure ExeToSWF(ExeFile, aSWF: string);
var
  p: pointer;
  f: file;
  sz,
    swfsize: integer;
const
  SWF_FLAG: integer = $FA123456;
begin
  if not fileexists(ExeFile) then
  begin
    messagebox(Application.Handle, pchar('File not found'), pchar('Error'),
      MB_ICONERROR);
    exit;
  end;
  assignfile(f, ExeFile);
  reset(f, 1);
  seek(f, filesize(f) - (2 * sizeof(integer)));
  blockread(f, sz, sizeof(integer));
  if sz <> swf_flag then
  begin
    messagebox(Application.Handle, pchar('Not a valid Projector Exe'), pchar('Error'),
      MB_ICONERROR);
    closefile(f);
    exit;
  end;
  blockread(f, swfsize, sizeof(integer));
  seek(f, filesize(f) - (2 * sizeof(integer)) - swfsize);
  getmem(p, swfsize);
  blockread(f, p^, swfsize);
  closefile(f);
  assignfile(f, aSWF);
  rewrite(f, 1);
  blockwrite(f, p^, swfsize);
  closefile(f);
  freemem(p, swfsize);
  messagebox(Application.Handle, pchar('SWF Extracted'), pchar('Succes'),
    MB_ICONINFORMATION);
end;

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExeToSWF('C:Desktopflash.exe', 'C:Desktopf.swf');
end;

end.

Undocumented: Delphi Visual Component Library Access License

Problem/Question/Abstract:

Undocumented: Delphi Visual Component Library Access License

Answer:

The SysUtils.pas unit contains some very interesting routines that are used by the VCL components to check if the correct version of Delphi is beeing used to compile the code (e.g. C/S components won't run if compiled with the Pro compiler).

Here are the functions:

function GDAL: LongWord;

Get Delphi Access License. Retreives the access licences resource. It checks if it is valid, if not an exception with the message 'Application is not licensed to use this feature' is raised.
The returned value is the decrypted first Access Licence (AL1).

procedure RCS;

Perform a check to see there is a Delphi Client Server licence. An exception is raised if the license is not valid.

procedure RPR;

Perform a check to see there is a Delphi Pro licence. An exception is raised if the license is not valid.

Other non exposed functions are:

function AL1(const P): LongWord;
function AL2(const P): LongWord;

These two functions return the decrypted value of the license value specified by P.

procedure ALV;

Raises an Access Licence Violation exception.

function ALR: Pointer;

Access License Resource loader. Returns a pointer to the loaded access license. An exception is raised if the resource is not found.

Convert short file names to long ones

Problem/Question/Abstract:

How do I convert a short (alias) filename or directory name into its long equivalent?

Answer:

Solve 1:

{Parameters:

shortname:
File name or path to convert. This can be a fully qualified file name or a path relative to the current directory. It can contain long and / or short forms for the names.

Returns:
Fully qualified filename using the long names for all elements of the path.

Description:
Recursively uses FindFirst to find the long names for the path elements.

Error Conditions:
Will raise an exception if any part of the path was not found.

Created:
15.01.98 14:09:26 by Peter Below}

function GetLongFilename(shortname: string): string;

  function GetL(shortname: string): string;
  var
    srec: TSearchRec;
  begin
    { Lob off the last element of the passed name. If we received only a root name,
    e.g. c:\, ExtractFileDir returns the path unchanged. }
    Result := ExtractFileDir(shortname);
    if (Result <> shortname) then
    begin
      { We still have an unconverted path element. So convert the last one in
                  the current shortname and combine the resulting long name with what we get
                        by calling ourselves recursively with the rest of the path. }
      if FindFirst(shortname, faAnyfile, srec) = 0 then
      try
        Result := GetL(Result) + '\' + srec.Name;
      finally
        FindClose(srec);
      end
      else
        raise Exception.CreateFmt('Path %s does not exist!', [shortname]);
    end
    else
      { Only the root remains. Remove the backslash since the caller will add it
                  back anyway. }
      Delete(Result, length(result), 1);
  end;

begin
  { Create fully qualified path and pass it to the converter. }
  Result := GetL(ExpandFilename(shortname));
end;


Solve 2:

{Get LFN from 8.3}

function GetLongPathName(const PathName: string): string;
var
  Drive: string;
  Path: string;
  SearchRec: TSearchRec;
begin
  if PathName = '' then
    Exit;
  Drive := ExtractFileDrive(PathName);
  Path := Copy(PathName, Length(Drive) + 1, Length(PathName));
  if (Path = '') or (Path = '\') then
  begin
    Result := PathName;
    if Result[Length(Result)] = '\' then
      Delete(Result, Length(Result), 1);
  end
  else
  begin
    Path := GetLongPathName(ExtractFileDir(PathName));
    if FindFirst(PathName, faAnyFile, SearchRec) = 0 then
    begin
      Result := Path + '\' + SearchRec.FindData.cFileName;
      FindClose(SearchRec);
    end
    else
      Result := Path + '\' + ExtractFileName(PathName);
  end;
end;


Solve 3:

You could try the following. It should work on Win95 and above.

unit WhateverYouWantToCallIt;

interface

function LongPathFromShort(const ShortPath: string): string;

implementation

uses
  Windows, SysUtils, ActiveX, ShlObj;

function LongPathFromShort(const ShortPath: string): string;
var
  iAttributes: Cardinal;
  iEaten: Cardinal;
  IntfDesktop: IShellFolder;
  IntfMalloc: IMalloc;
  pItemList: PItemIDList;
  sFile: WideString;
  szFile: array[0..MAX_PATH] of Char;
begin
  Result := ShortPath;
  if not FileExists(ShortPath) then
    Exit;
  if Succeeded(SHGetDesktopFolder(IntfDesktop)) then
  begin
    sFile := ShortPath;
    iAttributes := 0;
    if Succeeded(IntfDesktop.ParseDisplayName(0, nil, POleStr(sFile),
      iEaten, pItemList, iAttributes)) then
    begin
      SHGetPathFromIDList(pItemList, szFile);
      Result := szFile;
      SHGetMalloc(IntfMalloc);
      IntfMalloc.Free(pItemList)
    end
  end
end;

end.


Solve 4:

GetFullPathName converts a relative path to an absolute path. You can use GetLongPathName, but this requires Win98 and later or Win2k and later.

function GetLongName(const APath: string): string;
var
  Buffer: array[0..MAX_PATH] of Char;
  Required: Integer;
begin
  Required := GetLongPathName(PChar(APath), Buffer, Length(Buffer));
  if Required > MAX_PATH then {Buffer too small}
  begin
    SetLength(Result, Required - 1);
    GetLongPathName(PChar(APath), Pointer(Result), Required);
  end
  else if Required = 0 then {Error}
    Result := APath
  else
    SetString(Result, Buffer, Required);
end;

For an ANSI only function you can reduce the above to:

function GetLongName(const APath: AnsiString): AnsiString;
var
  Buffer: array[0..MAX_PATH] of AnsiChar;
  Required: Integer;
begin
  Required := GetLongPathNameA(PChar(APath), Buffer, Length(Buffer));
  SetString(Result, Buffer, Required);
end;

If you need to support for Win95 or WinNT, you can use this function:

function GetLongPathName(Path: string): string;
var
  I: Integer;
  SearchHandle: THandle;
  FindData: TWin32FindData;
  IsBackSlash: Boolean;
begin
  Path := ExpandFileName(Path);
  Result := ExtractFileDrive(Path);
  I := Length(Result);
  if Length(Path) <= I then {only drive}
    Exit;
  if Path[I + 1] = '\' then
  begin
    Result := Result + '\';
    Inc(I);
  end;
  Delete(Path, 1, I);
  repeat
    I := Pos('\', Path);
    IsBackSlash := I > 0;
    if not IsBackSlash then
      I := Length(Path) + 1;
    SearchHandle := FindFirstFile(PChar(Result + Copy(Path, 1, I - 1)), FindData);
    if SearchHandle <> INVALID_HANDLE_VALUE then
    begin
      try
        Result := Result + FindData.cFileName;
        if IsBackSlash then
          Result := Result + '\';
      finally
        Windows.FindClose(SearchHandle);
      end;
    end
    else
    begin
      Result := Result + Path;
      Break;
    end;
    Delete(Path, 1, I);
  until Length(Path) = 0;
end;