Convert hex color values into Delphi formatted ones

Problem/Question/Abstract:

Is there a routine that can take a hex color value and convert it to a Delphi formatted value like: "Cornsilk1 Cornsilk1 255 248 220 #FFF8DC" into $00DCF8FF ?

Answer:

Solve 1:

function Swap32(aLong: Longint): Longint; assembler;
asm
  BSWAP eax
end;

function HexColorToColor(HexColor: string): TColor;
{input: '#FFF8DC' -> output $DCF8FF as TColor, use IntTohex to convert output to string again if needed}
begin
  Assert((Length(hexcolor)) > 1);
  Assert(hexcolor[1] = '#');
  hexcolor[1] := '$';
  Result := Swap32(StrToInt(hexcolor));
end;


Solve 2:

The safest way to convert this is to use the following:

{ ... }
var
  r, g, b: string;
begin
  r := Copy(HexValue, 2, 2);
  g := {... same, but for the GG part}
  b := {...same, but for the BB part}
    {Finally}
  DelphiColor := RGB(STrToInt('$' + R), STrToInt('$' + G), STrToInt('$' + B));
end;

Note: You should never shift the RGB data manually as the bit order is different in various screen modes. The first two bytes you refered to as $00 is the alpha channel, or color intensity. Packages like Graphics32 that support this feature normally allows you to manipulate this directly, where $FF is normal color, while $00 is completely invisible. But all of this can be avoided by using the example above. Try it out, you will see what i mean.


Solve 3:

A HTML color string has the format #RRGGBB, the color values are coded as two digit hexadecimal numbers. Delphi's TColor is an Integer value. If the bits 24..31 = 0 then the value describes a RGB color.

RGB color:
Bit
  0.. 7: red
  8..15: green
  16..23: blue
  24..31: 0

Source code (untested):

{exchange red and blue color values}

function ByteSwapColor(Color: TColor): TColor; assembler;
asm
  BSWAP  EAX
  SHR  EAX, 8
end;

resourcestring
  SIsNotAHTMLColorValue = '%s is not a HTML color value';

procedure ConvertHTMLtoRGBColor(HTMLColor: string; var Color: TColor): Boolean;
begin
  Result := False;
  if Length(HTMLColor) <> 7 then
    Exit;
  if HTMLColor[1] <> '#' then
    Exit;
  HTMLColor[1] := '$';
  Color := StrToIntDef(HTMLColor, -1);
  Result := (0 <= Color) and (Color <= $FFFFFF);
  if Result then
    Color := ByteSwapColor(Color);
end;

function HTMLtoRGBColor(const HTMLColor: string): TColor;
begin
  if not ConvertHTMLtoRGBColor(HTMLColor, Result) then
    raise EConvertError.CreateFmt(SIsNotAHTMLColorValue, [HTMLColor]);
end;

function RGBtoHTMLColor(Color: TColor): string;
begin
  Color := RGBColor(Color);
  Color := ByteSwapColor(Color);
  Result := Format('#%.6x', [Color]);
end;

How to sort columns in a TDBGrid

Problem/Question/Abstract:

How to sort columns in a TDBGrid

Answer:

Many professional applications will display data in grid fields and allow you to sort on any one of the columns simply by clicking on the column header. Although what is proposed here is not the best way to accomplish this, it is a fairly simple way to mimic the same behavior. The key hurdle in this problem is the DBGrid itself. It has no OnClick or OnMouseDown events, so it really was not designed to capture this kind of input. It does provide an OnDoubleClick, but this really doesn't work too well. What we need is a way to make the column headers clickable. Enter the THeaderControl component. THeaderControl is a component that comes in Delphi 2.0 and provides the basic functions that we want. It can detect clicks on its individual panels, and the panels even go up and down when pressed (like a button). The key is to connect the THeaderControl to the DBGrid. Here is how it is done:

First, start a new application. Drop a THeaderControl on the form. It will automatically align to the top edge of the form. Now drop a DBGrid on the form and set its Align property to alClient. Next, add a TTable, and TDataSource component. Set the Tables DatabaseName property to DBDEMOS and its TableName to EVENTS.DB. Set the DataSource's DataSet property to point at Table1 and the DBGrid's DataSource property to point to DataSource1. Set Table's Active property to False in case it has been turned on.

Now we need to setup the THeaderControl component to look like the DBGrid's column headers. his will be done in code in the Form's FormCreate method. DoubleClick on Form1's OnCreate event and enter the following code:

procedure TForm1.FormCreate(Sender: TObject);
var
  TheCap: string;
  TheWidth, a: Integer;
begin
  DBGrid1.Options := DBGrid1.Options - [dgTitles];
  HeaderControl1.Sections.Add;
  HeaderControl1.Sections.Items[0].Width := 12;
  Table1.Exclusive := True;
  Table1.Active := True;
  for a := 1 to DBGrid1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with HeaderControl1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end;
    try
      Table1.AddIndex(TheCap, TheCap, []);
    except
      HeaderControl1.Sections.Items[a].AllowClick := False;
    end;
  end;
  Table1.Active := False;
  Table1.Exclusive := False;
  Table1.Active := True;
end;

Since the THeaderControl will be taking the place of the Grid's column headers, we first remove (set to False) the dgTitles option in the DBGrid's Options property. Then, we add a column to the HeaderControl and set its width to 12. This will be a blank column that is the same width as the Grid's status area on the left. Next we need to make sure the Table is opened for Exclusive use (no other users can be using it). I will explain why in just a bit. Now we add the HeaderControl sections. For each one we add, we will be giving it the same text as the caption of that column in the DBGrid. We loop through the DBGrid columns, and for each one we copy over the column's caption and width. We also set the HeaderControl's MinWidth and MaxWidth properties to the same as the column width. This will prevent the column from being resized. If you need resizeable columns, you will need a bit more code, and I wanted to keep this short and sweet.

Now comes the interesting part. We are going to create an index for each column in the DBGrid. The name of the index will be the same as the columns title. This step is in a try..finally structure because there are some fields that cannot be indexed (Blobs & Memos for example). When it tries to index on these fields, it will generate an exception. We catch this exception and turn off the ability to click that column. This means that non-indexed columns will not respond to mouse clicks. The creation of these indexes is why we had to open the table in Exclusive mode. After we are all done, we close the table, set Exclusive off and reopen then table. One last step. When the HeaderControl is clicked, we need to turn on the correct index for the Table. The HeaderControl's OnSectionClick method should be as follows:

procedure TForm1.HeaderControl1SectionClick(HeaderControl: THeaderControl;
  Section: THeaderSection);
begin
  Table1.IndexName := Section.Text;
end;

That's it! When the column is clicked, the Table's IndexName property is set to the same as the HeaderControl's caption. There is a lot of room for improvement however. It would be nice if clicking on a column a second time would reverse the sort order. Also, column resizing would be a nice added touch.


Improvements:

The improvement over the previous version is in the usage of the fieldname as indexname instead of the caption. This improves the flexibility.

procedure TfrmDoc.FormCreate(Sender: TObject);
var
  TheCap, TheFn: string;
  TheWidth, a: Integer;
begin
  Dbgrid1.Options := DBGrid1.Options - [DGTitles];
  Headercontrol1.sections.Add;
  Headercontrol1.Sections.Items[0].Width := 12;
  for a := 1 to DBGRID1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheFn := FieldName;
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with Headercontrol1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end;
    try
      {Use indexes with the same name as the fieldname}
      (DataSource1.Dataset as TTable).IndexName := TheFn;
      {Try to set the index name}
    except
      HeaderControl1.Sections.Items[a].AllowClick := False;
      {Index not Available}
    end;
  end;
end;

Use the fieldname property of the DBGrid to set an index with the same name as the fieldname.

procedure TfrmDoc.HeaderControl1SectionClick(HeaderControl: THeaderControl;
  Section: THeaderSection);
begin
  (DataSource1.Dataset as TTable).IndexName :=
    DBGrid1.Columns.Items[Section.Index - 1].FieldName;
end;

How to do flicker-free painting on the canvas of a TDBGrid

Problem/Question/Abstract:

Does anyone have the code for a flicker-free TDBGrid without the vertical scrollbar. Or could anyone explain how I get rid of the flicker? I thought it might be a good idea to set the DefaultDrawing property to False and handle all the drawing in the OnDrawDataCell event using an offscreen bitmap.

Answer:

Solve 1:

It would be better to allow DBGrid to still do the drawing, rather than manually replicating the code via OnDrawDataCell, but instead retro-fitting off-screen bitmap drawing into the control. This technique involves hooking the WM_Paint message, and forcing the control to paint into an off-screen bitmap, then finally BitBlt'ing the bitmap back to the screen. The code can be retro-fitted to any existing control via a simple subclass, or for those inclined by run-time subclassing of the control's WndProc. Note that if the control has sub-controls (with their own canvases), then only the control's canvas itself will be painted flicker-free.

type
  TFlickerFreeDBGrid = class(TDBGrid)
  private
    procedure WMPaint(var Message: TWMPaint); message WM_Paint;
  end;

procedure TFlickerFreeDBGrid.WMPaint(var Message: TWMPaint);
var
  WinDC, MemDC: HDC;
  Bitmap, OldBitmap: HBITMAP;
  PS: TPaintStruct;
  BegunPaint: Boolean;
begin
  BegunPaint := False;
  {Allocate a window DC, if needed}
  WinDC := Message.DC;
  if WinDC = 0 then
  begin
    WinDC := BeginPaint(Handle, PS);
    BegunPaint := True;
  end;
  {Allocate a memory DC}
  MemDC := CreateCompatibleDC(Canvas.Handle);
  Bitmap := CreateCompatibleBitmap(Canvas.Handle, Width, Height);
  OldBitmap := SelectObject(MemDC, Bitmap);
  try
    {Normal drawing, but into MemDC}
    Message.DC := MemDC;
    inherited;
    {Copy MemDC to WinDC}
    with Canvas.ClipRect do
      BitBlt(WinDC, Left, Top, Right - Left, Bottom - Top, MemDC, Left, Top, SRCCOPY);
  finally
    {Deallocate memory DC}
    SelectObject(MemDC, OldBitmap);
    DeleteObject(Bitmap);
    DeleteDC(MemDC);
    if BegunPaint then
      EndPaint(Handle, PS);
  end;
end;


Solve 2:

Another (possibly cleaner way than Answer 1) to approach this within the Delphi class framework is to override the PaintWindow method, something like this:

procedure TBufferedDBGrid.PaintWindow(DC: HDC);
var
  Bitmap: TBitmap;
begin
  if (DC <> 0) then
  begin
    {Buffered drawing occurs on an off-screen bitmap}
    Bitmap := TBitmap.Create;
    try
      {Set bitmap attributes}
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      {Set the canvas handle to the bitmap}
      Canvas.Handle := Bitmap.Canvas.Handle;
      try
        Paint;
        Canvas.Handle := DC;
        Canvas.CopyRect(ClipRect, Bitmap.Canvas, ClipRect);
      finally
        Canvas.Handle := 0;
      end;
    finally
      Bitmap.Free;
    end;
  end;
end;

A performance optimization would be to create / destroy the offscreen bitmap in the constructor / destructor, and (re)size the bitmap in an overridden SetBounds method - though keeping the bitmap around at all times will hog memory. Where the best trade off is depends on the design considerations of the application.


Solve 3:

The above code (Answer 2) is indeed a lot cleaner, and I much prefer clean high-level VCL code to my code which is low-level using the Win-API. However, there is a major difference between your cleaner code and mine. My code was written to handle flicker-free drawing of a panel that owns large TGraphicControl children (eg TLabel, TShape, which use the panel's canvas for drawing, hence major flicker). My code will paint both the panel AND its TGraphicControl children in the off-screen bitmap.

Your code, on the other hand, would only paint the panel in the bitmap, leaving the children to be drawn direct to screen as normal (in PaintHandler). This is because you intercept the PaintWindow method which is only responsible for the control's painting. not including any TGraphicControl children. I intercept the WM_Paint message directly, letting the VCL (and any future versions of it) paint the control in a completely normal fashion, but in to the bitmap.

So I've written a hybrid, taking the cleaner VCL approach you have (ie let TBitmap handle the CreateCompatibleDC etc), with my technique for also painting the children without flicker.

Note the same optimisations apply here. I actually only create a single bitmap for the whole application, resizing it larger and larger as needed. True, it can take up a lot of memory on high-colour screens, but anyone running high-colour will have more memory anyway. And there's only a single off-screen bitmap shared around all controls that need it, so I can can use the flicker-free technique wherever its useful.

procedure WMPaint(var Message: TWMPaint);
var
  Bitmap: TBitmap;
  WinDC: HDC;
  PS: TPaintStruct;
  BegunPaint: Boolean;
begin
  BegunPaint := False;
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := Width;
    Bitmap.Height := Height;
    {Paint completely as normal, but into Bitmap}
    WinDC := Message.DC;
    Message.DC := Bitmap.Canvas.Handle;
    inherited;
    {Need a Window DC ?}
    BegunPaint := WinDC = 0;
    if BegunPaint then
      WinDC := BeginPaint(Handle, PS);
    {Copy bitmap to screen}
    with Canvas.ClipRect do
      BitBlt(WinDC, Left, Top, Right - Left, Bottom - Top, Bitmap.Canvas.Handle, Left,
        Top, SRCCOPY);
  finally
    Bitmap.Free;
    if BegunPaint then
      EndPaint(Handle, PS);
  end;
end;

Crop a TBitmap or TBitmap32 automatically

Problem/Question/Abstract:

Does anybody know a component or a piece of Delphi code that performs "smart cropping" automatically, as follows. I have a lot of images with an almost white background and some drawing somewhere in the rectangle. I want to trim off the almost white margins around the drawing automatically (these margins are sometimes very different in size) in order to reduce the weight of the image, and to be able to center the drawing.

Answer:

{ ... }
type
TRGBArray = array[0..32767] of TRGBTriple; {pf24bit}
pRGBArray = ^TRGBArray;
{ ... }

function CropRect(Bitmap: TBitmap; C: TColor): TRect;
var
ScanlinePtr: PByte;
ScanlineIncrement: Integer;
LastScanline: PByte;
X: Integer;
Line: pRGBArray;
AColor: TColor;
r, g, b: Integer;
x1, x2, y1, y2, x3, x4, y3, n: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit); {must be pf24bit!}
AColor := ColorToRGB(C);
r := GetRValue(AColor);
g := GetGValue(AColor);
b := GetBValue(AColor);
X := Bitmap.Width;
ScanlinePtr := Bitmap.Scanline[0];
ScanlineIncrement := integer(Bitmap.Scanline[1]) - integer(ScanlinePtr);
LastScanline := ScanlinePtr;
Inc(LastScanLine, ScanlineIncrement * Bitmap.Height);
x1 := Bitmap.Width;
x2 := 0;
y1 := 0;
y2 := Bitmap.Height;
y3 := 0;
repeat
Line := pRGBArray(ScanLinePtr);
x3 := -1;
x4 := -1;
n := 0;
while (n < X) and (x3 < 0) do
begin
if (Line[n].rgbtRed <> r) or (Line[n].rgbtGreen <> g) or (Line[n].rgbtBlue <> b)
then
x3 := n;
Inc(n);
end;
n := X - 1;
while (n > -1) and (x4 < 0) do
begin
if (Line[n].rgbtRed <> r) or (Line[n].rgbtGreen <> g) or (Line[n].rgbtBlue <> b)
then
x4 := n;
Dec(n);
end;
if (x3 > -1) and (x3 < x1) then
x1 := x3;
if (x4 > -1) and (x4 > x2) then
x2 := x4;
if (x3 > -1) or (x4 > -1) then
begin
if y1 = 0 then
y1 := y3
else
y2 := y3;
end;
Inc(ScanlinePtr, ScanlineIncrement); {move to the next scanline}
Inc(y3);
until
(ScanlinePtr = LastScanline);
result := Rect(x1, y1, x2 + 1, y2);
if IsRectEmpty(result) then
result := Rect(0, 0, Bitmap.Width, Bitmap.Height);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
r: TRect;
begin
if Assigned(Image1.Picture) then {contains srcBmp}
begin
r := CropRect(srcBmp, FCropColor); {FCropColor is lower left pixel}
cropBmp.Width := r.Right - r.Left;
cropBmp.Height := r.Bottom - r.Top;
cropBmp.Canvas.CopyRect(Rect(0, 0, cropBmp.Width, cropBmp.Height), srcBmp.Canvas,
r);
Image2.Picture.Bitmap.Assign(cropBmp);
end;
end;

This can also be done with palette images (preferably grayscale), in which case only one component (byte) has to be compared, so faster. If you already have a thumbnail, use this one and use the result as a crude initial guess for the final calculation with complete bitmap. If the shape you're after is certain to be connected (no gaps) and concave, there are optimisations possible, like ray casting from top/bottom and left/right, finding the object, then traversing along the edge to find extremes. If you're doing any other operation on the bitmap before, like color conversion or gamma correction, you can use this very operation to already get you the crop box with limited extra effort.

Here's an alternative implementation for TBitmap32. TBitmap32 colors are really cardinals, so only one compare is neccesary per pixel. This implementation also exploits the fact that the bits (pixels) are all aligned in one long row. Another optimisation is that it skips the middle section once it has begun finding "non-white" pixels.

{ ... }
with Bitmap32 do
begin
{Initialisation}
Size := Width * Height;
First := -1;
Left := Width;
Right := -1;
Last := -1;
i := 0;
{Loop through bits, find First, Last, Left and Right}
repeat
if Bits[i] <> CropColor then
begin
if First < 0 then
{Set top row (First div Width)}
First := i;
{X position}
X := i mod Width;
if X < Left then
{Set new left border}
Left := X;
if X > Right then
{Set new right border}
Right := X
else
{Jump to the right border directly}
inc(i, Right - X);
{Set bottom row (Last div Width)}
Last := i;
end;
inc(i);
until
i >= Size;
{Resulting crop rectangle and IsEmpty flag}
CropRect := Rect(Left, First div Width, Right + 1, Last div Width + 1);
IsEmpty := First = -1;
end;

How to save and load printer settings to/from the registry

Problem/Question/Abstract:

I'm trying to get Windows to remember settings - in particular paper type, size and orientation - configured using the Printer Setup dialogue. It's confusing me. It seems that sometimes Windows remembers these settings and sometimes not. The technique I'm considering is to read and save (to an INI file or wherever) the Printer.PageHeight, PageWidth etc. values for the particular printer concerned, so they're available to be loaded for subsequent sessions. What better solutions would people suggest? I can't find a way to get the name of the currently selected paper layout (e.g. Letter, Legal, etc.). It's not among the properties of TPrinter. Anyone have a way to get / set this? I'm working with D5 pro (D6 soon), developing in Win2K, deploying to various flavours from Win'9X to XP.

Answer:

Solve 1:

Windows remembers only changes made to the default settings, using the printer icon in the control panels printers applet. A solution for you would be to save the printers devicemode record, the public part at least:


uses
  printers, registry;

{$R *.dfm}

procedure SaveCurrentPrinterSettings(reg: TRegistry);
var
  Device, Driver, Port: array[0..80] of Char;
  DevMode: THandle;
  pDevmode: PDeviceMode;
begin
  Printer.GetPrinter(Device, Driver, Port, DevMode);
  if Devmode <> 0 then
  begin
    {lock it to get pointer to DEVMODE record}
    pDevMode := GlobalLock(Devmode);
    if pDevmode <> nil then
    try
      reg.WriteBinaryData(device, pDevmode^, sizeof(TDevicemode));
    finally
      {unlock devmode handle.}
      GlobalUnlock(Devmode);
    end;
  end;
end;

procedure LoadCurrentPrinterSettings(reg: TRegistry);
var
  Device, Driver, Port: array[0..80] of Char;
  DevMode: THandle;
  pDevmode: PDeviceMode;
begin
  Printer.GetPrinter(Device, Driver, Port, DevMode);
  if Devmode <> 0 then
  begin
    {lock it to get pointer to DEVMODE record}
    pDevMode := GlobalLock(Devmode);
    if pDevmode <> nil then
    try
      reg.ReadBinaryData(device, pDevmode^, sizeof(TDevicemode));
    finally
      {unlock devmode handle.}
      GlobalUnlock(Devmode);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if reg.OpenKey('Software\PB\Test', true) then
    try
      SaveCurrentPrinterSettings(reg);
    finally
      reg.CloseKey;
    end
  finally
    reg.free
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create(KEY_READ);
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if reg.OpenKey('Software\PB\Test', false) then
    try
      LoadCurrentPrinterSettings(reg);
    finally
      reg.CloseKey;
    end
  finally
    reg.free
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  printdialog1.execute
end;


Solve 2:

Check out the Delphi Win API help for GetPrinter, PRINTER_INFO_2, and DEVMODE. I use the following code to read the current info for the printer. I'm attempting to find some code to set the values, but I'm having problems with user rights in Win2000 Pro. Use the Delphi select printer dialog to set the current printer, otherwise the code will display the settings of the default printer if one is set.


function GetPrinterName: string;
var
  prnIndex: Integer;
  prnList: TStrings;
begin
  result := '';
  prnIndex := Printers.Printer.PrinterIndex;
  prnList := Printers.Printer.Printers;
  if (prnIndex > -1) and (prnIndex < prnList.Count) then
  begin
    if (prnList.Objects[prnIndex] <> nil) then
      result := TPrinterDevice(prnList.Objects[prnIndex]).Device
    else
      result := prnList[prnIndex];
  end;
end;

procedure ShowPrinterInfo;
const
  LEVEL_2 = 2;
var
  printerHandle: THandle;
  printerInfo: TPrinterInfo2;
  bytesNeeded: Cardinal;
  printerDefaults: TPrinterDefaults;
  prnName: string;
  pBuffer: Pointer;
  gpResult: Boolean;
  devInfo: TDevMode;
  sMsg: string;
begin
  printerHandle := 0;
  ClearRecord(printerInfo, SizeOf(TPrinterInfo2));
  ClearRecord(printerDefaults, SizeOf(TPrinterDefaults));
  prnName := GetPrinterName;
  if not OpenPrinter(PChar(prnName), printerHandle, @printerDefaults) then
    Exit;
  try
    gpResult := WinSpool.GetPrinter(printerHandle, LEVEL_2, @printerInfo,
      SizeOf(printerInfo), @bytesNeeded);
    if not gpResult and (bytesNeeded > SizeOf(PrinterInfo)) then
      {get printer call failed because buffer passed was too small}
    begin
      GetMem(pBuffer, bytesNeeded); {allocate buffer of needed size}
      try
        {protect buffer memory allocate}
        gpResult := WinSpool.GetPrinter(PrinterHandle, LEVEL_2, pBuffer,
          bytesNeeded, @bytesNeeded);
        {call GetPrinter() again with new, bigger buffer}
        if gpResult then
          {success second time}
          printerInfo := PPrinterInfo2(pBuffer)^;
            {1st bytes are info record, copy values}
      finally
        FreeMem(pBuffer); {deallocate buffer}
      end;
    end;
    if gpResult then
    begin
      sMsg := '';
      devInfo := printerInfo.pDevMode^;
      if ((DM_PAPERSIZE and devInfo.dmFields) > 0) then
        sMsg := 'Paper Size: ' + PaperSizeToStr(devInfo.dmPaperSize) + #13;
      if ((DM_PAPERLENGTH and devInfo.dmFields) > 0) then
        sMsg := sMsg + 'Paper Length: ' + IntToStr(devInfo.dmPaperLength) + #13;
      if ((DM_PAPERWIDTH and devInfo.dmFields) > 0) then
        sMsg := sMsg + 'Paper Width: ' + IntToStr(devInfo.dmPaperWidth) + #13;
      ShowMessage(sMsg);
    end;
  finally
    ClosePrinter(printerHandle);
  end;
end;

Make the scrollbar of a TStringGrid show a proportional thumb

Problem/Question/Abstract:

How to make the scrollbar of a TStringGrid show a proportional thumb

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  info: TScrollInfo;
begin
  fillchar(info, sizeof(info), 0);
  with info do
  begin
    cbsize := sizeof(info);
    fmask := SIF_ALL;
    GetScrollInfo(stringgrid1.handle, SB_VERT, info);
    fmask := fmask or SIF_PAGE;
    nPage := 5 * (nmax - nmin) div stringgrid1.rowcount;
    {whatever number of cells you consider a "page"}
  end;
  setscrollinfo(stringgrid1.handle, SB_VERT, info, True);
end;

TClientDataset as memory dataset

Problem/Question/Abstract:

How to use TClientDataset as memory dataset

Answer:

As you know starting from Delphi 3, Borland included TClientDataset component as a database-independent engine.

Generally this component is used for multi-tier environments when you transfer from server application to client application your data (using TProvider).

But today I want to show how to use standard TClientDataset component for memory-dataset without any multi-tiered application.

On any archive you may find some third-party memory datasets:

TRxMemoryData from freeware RxLib/JVCL (I must say that only TMemoryTable from RX depends from BDE. TRxMemoryData don't use BDE)
DevExpress MemData
KbmMemTable

and a lot of another components

Also some from you use third-party database engines (Apollo/DBISAM/Halcyon/...) in mode when you don't need a real database. Exists a lot of task when real database is not required. All what you need is some temporary dataset.

So I want to show how to use TClientDataset in such mode on small sample.
1. you must create a TClientDataset instance. You may do it in design-time (simply drop a component on form) or in run-time (for example, in OnCreate event of your form):
table := TClientDataset.Create(Application);

2. you must add the field defintions:

table.FieldDefs.Add('ID', ftInteger, 0, False);
table.FieldDefs.Add('Status', ftString, 10, False);
table.FieldDefs.Add('Created', ftDate, 0, False);
table.FieldDefs.Add('Volume', ftFloat, 0, False);

3. create a dataset with specified structure:

table.CreateDataset

4. open a dataset

table.Open

5. it's all! Now you may add/edit/delete records, change an order (sort) and any another action that is available for any dataset.

For example, to add random values to records:

for i := 1 to 100 do
begin
  table.Append;
  table.FieldByName('ID').AsInteger := i;
  table.FieldByName('Status').AsString := 'Code' + IntToStr(i);
  table.FieldByName('Created').AsDateTime := Date();
  table.FieldByName('Volume').AsFloat := Random(10000);
  table.Post;
end;

6. if you want to change an order for records, simply change IndexFieldNames property. For example, next command will sort your memory dataset by Created field:

table.IndexFieldNames := 'Created';

7. note that TClientDataset also allow to save memory dataset to file and load from file:

table.SaveToFile('c:\mem.cds');
table.LoadFromFile('c:\mem.cds');

A few file formats are supported - internal cds-format and xml-format

Of course, you may use SMImport suite for save/load too - it will work with such memory dataset without any problems. So you may expand your application and load data from MS Excel-spreadsheet or MS Access database, for example.

So in such manner you may transfer your data between applications/computers, update record etc

As example, you may use xml-file instead ini-file and store there any number of items without limitations on size/value types etc. Just load it to TClientDataset and navigate thru stored options as thru dataset.

PS: of course, you may also display such memory dataset in DBGrid or print it using any report engine.

Load TWebBrowser's document content from stream or string

Problem/Question/Abstract:

I hate to face the fact that TWebBrowser does not come with Lines property and LoadFromStream/LoadFromFile method as we all familiar working with TMemo. To create temporary file and then call Navigate/Navigate2 method seems quite awful way.

Answer:

Here I want to show you how to reverse what was done by TWebBrowser.Document's IPersistStreamInit implementation in my previous article "Saving raw HTML source from TWebBrowser to disk". Beside Save() method, it also has Load() method. As you might guess from the method name, the later allows you to load the content from any object that implements IStream.

Here's how to do it:

procedure LoadDocFromStream(WB: TWebBrowser; Stream: TStream);
var
  PersistStreamInit: IPersistStreamInit;
  StreamIntf: IStream;
  StreamAdapter: TStreamAdapter;
begin
  PersistStreamInit := WB as IPersistStreamInit;
  StreamAdapter := TStreamAdapter.Create(Stream);
  StreamIntf := StreamAdapter as IStream;
  PersistStreamInit.Load(StreamIntf);
end;

After knowing which doing what from each statement above, now it is the time to reduce your typing task :)

procedure LoadDocFromStream(WB: TWebBrowser; Stream: TStream);
begin
  (WB.Document as IPersistStreamInit).Load(
    TStreamAdapter.Create(Stream, soReference));
end;

That's all the way to do it. Quite simple eh? If you have a string variable holds your HTML content, simply create TStringStream from it and pass it to second function parameter.

But wait, there's another way to work with string source! For you JavaScript guys whom play often with IE DOM should familiar with this script code:

<script language="JavaScript">
<!--
document.write("<HTML><BODY><H2>Hello World!</H2>/BODY></HTML>");
document.close();
//-->
</script>

Yes, that can be done with Delphi and TWebBrowser too. The main difference is the type of involved object. The first method is using TWebBrowser.Document's IPersistStreamInit implementation (IPersistStreamInit is IPersistStream descendant which is actually exposes Save() and Load() methods). The second is using its IHTMLDocument2 implementation method.

Here's how to do it:

procedure LoadDocFromString(WB: TWebBrowser; const HTMLString: string);
var
  v: OleVariant;
  HTMLDocument: IHTMLDocument2;
begin
  HTMLDocument := WB.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := HTMLString;
  HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
  HTMLDocument.Close;
end;

Remember to put ActiveX and MSHTML units to your uses clause (IHTMLDocument2 is declared inside the later unit). If your Delphi version does not come with it, you'll need to import "Microsoft HTML Object Library" from your Delphi IDE or use command line tool $(DELPHI)\bin\tlibimp.exe. In this case, you'll get MSHTML_TLB.pas.

There is a preliminary condition should be met though. All methods above will fail if WebBrowser does not contain valid document. You must load initial document (call it "dummy document") for the first time before using the functions above. I love to hear if anyone knows how to assign a dummy document better than my workaround below. Here's the snippet code:

if not Assigned(WebBrowser.Document) then
  LoadBlankDocAndWaitUntilDocLoaded;
LoadContentFromStringOrStream;

Finally to include the document validity checking, I rewrote all those above and make the final 'ready to use' code:

procedure LoadBlankDoc(WB: TWebBrowser);
begin
  WB.Navigate('about:blank', EmptyParam, EmptyParam, EmptyParam, EmptyParam);
  while WB.ReadyState <> READYSTATE_COMPLETE do
  begin
    Application.ProcessMessages;
    Sleep(0);
  end;
end;

procedure CheckDocReady(WB: TWebBrowser);
begin
  if not Assigned(WB.Document) then
    LoadBlankDoc(WB);
end;

procedure LoadDocFromStream(WB: TWebBrowser; Stream: TStream);
begin
  CheckDocReady(WB);
  (WB.Document as IPersistStreamInit).Load(TStreamAdapter.Create(Stream));
end;

procedure LoadDocFromString(WB: TWebBrowser; const HTMLString: string);
var
  v: OleVariant;
  HTMLDocument: IHTMLDocument2;
begin
  CheckDocReady(WB);
  HTMLDocument := WB.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := HTMLString;
  HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
  HTMLDocument.Close;
end;

I have used this method but the images dont appear to load in the html document that is displayed, I think you might need to specify the base location for the file, is there a way of doing this on the fly without have to manually code this into the html document passed to the twebbroswer??

The problem was that the browser failed to know where the document was saved so it couldnt find the images specified in the html code. The way to tell the browser where the original file resided is to insert the tag into the head section, I didnt find a way of making this possible until today using an html parser written by Przemyslaw Jankowski, which I found on http://vclcomponents.com , using this freeware unit I was able to write the following procedures/functions to accomplish the task.

function AdjustFile(HTMLDoc, SpecifiedFolder: string): string;
var
  p: THtmlParser;
  t: TTag;
begin
  p := THtmlParser.Create;
  try
    p.Text := HTMLDoc;
    p.GotoBeginning;
    while p.NextTag do
      if LowerCase(p.Tag.Name) = '/head' then
      begin
        t := TTag.Create;
        t.Name := 'BASE';
        t.Params.Add('HREF="' + SpecifiedFolder + '"');
        p.InsertTag(t);
        p.InsertText(#13#10);
        t.Free;
        Break;
      end;
    Result := p.Text;
  finally
    p.Free;
  end;
end;

procedure LoadDocFromString(WB: TWebBrowser; HTMLString, SpecifiedFolder: string);
var
  v: OleVariant;
  HTMLDocument: IHTMLDocument2;
begin
  CheckDocReady(WB);
  HTMLDocument := WB.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := AdjustFile(HTMLString, SpecifiedFolder);
  HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
  HTMLDocument.Close;
end;

SpecifiedFolder is something like:- c:\saved work\html\version 5
ofcourse the above code does not check for the existence of a base tag already or what to do if no head section exists.


Component Download: LoadWBContent.zip

Create a run-time invisible ActiveX Control

Problem/Question/Abstract:

How to create a run-time invisible ActiveX Control.

Answer:

Every so often there is a need for a control that can be placed on a form, manipulate it&#8217;s properties and run the form; then, gasp, the control is invisible to the user!  A common example of this is Visual Basic&#8217;s Timer control.  You set the interval, set enabled to true, and do something in the OnTime event and you are working.  All completely transparent to the user.   Delphi examples of this are the Delphi Timer and the ImageList controls.

As stated, this can be done for an ActiveX control running on a Visual Basic or VBA form.  In design time you see the control, in run-time you don&#8217;t.  So how is it done?

At the bottom of every ActiveForm with an Automation object is an Initialization section.  The default one created by Delphi looks like this:

initialization
  TActiveFormFactory.Create(
    ComServer,
    TActiveFormControl,
    TActiveFormX,
    Class_ActiveFormX,
    1,
    '',
    OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
    tmApartment);

The seventh field is MiscStatus, this tells the container about the controls default behavior and how to treat it, and this is the field we want to change.

The flag we need is OLEMISC_INVISIBLEATRUNTIME.  You add it to the field with an OR.  The end result follows:

TActiveFormFactory.Create(
  ComServer,
  TActiveFormControl,
  TActiveFormX,
  Class_ActiveFormX,
  1,
  '',
  OLEMISC_INVISIBLEATRUNTIME or OLEMISC_ACTSLIKELABEL,
  tmApartment);

You may notice that I replaced the OLEMISC_SIMPLEFRAME with OLEMISC_INVISIBLEATRUNTIME.  OLEMISC_SIMPLEFRAME mean that this control can hold other controls inside of it, acting like a container.  Most of the time this is not what you want for an invisible control.  

After you have made the change, compile the project and through it on a form.  The control will display the same behavior on a Visual Basic form, Microsoft Word document, Excel spreadsheet, VBA form, and even on a Delphi Form.

There is a separate issue here that also comes up, and that is sizing.  How do you get the control to come up at the correct size (say 32 by 32) and stay that size.

This has to be done in the constructor (setting the contstraints in this case will not work, since 32 by 32 is smaller than Delphi will allow you to size a form).

So in your constructor add code similar to this:

Self.Width := 32;
Self.Height := 32;

Self.Constraints.MaxWidth := 32;
Self.Constraints.MaxHeight := 32;
Self.Constraints.MinWidth := 32;
Self.Constraints.MinHeight := 32;

The New Virtual List Box in Delphi 6

Problem/Question/Abstract:

What are the new virtual styles in the TListbox for, and whay are they important?

Answer:

One of the new features in Delphi 6 is the addition of styles lbVirtual and lbVirtualOwnerDraw to the standard TListBox. In all the Delphi 6 &#8220;What&#8217;s new&#8221; articles I&#8217;ve read this addition has received no more than a passing mention.

Why are Virtual List boxes important?

Have you ever been frustrated by the limitations of the TStrings' objects property or have had a need to create a custom display string in the list. Sure, you can assign any pointer you want to the object field of a string list but what if you already have a list container (like a Tlist) full of data. Why should you be forced to duplicate this data over to the TStrings associated with the TListBox. You should be able to just use it. Well, with a virtual list box you can.

During the past week I ran into a situation where I had a TInterfaceList and wanted to use the value returned from one of the Interface's functions as the text of the list item. Under Delphi 5 this required that I step down through the TInterfaceList calling the required interface method at each step to add the strings to the TListBox. Then I would need to synchronize any movement and selection in the list box with the TInterfaceList. Under Delphi 6, using a virtual list box, I was able merge my TInterfaceList and the TListbox into one highly usable pseudo object. That is, I was able to make the TListBox &#8220;aware&#8221; of the TInterfaceList directly.

(BTW, my original thought was to not use the TInterfaceList at all and just place the references to the Interface into the object field of the TStrings member of the list box.. As you all probably know, this was a bad idea since it totally screws the reference counting on the interface.)

Anyway I will not go into great detail about setting up a virtual list box since the Delphi help is pretty good on this. Basically you need to set the style to one of the 2 virtual styles, set the list box&#8217;s count to the number of items in the list and then fill in at few as one and as many as 3 events.

Here is a trivial sample that may help to fill in some blanks left by the lack of sample code in the help file.

I only wish that Borland could have also added this feature the other list controls like the comboboxes and the treeview.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Edit1: TEdit;
    lblColor: TLabel;
    lblNumber: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ListBox1Data(Control: TWinControl; Index: Integer;
      var Data: string);
    function ListBox1DataFind(Control: TWinControl;
      FindString: string): Integer;
    procedure ListBox1DataObject(Control: TWinControl; Index: Integer;
      var DataObject: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    ObjList: TList;
  end;

  TMyObj = class
    fColor: string;
    fNumber: Integer;
    constructor create(const color: string; const Number: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMyObj }

constructor TMyObj.create(const color: string; const Number: Integer);
begin
  fColor := color;
  fNumber := number;
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  // create a TList and add some data to it.
  ObjList := TList.Create;
  ObjList.Add(TMyObj.Create('Red', 1));
  ObjList.Add(TMyObj.Create('Yellow', 15));
  ObjList.Add(TMyObj.Create('Blue', 21));
  ObjList.Add(TMyObj.Create('Green', 37));
  ObjList.Add(TMyObj.Create('Brown', 16));
  ObjList.Add(TMyObj.Create('Black', 5135));
  ObjList.Add(TMyObj.Create('White', 4));
  ObjList.Add(TMyObj.Create('Orange', 333));
  // ABSOLUTELY REQUIRED Set the count of the virtual listbox
  Listbox1.Count := ObjList.Count;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to ObjList.count - 1 do
    TMyObj(ObjList.Items[I]).free;
  ObjList.Free;
end;

procedure TForm1.ListBox1Data(Control: TWinControl; Index: Integer;
  var Data: string);
// REQUIRED
// return a string to put in the list box
begin
  Data := TMyObj(ObjList.Items[Index]).fColor;
end;

procedure TForm1.ListBox1DataObject(Control: TWinControl; Index: Integer;
  var DataObject: TObject);
// USUALLY REQUIRED
// return an object associated with the current selection of the list box
begin
  DataObject := ObjList.Items[Index];
end;

function TForm1.ListBox1DataFind(Control: TWinControl;
  FindString: string): Integer;
// USUALLY REQUIRED
// given a string FindString, return its index
var
  I: Integer;
begin
  // the simplest but most brain dead approach
  result := -1;
  for I := 0 to TListBox(Control).Count - 1 do
    if TListBox(Control).Items[I] = FindString then
      result := I;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.ItemIndex := ListBox1.Items.IndexOf(edit1.Text);
  // I don't think this next should be necessary but..
  ListBox1Click(Self);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  lblColor.Caption := TMyObj(ListBox1.Items.objects[Listbox1.ItemIndex]).fColor;
  lblNumber.Caption :=
    IntToStr(TMyObj(ListBox1.Items.objects[Listbox1.ItemIndex]).fNumber);
end;

end.

SQL-DMO part 1: The SQL-DMO API

Problem/Question/Abstract:

This is the first part of a serie of articles about the SQL Distributed Management Objects known as SQL-DMO API. In this first article I'll talk about SQL-DMO, whats the purpose of it and what you'll gain if you use it.
I will also show how to install it, so you can use it within our Delphi projects.

Answer:

Some notes

Parts of the following two topics were copied from Microsoft SQL Server Books Online (BOL), because they are already very descriptive, and I would not write it better.

What is SQL-DMO?

From the Microsoft SQL Server Books Online:

SQL Distributed Management Objects (SQL-DMO) encapsulate the objects found in Microsoft&reg; SQL Server&#8482; 2000 databases. SQL-DMO allows applications written in languages that support Automation or COM to administer all parts of a SQL Server installation. SQL-DMO is the application programming interface (API) used by SQL Server Enterprise Manager in SQL Server 2000; therefore, applications using
SQL-DMO can perform all functions performed by SQL Server Enterprise Manager.

SQL-DMO is intended for any Automation or COM application that must incorporate SQL Server administration, for example:
Applications that encapsulate SQL Server as their data store and want to shield users from as much SQL Server administration as possible.
Applications that have specialized administrative logic incorporated the application itself.
Applications that want to integrate SQL Server administrative tasks in their sown user interface.

All SQL-DMO documentation is available upon the installation of SQL Server within Microsoft Books Online (BOL), and many samples are available under the \Program Files\Microsoft SQL Server\80\Tools\DevTools\Samples\sqldmo directory.

If you use Microsoft SQL Server Desktop Engine (MSDE), you can see that you don't have the necessary administrative tools. SQL-DMO is a option to create a managment tool for MSDE. Of course that there are around several tools to do that (including Microsoft SQL Server Enterprise Manager), but it's not a bad option we build our own administrative tool, because it's always a good way to learn some more!

SQL-DMO availability

SQL-DMO uses the Microsoft&reg; SQL Server&#8482; ODBC driver to connect to and communicate with instances of SQL Server. Stored procedures supporting SQL-DMO are installed on each instance of SQL Server.

SQL-DMO clients require one of these operating systems:
Microsoft Windows NT&reg; version 4.0 (Service Pack 5 or later).
Microsoft Windows&reg; 98 or Microsoft Windows&reg; 95.
Or
Microsoft Windows&reg; 2000.

SQL-DMO clients require SQL Server ODBC Driver, version 3.80 or later, which ships with SQL Server 2000. The client network library must be properly configured.

SQL-DMO locates instances of SQL Server using the SQL Server instance name.
SQL-DMO does not use ODBC data source definitions for connection, and you need not use the ODBC Administrator to create data source definitions for servers administered by SQL-DMO applications.

Stored procedures that support SQL-DMO are created as part of an instance of SQL Server 2000. The Transact-SQL script Sqldmo.sql is shipped with SQL Server 2000 and can be used to reinstall the required stored procedures if necessary.

All required SQL-DMO components are installed as part of an instance of Microsoft&reg; SQL Server&#8482; server or client. SQL-DMO is implemented in a single dynamic-link library (DLL). You may develop SQL-DMO applications on either a client or a server. When using an OLE Automation controller as a development platform, such as Delphi, no additional files are required. You can also use the SQL-DMO header files, but they need to be translate to Delphi first.

I don't see an obvious advantage about using the SQL-DMO header files, and seems to me that it's much easier just use OLE automation.

SQL-DMO sample applications, providing additional reference material for SQL-DMO application development, are included with SQL Server.

To register the SQL-DMO components on a client computer
From C:\Program Files\Microsoft SQL Server \80\Tools\Binn\Resources\<language> directory, execute:
\Program Files\Microsoft SQL Server \80\Tools\Binn\REGSVR32 SQLDMO.DLL
From any directory, execute:
C:\Program Files\Microsoft SQL Server \80\Tools\Binn\REGSVR32.EXE

C:\Program Files\Microsoft SQL Server \80\Tools\Binn\resources\1033\SQLDMO.RLL

Delphi instalation

Because you'll be using SQL-DMO with OLE automation, you need to import a type library for it.

This is done by using the 'Import Type Library' function under the 'Project' menu.
Then select the 'Microsoft SQLDMO Object Library (Version 8.0)' for SQL Server 2000 and install it as VCL Components or just create the interface units. Just choose the option you prefer. Personnaly I prefer just creating the unit and don't install it in the VCL palette.

This will create a unit of about 2.5Mb (about 65k lines) taking several minutes (about 6 minutes in a PII 400Mhz) to create it.

Interfaces versus wrapper classes

The beauty of wrapper classes generated by Delphi is that they are easy to use like a regular VCL component or class.
Normally a wrapper class joins the main interface and a event sink interface (if it's available). While the main interface has the main properties and methods, the event sink interface gives us the events part.
So instead of having to work with separated interfaces, we have both options wrapped together in a class.

Nevertheless, a problem arises. After doing some research I concluded that it's better not to use the wrapper classes generated by Delphi. Why this?
The problem, is that several functions I checked were incorrect. In some cases was code that was missing, in other cases was the existence of incorrect code.
The best option now passes by using the interfaces directly, or then do a complete verification (probably rewrite) to the imported type library so it could be correct.
Anyway, I doubt that anyone out there has the patience to verify 65k lines of code.

This is not a big problem. The direct use of interfaces it's not difficult and it's really straight forward. The problem here concentrates now in the use of the event sink interfaces.
To solve this problem, and after reading this article I decided by using this utility that generates classes for the event sink interfaces.
In the article you can read that the objective of these classes is to give the same functionality that Visual Basic WithEvents keyword gives.

You end up by having a SQLDMO_TLB.pas generated by Delphi and a SQLDMOEvents.pas generated by EventSinkImp. Both units are included in the samples package. Just remember that these units are for use with MSSQL 2000.

The first sample - "The login dialog"

Great part of the samples I will provide in the several parts of this article are based on the samples provided with SQL Server DevTools located in the \Program Files\Microsoft SQL Server\80\Tools\DevTools\Samples\sqldmo directory.

Because in every sample I will provide we need a connection to the server, it's logical that the first sample should be the connection creation and validation.

This is a generic login dialog to create a connection to a database server using SQL-DMO API. Basically, it shows a list of available servers and asks the user to input the connection parameters. If the connection it's established it returns a connection handle to be used in the process.

Personnaly I like the login dialog used by the Query Analyser, because it provides a simple but complete way of connecting to a SQL Server. This login dialog gives you the option to connect to a SQL Server using windows or SQL Server autenthication, and you can choose between a listed SQL Server or specify one.


The login dialog has two major functions:

the function where we'll get the available servers

procedure TfrmLogin.GetAvailableSQLServers(aStrings: TStrings);
var
  lServers: NameList;
  i: Integer;

begin
  // Clear servers list
  aStrings.Clear;

  // Obtain servers list
  lServers := FSQLServerApp.ListAvailableSQLServers;
  for i := 1 to lServers.Count do
    aStrings.Add(lServers.Item(i));
end;

this function will use the FSQLServerApp interface function ListAvailableSQLServers that returns a name list containing all active SQL Servers. Tests I've made seems to garantie that this function doesn't really on registered SQL Servers, so it's just what we really need.
After getting the available SQL Servers, you only need to save their names, in this case in a string list for posterior use.

One important note is that SQL-DMO colecctions have start index 1 and not 0.

the function where we'll connect to the specified SQL Server

procedure TfrmLogin.btnOKClick(Sender: TObject);
begin
  FSQLServer.LoginTimeout := -1; // -1 is the ODBC default (60) seconds
  FSQLServer.ApplicationName := Forms.Application.Name;
  FSQLServer.LoginSecure := rbWindows.Checked;
  FSQLServer.AutoReConnect := False; // Do not reconnect automatically

  // Connect to the Server
  FSQLServer.Connect(cbServers.Text, edtLogin.Text, edtPassword.Text);
end;

FSQLServer.ApplicationName setting has the purpose of helping to identify our application within SQL Server processes enumeration.
another thing is that we don't need to have two diferent connection statements because when FSQLServer.LoginSecure is specified, the login and password are ignored in the FSQLServer.Connect.

After a successful connection, we have a valid FSQLServer handle available for all operations we need. This way, it's useful to have a public property making this interface available for operations within our application.

Regularly we need to know if the connection is available, and we do this verification by using the FSQLServer.VerifyConnection(SQLDMOConn_CurrentState). Due to the high usage of this function I preferred to encapsulate this function in another public property:

property Connected: Boolean read GetConnected;

function TfrmLogin.GetConnected: Boolean;
begin
  Result := FSQLServer.VerifyConnection(SQLDMOConn_CurrentState);
end;

Now, we can used it like this:

if frmLogin.Connected then
  DoSomething;

"Events"

SQL Server sends messages, warnings and errors in the form of events. If some of them we don't need or care, others are very important to us.
For the purpose of having a generic way of catching all the events sent by SQL Server I prefer to do a generic form (created in the login form) that will catch the events for all the connected interfaces.

The events form is very simple having just one memo where the events will be written and the available sink objects.

The creation of this form is made in the login form creation

procedure TfrmLogin.FormCreate(Sender: TObject);
begin
  // Create an instance of the SQL-DMO Application and SQLServer interfaces
  FSQLServerApp := CoApplication.Create;
  FSQLServer := CoSQLServer.Create;

  // Events form
  FEventsForm := TfrmEvents.Create(self);
  FEventsForm.ServerSink.Connect(FSQLServer);
end;

being the FSQLServer interface attached to the ServerSink object.

This way we have a form

that will provide a central point for event analysis.

Conclusion

In the first part of this article you learn:
what SQL-DMO is
what are it's advantages
and how to use it
how to connect to SQL Server
how to use the messages sent by SQL Server using the events sink interfaces wrapped as simple objects

all this groupped in two generic units that will be used on following samples.

In the second part of this article I'll show how to backup databases using SQL-DMO and also use events to show backup progress.

You can download the code referent to this article here.

System and User Locale vs. System and User UI Language

Problem/Question/Abstract:

This sorts out the business of Language IDs and UI Language IDs. Why they are different and how to access them.

Answer:

I became quite confused (easy for me) on the subject of Language ID&#8217;s. It turns out, that what I failed to realize is that there is really two, potentially different, languages IDs on a system. Sure, I knew that there is both a default &#8220;system&#8221; ID and a &#8220;user&#8221; ID for each defined user on the system but what I didn&#8217;t know, was that there is also a system and user UI Language ID.

Windows 32 bit operating systems have a System Locale, which can be retrieved with GetSystemDefaultLangID. System This ID determines which bitmap fonts, and OEM, ANSI and MAC code pages are defaults for the system.

Complementing the system locale default is the user locale default that determines which settings are used for dates, times, currency, numbers, and sort order as a default for each user. The GetUserDefaultLangID retrieves the default value for the current user.

Threads can also have a default locale. New threads default to the default user locale but can be changed with SetThreadLocale and retrieved with GetThreadLocale. The thread locale determines which settings are used for formatting dates, times, currency, numbers, and sort order for the thread.

Eventually, I realized that there is also separate default User Interface (UI) language IDs. These determine the language of menus, dialogs, messages, INF files and help files. The System UI Language is retrieved using GetSystemDefaultUILanguage, while the user UI language is retrieved using GetUseDefaultUILanguage.

Once I finally came to terms with this, not so subtle, distinction between &#8220;locals&#8221; and &#8220;UI languages&#8221; I realized that what I needed was the user UI language ID unfortunately none of my copies of Delphi (including Delphi 6) support either GetSystemDefaultUILanguage or GetUseDefaultUILanguage. Even worse, these are relatively new API calls and only first appeared with Windows ME and 2000.

Here is a GetUseDefaultUILanguage I pieced together from various MSDN documents, samples, and factoids. This was written with Delphi 6 and supports OSs from Win95 on up. I&#8217;ve only tested it on Windows 2000 so please let me know if it hiccups on Win9x and NT.

Send comments to alecb@o2a.com.

// Helper

function HrFromWin32(dwErr: DWord): HResult;
begin
  result := HResultFromWin32(dwErr);
end;

// Helper

function HrFromLastWin32Error: HResult;
var
  dw: DWord;
begin
  dw := GetLastError;
  if dw = 0 then
    result := E_Fail
  else
    result := HrFromWin32(dw);
end;

// Helper

function MAKELANGID(p, s: word): word;
begin
  result := (s shl 10) or p;
end;

// The good stuff

function GetUserDefaultUILanguage: LANGID;
type
  TGetLang = function: LangID;
  THandle = Integer;
var
  GetLang: TGetLang;
  wUILang: LANGID;
  Osv: OSVERSIONINFO;
  Reg: TRegistry;
  Handle: THandle;
begin
  wUILang := 0;
  Osv.dwOSVersionInfoSize := sizeof(Osv);

  if not GetVersionEx(Osv) then
  begin
    OleError(HrFromLastWin32Error);
  end
    // Get the UI language by one of three methods, depending on OS
  else if Osv.dwPlatformId <> VER_PLATFORM_WIN32_NT then
  begin
    // Case 1: Running on Windows 9x. Get the system UI language from registry:
    Reg := TRegistry.Create;
    try
      Reg.RootKey := HKEY_USERS;
      if Reg.OpenKey('.Default\Control Panel\desktop\ResourceLocale', False) then
      begin
        wUILang := LangID(Reg.ReadInteger(''));
        Reg.CloseKey;
      end;
    finally
      Reg.Free;
    end;
  end
  else if (Osv.dwMajorVersion >= 5.0) then
  begin
    // Case 2: Running on Windows 2000 or later. Use GetUserDefaultUILanguage
    // to find the user's prefered UI language
    Handle := LoadLibrary('kernel32.dll');
    if Handle <> 0 then
    begin
      @GetLang := GetProcAddress(Handle, 'GetUserDefaultUILanguage');
      if @GetLang <> nil then
        wUILang := GetLang;
      FreeLibrary(Handle);
    end;
  end
  else
  begin
    // Case 3: Running on Windows NT 4.0 or earlier. Get UI language
    // from locale of .default user in registry:
    // HKEY_USERS\.DEFAULT\Control Panel\International\Locale
    Reg := TRegistry.Create;
    try
      Reg.RootKey := HKEY_USERS;
      if Reg.OpenKey('.Default\Control Panel\desktop\International', False) then
      begin
        wUILang := LangID(Reg.ReadInteger('Locale'));
        Reg.CloseKey;

        // Special case these to the English UI.
        // These versions of Windows NT 4.0 were enabled only, i.e., the
        // UI was English. However, the registry setting
        // HKEY_USERS\.DEFAULT\Control Panel\International\Locale was set
        // to the respective locale for application compatibility.
        if ($0401 = wUILang) or // Arabic
        ($040D = wUILang) or // Hebrew
        ($041E = wUILang) then // Thai
        begin
          wUILang := MakeLangID(LANG_ENGLISH, SUBLANG_ENGLISH_US);
        end;

      end;
    finally
      Reg.Free;
    end;
  end;
  result := wUILang;
end;

Create and Manage dynamic Forms at Runtime using Class References

Problem/Question/Abstract:

How to dynamicaly create and manage different Forms at runtime in a global manner?

Answer:

If you need to create dynamic forms at runtime and you want to manage them in a global manner, you may have the problem that you don't know how to administrate different form classes. For this case, Delphi comes with special class types of all common objects. But before I go into details, let me create a scenario in which this article may helps you.

  "I'll create an application for my customer to let him administrate serveral kinds of data in a local database. Each data category (such as employees, articles, ...) have to been implemented in a specified form with individual edit fields and tools. I don't like to create a MDI bases application (for some reasons) but the customers should have the possibilty to create more than one form for each category (e.g. opens up to 10 forms with customer informations and 3 forms with article informations). He should refer to each form after a while, so all forms have to been non-modular > the customer can hide or minimize each form. In normal MDI application, Delphi helps you to manage the MDI childs form via the 'ActiveMDIChild' property for example, but in non MDI applications you had to manage all child forms by yourself."

To find a workable solution we had to abstract the layer in which we could manage several kinds of forms. Each Delphi form inherites from TCustomForm so our first solution is to create a method who we pass a form reference to memorize - but how to keep such references? By the way, it's also possible to create a form manually and then pass the handle direct to the management component, but we'll create a method which automatically creates each kind of form. At the end of this article we've created a VCL component called TWindowManager which makes all of the discussed stuff, but now - let's start:

function TWindowManager.CreateForm(const Form: TFormClass;
  Name: string; Show: Boolean = False): TCustomForm;
begin
  if not Form.InheritsFrom(TCustomForm) then
    raise Exception.Create('Invalid FormClass - must be a descendant
      of TCustomForm!');
      Result := TCustomForm(Form.Create(Application));
      if Name <> '' then
        Result.Name := Name;
      // insert code here, to store the reference
      if Show then
        Result.Show;
end;

Okay, but how to use it? First, we've created a normal Delphi application and added a new form called DynForm1 for example. Delphi automatically creates the following entry in the pas unit:

type
  TDynForm1 = class(TForm)
    ...
  end;

For the next step we had to refer to the new unit by included the corresponding unit name to the uses clause. To dynamically create the new form at runtime, you can call the method in a way like:

procedure TMainForm.ButtonDyn1Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm1, True);
end;

Don't marvel about the name WindowManager or TWindowManager in the source examples, I've pasted it direct from the component source I've explained earlier.

Do you notice that we have passed the formclass to the method instead of the name or anythink else? It's possible, because the parameter type of the method is TFormClass which is implemented as TFormClass = class of TForm in Delphi's Forms unit.

Now we need a solution to store the form reference:

type
  { TWindowItem }

  PWindowItem = ^TWindowItem;
  TWindowItem = packed record
    Form: Pointer;
  end;

Note:

It's also possible to use a TStringList for example and create items which holds the form handles (or references direct) but it's not a good solutions if you want to search for already existing form (names). Since Version 3 (I'm not sure exactly) Delphi comes with a special container class which gives you some more specific descendants from the TList class. You can use the TObjectList class, derive from it and overwritte the maintenance methods. In this article I use a normal record to store all informations - it's less code to write and you can easily add improved custom informations to store.

The sourcecode of the TWindowManager comes from a Delphi3 implementation I've wrote - if I've some spare time, I'll update it to the newer technology!

Our WindowManager also published a method to directly add already existing form references, so you don't need to create your forms using the CreateForm method:

function TWindowManager.Add(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := True;
  try
    New(WindowItem);
    WindowItem^.Form := Form;
    FWindowList.Add(WindowItem);
  except // wrap up
    Result := True;
  end; // try/except
end;

FWindowList is declared as FWindowList: TList to hold a list of reference records. Followed you'll see to complete sourcode of the TWindowManager - try to understand the individual methods - they are simple. The main trick is the use off class references I've mentioned earlier.

The main component

unit WindowMng;

interface

uses
  Classes, Forms, SysUtils, Windows;

type
  { TWinNotifyEvent }

  TWinNotifyEvent = procedure(Sender: TObject; Form: TCustomForm) of object;

  { TWindowItem }

    // I used a packed record to be more flexible for futher improvements
    // which may need to store additional informations.

  PWindowItem = ^TWindowItem;
  TWindowItem = packed record
    Form: Pointer;
  end;

  { TWindowManager }

  TWindowManager = class(TComponent)
  private
    { Private declarations }
    FAutoNotification: Boolean;
    FLastIndex: Integer;
    FWindowList: TList;
    FOnFormAdded: TWinNotifyEvent;
    FOnFormHandled: TNotifyEvent;
    FOnFormRemoved: TWinNotifyEvent;
  protected
    { Protected declarations }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetFormByIndex(Index: Integer): TCustomForm; virtual;
    function GetWindowItemByIndex(Index: Integer): PWindowItem; virtual;
    function GetWindowItemByForm(const Form: TCustomForm): PWindowItem; virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Add(const Form: TCustomForm): Boolean; overload;
    function Count: Integer;
    function CreateForm(const Form: TFormClass; Name: string; Show: Boolean = False):
      TCustomForm; overload;
    function CreateForm(const Form: TFormClass; Show: Boolean = False): TCustomForm;
      overload;
    function Exists(const Form: TCustomForm): Boolean;
    function Remove(const Form: TCustomForm): Boolean;
    function Restore(const Index: Integer): Boolean; overload;
    function Restore(const Form: TCustomForm): Boolean; overload;
    property Forms[Index: Integer]: TCustomForm read GetFormByIndex; default;
  published
    { Published declarations }
    property AutoNotification: Boolean read FAutoNotification write FAutoNotification;
    property OnFormAdded: TWinNotifyEvent read FOnFormAdded write FOnFormAdded;
    property OnFormHandled: TNotifyEvent read FOnFormHandled write FOnFormHandled;
    property OnFormRemoved: TWinNotifyEvent read FOnFormRemoved write FOnFormRemoved;
  end;

procedure Register;

implementation

// -----------------------------------------------------------------------------

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

// -----------------------------------------------------------------------------

{ TWindowManager }

constructor TWindowManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoNotification := False;
  FLastIndex := -1;
  FWindowList := TList.Create;
end;

destructor TWindowManager.Destroy;
begin
  FWindowList.Free;
  inherited Destroy;
end;

procedure TWindowManager.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  if (FAutoNotification) and (AComponent <> nil) and (Operation = opRemove)
    and (AComponent is TCustomForm) and (Exists(TCustomForm(AComponent))) then
    Remove(TCustomForm(AComponent));
  inherited Notification(AComponent, Operation);
end;

function TWindowManager.Add(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := False;
  if not Exists(Form) then
  try
    New(WindowItem);
    WindowItem^.Form := Form;
    FWindowList.Add(WindowItem);
    if FAutoNotification then
      Form.FreeNotification(Self);
    Result := True;
    if assigned(FOnFormAdded) then
      FOnFormAdded(Self, Form);
    if assigned(FOnFormHandled) then
      FOnFormHandled(Self);
  except // wrap up
  end; // try/except
end;

function TWindowManager.Count: Integer;
begin
  Result := FWindowList.Count;
end;

function TWindowManager.CreateForm(const Form: TFormClass; Name: string; Show: Boolean
  = False): TCustomForm;
begin
  if not Form.InheritsFrom(TCustomForm) then
    raise
      Exception.Create('Invalid FormClass - must be a descendant of TCustomForm!');
  Result := TCustomForm(Form.Create(Application));
  if Name <> '' then
    Result.Name := Name;
  Add(Result);
  if Show then
    Result.Show;
end;

function TWindowManager.CreateForm(const Form: TFormClass; Show: Boolean = False):
  TCustomForm;
begin
  Result := CreateForm(Form, '', Show);
end;

function TWindowManager.Exists(const Form: TCustomForm): Boolean;
begin
  Result := GetWindowItemByForm(Form) <> nil;
end;

function TWindowManager.GetFormByIndex(Index: Integer): TCustomForm;
var
  WindowItem: PWindowItem;
begin
  Result := nil;
  WindowItem := GetWindowItemByIndex(Index);
  if WindowItem <> nil then
    Result := TCustomForm(WindowItem^.Form);
end;

function TWindowManager.GetWindowItemByIndex(Index: Integer): PWindowItem;
begin
  Result := nil;
  if Index < Count then
    Result := PWindowItem(FWindowList[Index]);
end;

function TWindowManager.GetWindowItemByForm(const Form: TCustomForm): PWindowItem;
var
  iIndex: Integer;
begin
  Result := nil;
  FLastIndex := -1;
  for iIndex := 0 to FWindowList.Count - 1 do
    if GetWindowItemByIndex(iIndex)^.Form = Form then
    begin
      FLastIndex := iIndex;
      Result := GetWindowItemByIndex(FLastIndex);
      Break;
    end;
end;

function TWindowManager.Remove(const Form: TCustomForm): Boolean;
var
  WindowItem: PWindowItem;
begin
  Result := False;
  WindowItem := GetWindowItemByForm(Form);
  if WindowItem <> nil then
  try
    FWindowList.Delete(FLastIndex);
    Dispose(WindowItem);
    Result := True;
    if assigned(FOnFormRemoved) then
      FOnFormRemoved(Self, Form);
    if assigned(FOnFormHandled) then
      FOnFormHandled(Self);
  except // wrap up
  end; // try/except
end;

function TWindowManager.Restore(const Form: TCustomForm): Boolean;
begin
  Result := False;
  if (Form <> nil) and (Exists(Form)) then
  try
    if IsIconic(Form.Handle) then
      Form.WindowState := wsNormal;
    Form.SetFocus;
    Result := True;
  except // wrap up
  end; // try/except
end;

function TWindowManager.Restore(const Index: Integer): Boolean;
begin
  Result := Restore(GetFormByIndex(Index));
end;

end.

To show you the in more detail how to work with this component, followed you'll find a demo application with two additional forms. You don't need to install the component to a package, I'll create it at runtime:

The project file

program WMDemo;

uses
  Forms,
  MainFrm in 'MainFrm.pas' {MainForm},
  WindowMng in 'WindowMng.pas',
  DynFrm1 in 'DynFrm1.pas' {DynForm1},
  DynFrm2 in 'DynFrm2.pas' {DynForm2};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.

The MainForm file

unit MainFrm;

interface

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

type
  TMainForm = class(TForm)
    ButtonDyn1: TButton;
    GroupBoxForms: TGroupBox;
    ListBoxForms: TListBox;
    ButtonHelloWorld: TButton;
    ButtonDyn2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ButtonDyn1Click(Sender: TObject);
    procedure ListBoxFormsDblClick(Sender: TObject);
    procedure ButtonHelloWorldClick(Sender: TObject);
    procedure ButtonDyn2Click(Sender: TObject);
  private
    { Private declarations }
    WindowManager: TWindowManager;
    procedure RedrawFormList(Sender: TObject);
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses
  DynFrm1, DynFrm2;

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  // create WindowManager
  WindowManager := TWindowManager.Create(Self);

  // enable 'AutoNotification'. If this feature is turned on,
  // WindowManager will receive a notification if a form was closed
  // by the user, so it can fire events to recorgnize this.
  // We use the 'OnFormHandled' event to redraw out ListBox.
  WindowManager.AutoNotification := True;

  // link event handler to update out ListBox.
  WindowManager.OnFormHandled := RedrawFormList;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  // destroy WindowManager
  WindowManager.Free;
end;

procedure TMainForm.RedrawFormList(Sender: TObject);
var
  i: Integer;
begin
  // get all available forms and display them.
  // we also stores the object reference to enable the 'restore' function
  // if the user double-clicked on an item.
  ListBoxForms.Clear;
  for i := 0 to WindowManager.Count - 1 do
    ListBoxForms.AddItem(WindowManager.Forms[i].Name, WindowManager.Forms[i]);
end;

procedure TMainForm.ButtonDyn1Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm1, True);
end;

procedure TMainForm.ButtonDyn2Click(Sender: TObject);
begin
  // create a new (dynamic) form.
  WindowManager.CreateForm(TDynForm2, True);
end;

procedure TMainForm.ListBoxFormsDblClick(Sender: TObject);
var
  ClickForm: TCustomForm;
begin
  // extract the 'clicked' form.
  with ListBoxForms do
    ClickForm := TCustomForm(Items.Objects[ItemIndex]);

  // restore the form to the top order.
  // we used the WindowManager method 'Restore' to be sure
  // that the form will be restored also if it was iconized
  // before.
  WindowManager.Restore(ClickForm);
end;

procedure TMainForm.ButtonHelloWorldClick(Sender: TObject);
begin
  // check, if any registered forms exists.
  if WindowManager.Count = 0 then
  begin
    ShowMessage('No dynamic Forms exists - please create one!');
    Exit;
  end;

  // check, if the first available form is 'DynForm1'.
  // if true, call the HelloWorld method.
  if WindowManager.Forms[0] is TDynForm1 then
    TDynForm1(WindowManager.Forms[0]).HelloWorld
  else
    ShowMessage('The first Form is not a "Dynamic Form I"!');
end;

end.

The MainForm resource file

object MainForm: TMainForm
  Left = 290
    Top = 255
    BorderStyle = bsSingle
    Caption = 'MainForm'
    ClientHeight = 229
    ClientWidth = 510
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    DesignSize = (
    510
    229)
    PixelsPerInch = 96
    TextHeight = 13
    object ButtonDyn1: TButton
    Left = 16
      Top = 16
      Width = 121
      Height = 25
      Caption = 'Create Dynamic Form I'
      TabOrder = 0
      OnClick = ButtonDyn1Click
  end
  object GroupBoxForms: TGroupBox
    Left = 16
      Top = 56
      Width = 481
      Height = 169
      Anchors = [akLeft, akTop, akRight, akBottom]
      Caption = 'Available Forms (Double-Click to restore)'
      TabOrder = 1
      object ListBoxForms: TListBox
      Left = 2
        Top = 15
        Width = 477
        Height = 152
        Align = alClient
        BorderStyle = bsNone
        ItemHeight = 13
        ParentColor = True
        TabOrder = 0
        OnDblClick = ListBoxFormsDblClick
    end
  end
  object ButtonHelloWorld: TButton
    Left = 344
      Top = 16
      Width = 153
      Height = 25
      Caption = 'Fire ''HelloWorld'' on DynForm1'
      TabOrder = 2
      OnClick = ButtonHelloWorldClick
  end
  object ButtonDyn2: TButton
    Left = 144
      Top = 16
      Width = 121
      Height = 25
      Caption = 'Create Dynamic Form II'
      TabOrder = 3
      OnClick = ButtonDyn2Click
  end
end

The DynForm1 file

unit DynFrm1;

interface

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

type
  TDynForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure HelloWorld;
  end;

var
  DynForm1: TDynForm1;

implementation

{$R *.dfm}

procedure TDynForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // be sure that our form will be freed.
  Action := caFree;
end;

procedure TDynForm1.HelloWorld;
begin
  ShowMessage('HelloWorld method was fired!');
end;

end.

The DynForm2 file

unit DynFrm2;

interface

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

type
  TDynForm2 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  DynForm2: TDynForm2;

implementation

{$R *.dfm}

procedure TDynForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // be sure that our form will be freed.
  Action := caFree;
end;

end.

Hope this article helps you to understand how dynamic forms can be created and managed.

How to reindex Paradox tables

Problem/Question/Abstract:

How to reindex Paradox tables

Answer:

There are a number of ways to approach this. One way would be to make a call to the BDE API function DbiRegenIndexes. This insulates you from having to know what indexes exist, if any, the BDE handling all the code for you. Error checking can be handled by examining the return value (type DBIResult) or by using the Check function (defined in the BDE wrapper unit BDE).

procedure TForm1.Button4Click(Sender: TObject);
var
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    Open;
    Check(DbiRegenIndexes(Table1.Handle));
    Close;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;

As when calling any BDE API function, the BDE API wrapper unit BDE (for Delphi 1, the units DbiTypes, DbiErrs, and DbiProcs) must be referenced in the Uses section of the unit from which the call is to be made. The BDE API function DbiSaveChanges, used here, forces any data changes in memory buffer to be written to disk at that point.

Another way to handle this situation -- if you know at design-time all the indexes that will exist for the table -- would be to iterate through the items in the TIndexDefs object of the TTable component, delete each index (DeleteIndex method), and then add all needed indexes back (AddIndex method).

procedure TForm1.Button3Click(Sender: TObject);
var
  aName: string;
  i: Byte;
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    IndexDefs.Update;
    i := IndexDefs.Count;
    while i > 0 do
    begin
      aName := IndexDefs.Items[i - 1].Name;
      DeleteIndex(aName);
      Dec(i);
    end;
    AddIndex('', 'MainField', [ixPrimary]);
    AddIndex('Field1', 'Field1', []);
    AddIndex('Field2', 'Field2', []);
    IndexDefs.Update;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;

When iterating through the items in the TIndexDefs object, the cycling must be backwards, from highest to lowest. This is to account for those table types that have primary indexes. With those table types, deleting a primary index first causes all secondary indexes to be unavailable, which interferes with this iterating based on the TIndexDefs array object contents. This is because a secondary index cannot exist in some table types (such as Paradox) without an existing primary index. For the same reason, when recreating the indexes, the process should start with the primary index and then progress through all secondary indexes (if any are to be created).

If information about the index definitions is not known at design-time, this process becomes emminently more complex. The data from all indexes will need to be saved to memory, the information for all indexes existing simultaneously in memory. This is because a primary index would need to be deleted at some point (to later be rebuilt), destroying references to any secondary indexes (whether retrieval for the secondary indexes takes place before or after deletion of the primary index). To accomplish this, some multi-entity storage structure would need to be created to hold a variable number of elements, one element per index. Each element would need to be able to store the four bits of data that comprise an index's definition: Name (String), Fields (String), Expression (String), and Options (TIndexOptions). An array or a TList object of Pascal records with these data fields would suffice for this purpose.

Once the definition information for all indexes are stored to memory, the succeeding steps are similar to those for the previous method: Delete each index (DeleteIndex) and then recreate each index based on the definition information stored in the array or TList (AddIndex).