How to create and use a resource-only DLL

Problem/Question/Abstract:

How do I create a DLL with just graphics files, then allow several different DLL's and applications to use these files?

Answer:

First, create a resource source file (*.RC) containing references to the bitmaps:

CLOSEBUTTON BITMAP "C:\Projects\closebtn.bmp"
OPENBUTTON BITMAP "C:\Projects\openbtn.bmp"

This is just an ordinary text file, so you can use the Delphi code editor or any other text editor to create it. Make sure the names of the bitmaps (CLOSEBUTTON, etc.) are ALL UPPERCASE.

Next, compile this .RC file to create the corresponding .RES file, using BRCC32.EXE:

brcc32 myimages.rc

Now start a new DLL project in Delphi and link the .RES file into it with an $R directive:

library MyImages;

uses
  Windows;

{$R MYIMAGES.RES}

begin
end.

Compile this code, and you now have a resource DLL containing the bitmaps.

To use these resources in an EXE or another DLL, you need to use LoadLibrary to get a handle to the DLL, and then LoadBitmap to get a handle to the bitmap:

var
  DllHandle: THandle;
  CloseButtonBmp: TBitmap;
  OpenButtonBmp: TBitmap;
begin
  DllHandle := LoadLibrary('MyImages.dll');
  if DllHandle <> 0 then
  try
    CloseButtonBmp := TBitmap.Create;
    CloseButtonBmp.Handle := LoadBitmap(DllHandle, 'CLOSEBUTTON');
    OpenButtonBmp := TBitmap.Create;
    OpenButtonBmp.Handle := LoadBitmap(DllHandle, 'OPENBUTTON');
    {...}
  finally
    FreeLibrary(DllHandle)
  end;
else
  ShowMessage(SysErrorMessage(GetLastError))
end;

Once you've loaded the bitmaps, you can assign them to their final destinations, wherever that may be, and then free them.

Advanced Options

Problem/Question/Abstract:

Some Advanced Options that I found on the Internet.


Answer:

1) It scroll automatically the Delphi Palette
[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Extras]
"AutoPaletteSelect"="1"

2) It scroll automatically the components on Palette
[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Extras]
"AutoPaletteScroll"="1"

3) It show font names in Object Inspector
[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Extras]
"FontNamePropertyDisplayFontNames"="1"

4) It show compiling errors in message view window
[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Compiling]
"ShowCodeInsiteError"="1"

5) Default fonts for new forms
[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\FormDesign]
"DefaultFont"="Tahoma, 8, Normal"

How to hide MDI child forms

Problem/Question/Abstract:

How to hide MDI child forms

Answer:

To hide:

{ ... }
if Form2.WindowState = wsMaximized then
  Form2.WindowState := wsNormal;
ShowWindow(Form2.Handle, SW_Hide);
{ ... }

To redisplay:

{ ... }
SetWindowPos(Form2.Handle, HWND_TOP, 0, 0, 0, 0, SWP_NoMove or
  SWP_NoSize or SWP_ShowWindow);
WinProcs.SetFocus(Form2.Handle);
{ ... }

Only numerical input in a TEdit

Problem/Question/Abstract:

Only numerical input in a TEdit

Answer:

If you want to limit the input of a TEdit to numerical strings only, you can discard the "invalid" characters in its OnKeyPress event handler.

Let's assume that you only want to allow positive integer numbers. The code for the OnKeyPress event handler is as follows:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  // #8 is Backspace
  if not (Key in [#8, '0'..'9']) then
  begin
    ShowMessage('Invalid key');
    // Discard the key
    Key := #0;
  end;
end;

If you also want numbers with a decimal fraction, you must allow a POINT or a COMMA, but only once. For an international version that looks at the correct decimal separator, the code could be as follows:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in [#8, '0'..'9', DecimalSeparator]) then
  begin
    ShowMessage('Invalid key: ' + Key);
    Key := #0;
  end
  else if (Key = DecimalSeparator) and
    (Pos(Key, Edit1.Text) > 0) then
  begin
    ShowMessage('Invalid Key: twice ' + Key);
    Key := #0;
  end;
end;

And here's a full blown version of the event handler, accepting a decimal separator and negative numbers (minus sign: only accepted once, has to be the first character):

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in [#8, '0'..'9', '-', DecimalSeparator]) then
  begin
    ShowMessage('Invalid key: ' + Key);
    Key := #0;
  end
  else if ((Key = DecimalSeparator) or (Key = '-')) and
    (Pos(Key, Edit1.Text) > 0) then
  begin
    ShowMessage('Invalid Key: twice ' + Key);
    Key := #0;
  end
  else if (Key = '-') and
    (Edit1.SelStart <> 0) then
  begin
    ShowMessage('Only allowed at beginning of number: ' + Key);
    Key := #0;
  end;
end;

How about giving that same behaviour to several TEdits on the same form, say 10 of them? In the Object Inspector, you change the name of the event handler of Edit1 from Edit1KeyPress to Edit1_10KeyPress or something similar. Delphi automatically changes the name in the code editor, don't worry.

Then, for each next TEdit, you select its OnKeyPress event and you select Edit1_10KeyPress from the listbox next to the event.

Finally, we have to slightly adapt the code. Intead of pointing to Edit1, we must point to "the TEdit that generated the event", in other words: the edit-box where the cursor was when a key was depressed. When you look at the template for the event handler that Delphi made, you see the parameter Sender: that's a pointer to the component that generated the event. But we are not allowed to use it straight away in our code, we must specify that we're dealing with a component of the type TEdit. That's done with the code Sender as TEdit:

procedure TForm1.Edit1_10KeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in [#8, '0'..'9', '-', DecimalSeparator]) then
  begin
    ShowMessage('Invalid key: ' + Key);
    Key := #0;
  end
  else if ((Key = DecimalSeparator) or (Key = '-')) and
    (Pos(Key, (Sender as TEdit).Text) > 0) then
  begin
    ShowMessage('Invalid Key: twice ' + Key);
    Key := #0;
  end
  else if (Key = '-') and
    ((Sender as TEdit).SelStart <> 0) then
  begin
    ShowMessage('Only allowed at beginning of number: ' + Key);
    Key := #0;
  end;
end;

Draw a filled circle using ScanLine

Problem/Question/Abstract:

I am looking for some code to draw a filled circle on a bitmap or change colors of pixels within a circle on it, using Bitmap.Scanline. Any suggestions or ideas on how to do this, the edges need to be perfect and it has to be fast.

Answer:

Perfect edges mean you will have to work with an alpha channel and do anti-aliasing. This means, that you either have to use a 32-bit bitmap (see e.g. Graphics32) or you have to first draw the background image in the bitmap and directly blend it when rendering the circle. Next question: do you want to use integer precision or floating point precision for the circle properties like center point and diameter? If you use integer, you only have to draw 1/8 of the circle and the rest can be copied/mirrored/flipped around. Assuming floating point, and a grayscale bitmap, here's an approach:

CX, CY: center of circle (single)
R: radius of circle (single)
F: feather size (the number of pixels used as blend area, usually 1 pix) (single)

Determine bounds in Y (integers):
LX := floor(CX - R - F * 0.5);
RX := ceil(CX + R + F * 0.5);
LY := floor(CY - R - F * 0.5);
RY := ceil(CY + R + F * 0.5);

Determine some helpful values (singles)
RPF2 = sqr(R + F/2);
RMF2 = sqr(R - F/2);

{ ... }
var
  P: PByteArray
  sqdist: single;
  { ... }
    {Loop through Y values}
    {for y := LY to RY do begin -> not very safe}
  for y := max(LY, 0) to Min(RY, Bitmap.Height - 1) do
    P := Bitmap.Scanline[y];
  {Loop through X values}
  for x := Max(LX, 0) to Min(RX, Bitmap.Width - 1) do
  begin
    {Determine squared distance from center for this pixel}
    sqdist := sqr(y - CY) + sqr(x - CX); {Or use hypot() function}
    {Inside outer circle?}
    if sqdist < RPF2 then
    begin
      {Inside inner circle?}
      if sqdist < RMF1 then
        {Inside the inner circle.. just give the scanline the new color}
        P[x] := 255
      else
      begin
        {We are inbetween the inner and outer bound, now mix the color}
        Fact := Max(0, Min(255, round(((R - sqrt(sqdist)) * 2 / F) * 128 + 128)));
        P[x] := (255 - Fact) * P[x] + Fact;
      end;
    end;
    { ... }

This algorithm is optimized a bit but could be made faster probably. Untested!

Copy a menu item from a TMainMenu to an empty popup menu

Problem/Question/Abstract:

How to copy a menu item from a TMainMenu to an empty popup menu

Answer:

This will only copy the first level of menu items:

procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
I: Integer;
MenuItem: TMenuItem;
begin
TPopupMenu(Sender).Items.Clear;
{Copy menu items from first mainmenu (File1)}
for I := 0 to File1.Count - 1 do
begin
with File1.Items[I] do
MenuItem := NewItem(Caption, ShortCut, Checked, Enabled, OnClick, HelpContext,
Name);
TPopupMenu(Sender).Items.Add(MenuItem);
end;
end;

Convert a string to a set and vice versa using RTTI

Problem/Question/Abstract:

Given a string like '[mbOk, mbCancel]', what is a simple way to use the routines in TypInfo to produce the corresponding set?

Answer:

uses
TypInfo;

function ButtonStringToSet(const S: string): TMsgDlgButtons;
var
Temp: TStringlist;
I: Integer;
N1, N2: Integer;
begin
Result := [];
N1 := Pos('[', S);
N2 := Pos(']', S);
if N2 = 0 then
N2 := Length(S) + 1;
Assert(N2 > N1);
Temp := TStringlist.Create;
try
Temp.Commatext := Copy(S, N1 + 1, N2 - N1 - 1);
for i := 0 to Temp.Count - 1 do
Include(Result, TMsgDlgBtn(TypInfo.GetEnumValue(TypeInfo(TMsgDlgBtn),
Trim(Temp[I]))));
finally
Temp.Free;
end;
end;

function SetToButtonString(Buttons: TMsgDlgButtons): string;
var
Temp: TStringlist;
Btn: TMsgDlgBtn;
begin
Temp := TStringlist.Create;
try
for Btn := Low(Btn) to High(Btn) do
if Btn in Buttons then
Temp.Add(TypInfo.GetEnumName(TypeInfo(TMsgDlgBtn), Ord(Btn)));
Result := Format('[%s]', [Temp.Commatext]);
finally
Temp.Free;
end;
end;

Accessing hidden properties

Problem/Question/Abstract:

How can I access the InplaceEditor property of a Grid?

Answer:

Some components have useful properties, but for some reason they were declared in their protected section, so they are not readily available to the programmer. For example, TStringGrid, TDrawGrid, TDBGrid and in general any descendant of TCustomGrid has an InplaceEditor property that represents the text edit box used for editing cell values. However you can't access this property directly because it has been declared as protected.

The easiest workaround to this problem is subclassing (deriving) your component with the only purpose or publishing the protected property. For example:

type
  TDBGridX = class(TDBGrid)
  public
    property InplaceEditor;
  end;

We don't need to intall this new component and register it in the components palette (which I consider too much of a bother for such a little thing). Instead, any time we want to access this property, we can just cast the object (for example DBGrid1) to our new class. For example:

TDBGridX(DBGrid1).InplaceEditor.SelectAll;

Note: InplaceEditor will be Nil until the first time EditorMode is set to True (either by code or when the user presses F2).

But use the protected property always cause some fault unexpectable.Sush as the Fixcols property. How to resolve it?

The properties were left protected for some reason, usually this being the fact that they are not safe to use directly. There are some limitations when accessing protected fields, properties or methods and normally these limitations are documented (they are not so much "unexpectable").

For example, about the inplace editor the documentation says:

   "The inplace editor is created the first time the grid is put in edit mode."

This means that before the first time the grid is put in edit mode, a code like the following will certainly generate an
Access Violation:

TDBGridX(DBGrid1).InplaceEditor.SelectAll;

You can solve this problem by first checking if InplaceEditor is not Nil:

if TDBGridX(DBGrid1).InplaceEditor <> nil then
  TDBGridX(DBGrid1).InplaceEditor.SelectAll;

About FixedCols, the documentation says:

"Grids must include at least one scrolling column. Do not set FixedCols to a value greater than ColCount - 1."

This means that for instance the following code will raise an EInvalidGridOperation exception if ColCount <= 2:

TDBGridX(DBGrid1).FixedCols := 2;

For example if you create columns automatically from a Dataset associated with a DataSource, then you should first open the Dataset to let the columns be created, and only then you can set the FixedCols property. For example:

Table1.Active := True;
TDBGridX(DBGrid1).FixedCols := 2;

In conclusion, you should check the documentation first before using the protected properties since normally they have some limitation. As I've shown, the way to circunvent it depends on the case and there is no general rule. There may be also some undocumented problems and side effects and when they appear generally you should check the source code of the component to get an idea of how to avoid or fix them.

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

Add items to the Windows Explorer right-click menu (2)

Problem/Question/Abstract:

Does anybody know how to write a Delphi program that can add itself to the Windows Explorer right-click menu? I have seen some simple cases like adding NotePad for txt files but that only works on one file (if you highlight many files then many instances of Notepad will be created). I want to be able to highlight a group of files and then pass all of them (probably through a command line argument) to my progam so it can act on the group of them.

Answer:

Implement IContextMenu and IShellExtInit:

TOFCContextMenu = class(TComObject, IContextMenu, IShellExtInit)
private
  FileList: TStringList;
protected
  function IShellExtInit.Initialize = IShellExtInit_Initialize;
  function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
    uFlags: UINT): HResult; stdcall;
  function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
  function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR;
    cchMax: UINT): HResult; stdcall;
  function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
    hKeyProgID: HKEY): HResult; stdcall;
public
  destructor Destroy; override;
end;

In the Initialize method of the IShellExtInit interface you can determine which files are selected:

function TOFCContextMenu.IShellExtInit_Initialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult; stdcall;
var
  StgMedium: TStgMedium;
  FormatEtc: TFormatEtc;
  szFile: array[0..MAX_PATH + 1] of Char;
  FileCount: Integer;
  FileCounter: Integer;
begin
  try
    if (lpdobj <> nil) then
    begin
      with FormatEtc do
      begin
        cfFormat := CF_HDROP;
        ptd := nil;
        dwAspect := DVASPECT_CONTENT;
        lindex := -1;
        tymed := TYMED_HGLOBAL;
      end;
      Result := lpdobj.GetData(FormatEtc, StgMedium);
      if (not Failed(Result)) then
      begin
        FileList := TStringList.Create;
        FileList.Clear;
        FileList.Sorted := True;
        FileList.Duplicates := dupIgnore;
        FileCount := DragQueryFile(stgmedium.hGlobal, $FFFFFFFF, nil, 0);
        for FileCounter := 0 to FileCount - 1 do
        begin
          DragQueryFile(stgmedium.hGlobal, FileCounter, szFile, SizeOf(szFile));
          FileList.Add(StrPas(szFile));
        end;
        Result := NOERROR;
        ReleaseStgMedium(StgMedium);
      end;
    end
    else
      Result := E_INVALIDARG;
  except
    Result := E_FAIL;
  end;
end;

The file list must be freed in the destructor:

destructor TOFCContextMenu.Destroy;
begin
  try
    FileList.Free;
  except
  end;
  inherited Destroy;
end;

Now implement the other methods:

QueryContextMenu
InvokeCommand
GetCommandString

At the end of the unit you can register the extension:

initialization
  TRegisterContextMenuFactory.Create(ComServer, TOFCContextMenu, Class_OFCContextMenu,
    'OFCContextMenu', 'A description', ciMultiInstance, tmApartment);

Remember to protect every method with try..except or try..finally. The main application is the explorer. It doesn't support exception handling like a delphi application does. An exception outside a try..except/finally compound causes the explorer to crash.

The TRegisterContextMenuFactory object looks something like this:

type
  TRegisterContextMenuFactory = class(TComObjectFactory)
  protected
    function GetProgID: string; override;
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

function TRegisterContextMenuFactory.GetProgID: string;
begin
  Result := '';
end;

procedure TRegisterContextMenuFactory.UpdateRegistry(Register: Boolean);
const
  ApproveKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\ShellExtensions\Approved\';
var
  ClsID: string;
begin
  inherited UpdateRegistry(Register);
  ClsID := GUIDToString(ClassID);
  if (Register) then
  try
    {Additional registry settings }
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      CreateRegKeyEx(ApproveKey, ClsId, PChar(Description), REG_SZ,                                                              Length(Description) + 1, HKEY_LOCAL_MACHINE);
  except
  end
  else
  try
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      DeleteRegValue(ApproveKey, ClsId, HKEY_LOCAL_MACHINE);
    {Delete additional registry settings }
  except
  end;
end;

Instead of {Additional registry settings } you must add the registry keys for the extension. Like which file exctension is associated. You can use HKEY_LOCAL_MACHINE\* for all extensions.

Debug a component at design time (in the IDE)

Problem/Question/Abstract:

Debug a component at design time (in the IDE)

Answer:

To debug a component at design time, follow these steps:

In Delphi go to Tools/Options then go to the "Library" page. Check the "Compile With Debug Info" box.

Rebuild the library.

Run Delphi from within Turbo Debugger.

Use "File/Change Dir" to include the source directories.

Fixing a broken generator (InterBase)

Problem/Question/Abstract:

Recently I got unique key violations during insert attempts on a piece of code that used to work (what can go bad, will go bad). I found that the offending field - was actually created by a generator. For some reason the generator returned values that where already in the database.

how can I display the current value of the generator?
how can I adjust the value of the generator?

Answer:

See the example (table name is SD_LOAD, generator name is GEN_SD_LOAD).

Note:

You cannot modify the value of the generator inside of a trigger or stored procedure. You only can call the gen_id() function to increment the value in a generator. The SET GENERATOR command will only work outside of a stored procedure or trigger.

SELECT DISTINCT(GEN_ID(gen_sd_load, 0))FROM sd_load

set GENERATOR gen_sd_load to 2021819

How to get Windows uptime?

Problem/Question/Abstract:

How to get Windows uptime?

Answer:

Use the following function:

function UpTime: string;
const
  ticksperday: integer = 1000 * 60 * 60 * 24;
  ticksperhour: integer = 1000 * 60 * 60;
  ticksperminute: integer = 1000 * 60;
  tickspersecond: integer = 1000;

var
  t: longword;
  d, h, m, s: integer;

begin
  t := GetTickCount;

  d := t div ticksperday;
  dec(t, d * ticksperday);

  h := t div ticksperhour;
  dec(t, h * ticksperhour);

  m := t div ticksperminute;
  dec(t, m * ticksperminute);

  s := t div tickspersecond;

  Result := 'Uptime: ' + IntToStr(d) + ' Days ' + IntToStr(h) + ' Hours ' + IntToStr(m)
    + ' Minutes ' + IntToStr(s) + ' Seconds';
end;

Replace the default scrollbar of a TStringGrid with buttons

Problem/Question/Abstract:

I want to put two buttons as a scrollbar to my grid instead of using the default Delphi windows scrollbar. I suppose that I should handle the messages like WM_VSCROLL and WM_HSCROLL and setting my grid.Scrollbars := none

Answer:

You should send these messages to the grid on your button presses, e.g. for a line up:

{ ... }
with stringgrid1 do
begin
  perform(WM_VSCROLL, SB_LINEUP, 0);
  perform(WM_VSCROLL, SB_ENDSCROLL, 0);
end;

or use:

procedure buttonupClick(sender);
begin
  SendMessage(Grid1.Handle, WM_VSCROLL, SB_LINEUP, 0)
end;

Sparse array implementation using TStringlist

Problem/Question/Abstract:

Sparse arrays are arrays that only uses memory for the cells that are actually in use although the full size of the array is always available. A prime example is the cells in a spreadsheet application: they can have enormous dimensions (like 99999 * 99999 cells) but still only use memory equivalent to the cells where there is any data. This article shows how you can easily create a sparse array with any number of dimensions and of arbitrary size.

Answer:

One solution is to create a new class (let's call it TSparseArray) that stores the data in a TStringlists Objects array and the dimensions in the Strings array as a compound string. Here's a two-dimensional example:

interface

type
  TSparseArray = class(TObject)
  private
    FCells: TStringlist;
    function GetCell(Col, Row: integer): TObject;
    procedure SetCell(Col, Row: integer; const Value: TObject);
  public
    constructor Create;
    destructor Destroy; override;
    property Cells[Col, Row: integer]: TObject read GetCell write SetCell; default;
  end;

implementation

const
  cFmtDims = '%d:%d';

constructor TSparseArray.Create;
begin
  inherited Create;
  FCells := TStringlist.Create;
  FCells.Sorted := true; // faster retrieval, slower updates, needed for dupIgnore
  FCells.Duplicates := dupIgnore;
end;

destructor TSparseArray.Destroy;
begin
  FCells.Free;
  inherited Destroy;
end;

function TSparseArray.GetCell(Col, Row: integer): TObject;
var
  i: integer;
begin
  Result := nil;

  i := FCells.IndexOf(Format(cFmtDims, [Col, Row]));
  if i > -1 then
    Result := FCells.Objects[i];
end;

procedure TSparseArray.SetCell(Col, Row: integer; const Value: TObject);
begin
  // dupIgnore guarantees that if this cell already exists, this will overwrite it
  FCells.AddObject(Format(cFmtDims, [Col, Row]), Value);
end;

end.

To create a sparse array with more dimensions, you just have to redefine the Cells property (and the read / write methods) and change the format of cFmtDims accordingly. You can even mix dimensions of different types (i.e Cells[const Row:string;Col:integer]:TObject). I think you can come up with more neat things yourself. Enjoy!

Accessing DataBase via 3th server

Problem/Question/Abstract:

Writing n-tier Application for accessing client's app to DataBase without installing Client of Database via 3th server using Indy

Answer:

This is simple sample how organize work client's app with DataBase without installing Database client or organize remote access to database.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdTCPServer, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, DBClient, Provider, Grids, DBGrids, DB,
  OracleData, Oracle, IdAntiFreezeBase, IdAntiFreeze;

type
  TForm1 = class(TForm)
    OracleSession1: TOracleSession;
    OracleDataSet1: TOracleDataSet;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    DataSetProvider1: TDataSetProvider;
    ClientDataSet1: TClientDataSet;
    IdTCPClient1: TIdTCPClient;
    IdTCPServer1: TIdTCPServer;
    Button1: TButton;
    Memo1: TMemo;
    IdAntiFreeze1: TIdAntiFreeze;
    procedure Button1Click(Sender: TObject);
    procedure IdTCPServer1Connect(AThread: TIdPeerThread);
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure variantToStream(const v: oleVariant; stream: TStream);
var
  p: pointer;
begin
  stream.position := 0;
  stream.size := varArrayHighBound(v, 1) - varArrayLowBound(v, 1) + 1;
  p := varARrayLock(v);
  stream.write(p^, stream.size);
  varARrayUnlock(v);
  stream.position := 0;
end;

procedure VarArrayToStream(const Data: OleVariant; Stream: TStream);
var
  p: Pointer;
begin
  p := VarArrayLock(Data);
  try
    Stream.Write(p^, VarArrayHighBound(Data, 1) + 1); //assuming low bound = 0
  finally
    VarArrayUnlock(Data);
  end;
end;

function StreamToVarArray(Stream: TStream): OleVariant;
var
  p: Pointer;
begin
  Result := VarArrayCreate([0, Stream.Size - 1], varByte);
  p := VarArrayLock(Result);
  try
    Stream.Position := 0; //start from beginning of stream
    Stream.Read(p^, Stream.Size);
  finally
    VarArrayUnlock(Result);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  if not IdTCPClient1.Connected then
    IdTCPClient1.Connect;
  if IdTCPClient1.Connected then
    Memo1.Lines.Add('connected')
  else
    Memo1.Lines.Add('Not Connected');

  IdTCPClient1.Write('open');
  IdTCPClient1.ReadStream(ms, STrToINt(IdTCPClient1.ReadString(10)));
  ClientDataSet1.Data := StreamToVarArray(ms);
  // ClientDataSet1.LoadFromStream(ms);
  ClientDataSet1.Active := True;
end;

procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
  //
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
  s: string;
  ms: TMemoryStream;
begin
  with AThread.Connection do
  begin
    s := ReadString(4);
    if s = 'open' then
    begin
      ms := TMemoryStream.Create;
      VarArrayToStream(DataSetProvider1.Data, ms);
      s := IntToSTr(ms.Size);
      while length(s) < 10 do
      begin
        s := '0' + s;
      end;
      Write(s);
      ms.Seek(0, soFromBeginning);

      WriteStream(ms);
    end;
  end;
end;

end.

How to change the system colours

Problem/Question/Abstract:

How to change the system colours

Answer:

Solve 1:

procedure TMainForm.Button4Click(Sender: TObject);
var
  nColorIndex: array[1..2] of integer;
  nColorValue: array[1..2] of longint;
begin
  nColorIndex[1] := COLOR_ACTIVECAPTION;
  nColorIndex[2] := COLOR_BTNFACE;
  nColorValue[1] := clBlue; {define the color you want}
  nColorValue[2] := clRed; {in that case is the caption bar and button color}
  SetSysColors(2, nColorIndex, nColorValue);
  PostMessage(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0, 0);
end;

You could have a look into the "Win32 API reference", under the "SetSysColors" section. There, if you directly go to "GetSysColors" you'll get alist of the places where you can change the colors. (e.g taskbar, borders, etc). In your case use COLOR_BACKGROUND and COLOR_DESKTOP.


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
const
  ColCount = 2;
  Elements: array[0..ColCount - 1] of Integer = (COLOR_WINDOW, COLOR_WINDOWTEXT);
  Colors: array[0..ColCount - 1] of TColorRef = (clBlue, clYellow);
begin
  if not SetSysColors(ColCount, Elements[0], Colors[0]) then
    RaiseLastWin32Error;
end;

How to sort a TStringList by numerical value using the Heapsort algorithm

Problem/Question/Abstract:

I cannot use the Sort method in TStringList as I would like to sort by Integer. My TStringList is filled with numbers such as:

20, 12, 1, 23, 54, 32

Of course, they're converted to string before being added to TStringList. What is a fast algorithm to achieve this sort? I normally have less than 50 items in my TStringList, if that is a factor.

Answer:

You'd end up doing a lot of conversions using StrToInt, which is wasteful, so I would recommend that you create a

type
PInteger = ^Integer type

store all of the StrToInt values in the TStringList.Objects array, and then when you use the sort, do your comparisons based on

PInteger(SL.Objects[Idx])^

The quicksort that TStringList uses (see CLASSES.PAS) uses a very simple partition function, which is completely unaware of the data it's sorting. It's using the midpoint index to begin to decide where to start partitioning, which is just as reliable as picking a random number when deciding how to sort. If, for example, you had a big list of items that was already sorted in the reverse direction, and you used this quicksort on it, and would call itself recursively once for every element in the list! Now, when you take into account that you're pushing a few items on the stack (the return address as well as the parameters as well as the registers you are saving) it might not take too long for your 16K of stack space to get eaten up (16,384 bytes divided by about maybe 32 bytes (and that's being pretty optimistic!) is about 2048 items before you run the risk of killing the stack!). The MaxListSize in CLASSES is 16380 (65520 div sizeof (Pointer)), so it's certainly possible to cause this problem.

Remember that TStringList.Sort is declared as virtual, so if you wanted to override it, you certainly could in a class derived from TStringList.

Also mind that the odds of anyone having to sort this much data (2000 items) seems pretty remote (correct me, anyone, if you've ever sorted more than 2000 strings in an application). The most reliable sort with the same running time as QuickSort is a HeapSort. They both run in O(N lg N) time, whereas sorts like the InsertionSort (which someone mentioned) and BubbleSort (which someone else mentioned) run in O(N^2) time, on the average.

The biggest differences between HeapSort and QuickSort, in terms of their run time and storage are:

HeapSort only calls itself recursively at most lg N times, where as QuickSort could call itself recursively N times (big difference, like 10 vs 1024, or 32 vs 2^32);
The worst case upper bound time on HeapSort is only O(N lg N), whereas in the worst case for QuickSort, the running time is O(N^2).


program H;

uses
  WinCrt, SysUtils;

const
  min = 10;
  max = 13;
  maxHeap = 1 shl max;

type
  heap = array[1..maxHeap] of integer;
  heapBase = ^heap;

var
  currentSize, heapSize: integer;
  A: heapBase;

procedure SwapInts(var a, b: integer);
var
  t: integer;
begin
  t := a;
  a := b;
  b := t
end;

procedure InitHeap(size: integer);
var
  i: integer;
begin
  heapSize := size;
  currentSize := size;
  Randomize;
  for i := 1 to size do
    A^[i] := Random(size) + 1;
end;

procedure Heapify(i: integer);
var
  left, right, largest: integer;
begin
  largest := i;
  left := 2 * i;
  right := left + 1;
  if left <= heapSize then
    if A^[left] > A^[i] then
      largest := left;
  if right <= heapSize then
    if A^[right] > A^[largest] then
      largest := right;
  if largest <> i then
  begin
    SwapInts(A^[largest], A^[i]);
    Heapify(largest)
  end;
end;

procedure BuildHeap;
var
  i: integer;
begin
  for i := heapSize div 2 downto 1 do
    Heapify(i)
end;

procedure HeapSort;
var
  i: integer;
begin
  BuildHeap;
  for i := currentSize downto 2 do
  begin
    SwapInts(A^[i], A^[1]);
    dec(heapSize);
    Heapify(1)
  end;
end;

type
  TAvgTimes = array[min..max] of TDateTime;
var
  sTime, eTime, tTime: TDateTime;
  i, idx, size: integer;
  avgTimes: TAvgTimes;
begin
  tTime := 0;
  i := min;
  size := 1 shl min;
  new(A);
  while i <= max do
  begin
    for idx := 1 to 10 do
    begin
      InitHeap(size);
      sTime := Time;
      HeapSort;
      eTime := Time;
      tTime := tTime + (eTime - sTime)
    end;
    avgTimes[i] := tTime / 10.0;
    inc(i);
    size := size shl 1;
  end;
end.

Get "executable" file name also from a DLL

Problem/Question/Abstract:

If you still use ParamStr(0), or Application.ExeName for getting your executable path and file name, you could have problems developing DLLs. In fact if your DLL enquires ParamStr(0) it gets the path and file name of the executable which loaded your DLL.

Answer:

Using Application.ExeName is the same as using ParamStr(0), but there's a way to fix this and have the correct file name in every case.

Just use this:


function GetRealExeName: string;
var
  ExeName: array[0..MAX_PATH] of char;
begin
  fillchar(ExeName, SizeOf(ExeName), #0);
  GetModuleFileName(HInstance, ExeName, MAX_PATH);
  Result := ExeName;
end;

Implement fuzzy search

Problem/Question/Abstract:

How to implement fuzzy search

Answer:

Solve 1:

This DLL calculates the Levenshtein Distance between two strings. Please note that ShareMem must be the first unit in the Uses clause of the Interface section of your unit, if your DLL exports procedures or functions, which pass string parameters or function results. ShareMem is the interface to delphimm.dll, which you have to distribute together with your own DLL. To avoid using delphimm.dll, pass string parameters by using PChar or ShortString parameters.

library Levensh;

uses
  ShareMem, SysUtils;

var
  FiR0: integer;
  FiP0: integer;
  FiQ0: integer;

function Min(X, Y, Z: Integer): Integer;
begin
  if (X < Y) then
    Result := X
  else
    Result := Y;
  if (Result > Z) then
    Result := Z;
end;

procedure LevenshteinPQR(p, q, r: integer);
begin
  FiP0 := p;
  FiQ0 := q;
  FiR0 := r;
end;

function LevenshteinDistance(const sString, sPattern: string): Integer;
const
  MAX_SIZE = 50;
var
  aiDistance: array[0..MAX_SIZE, 0..MAX_SIZE] of Integer;
  i, j, iStringLength, iPatternLength, iMaxI, iMaxJ: Integer;
  chChar: Char;
  iP, iQ, iR, iPP: Integer;
begin
  iStringLength := length(sString);
  if (iStringLength > MAX_SIZE) then
    iMaxI := MAX_SIZE
  else
    iMaxI := iStringLength;
  iPatternLength := length(sPattern);
  if (iPatternLength > MAX_SIZE) then
    iMaxJ := MAX_SIZE
  else
    iMaxJ := iPatternLength;
  aiDistance[0, 0] := 0;
  for i := 1 to iMaxI do
    aiDistance[i, 0] := aiDistance[i - 1, 0] + FiR0;
  for j := 1 to iMaxJ do
  begin
    chChar := sPattern[j];
    if ((chChar = '*') or (chChar = '?')) then
      iP := 0
    else
      iP := FiP0;
    if (chChar = '*') then
      iQ := 0
    else
      iQ := FiQ0;
    if (chChar = '*') then
      iR := 0
    else
      iR := FiR0;
    aiDistance[0, j] := aiDistance[0, j - 1] + iQ;
    for i := 1 to iMaxI do
    begin
      if (sString[i] = sPattern[j]) then
        iPP := 0
      else
        iPP := iP;
      {aiDistance[i, j] := Minimum of 3 values}
      aiDistance[i, j] := Min(aiDistance[i - 1, j - 1] + iPP,
        aiDistance[i, j - 1] + iQ,
        aiDistance[i - 1, j] + iR);
    end;
  end;
  Result := aiDistance[iMaxI, iMaxJ];
end;

exports
  LevenshteinDistance Index 1,
  LevenshteinPQR Index 2;

begin
  FiR0 := 1;
  FiP0 := 1;
  FiQ0 := 1;
end.


Solve 2:

This is an old Pascal code snippet, which is based on a C project published in the C't magazine somewhen back in the 1990's. Can't remember where I found it on the WWW. Please note that the code below accesses a simple *.txt file to search in.

program FuzzySearch;
{Translation from C to Pascal by Karsten Paulini and Simon Reinhardt}
const
  MaxParLen = 255;
var
  InFile: Text;
  Filename: string;
  InputStr: string;
  SearchStr: string;
  Treshold: Integer;

function PrepareTheString(OriginStr: string; var ConvStr: string): Integer;
var
  i: Integer;
begin
  ConvStr := OriginStr;
  for i := 1 to Length(OriginStr) do
  begin
    ConvStr[i] := UpCase(ConvStr[i]);
    if ConvStr[i] < '0' then
      ConvStr[i] := ' '
    else
      case ConvStr[i] of
        Chr(196): ConvStr[i] := Chr(228);
        Chr(214): ConvStr[i] := Chr(246);
        Chr(220): ConvStr[i] := Chr(252);
        Chr(142): ConvStr[i] := Chr(132);
        Chr(153): ConvStr[i] := Chr(148);
        Chr(154): ConvStr[i] := Chr(129);
        ':': ConvStr[i] := ' ';
        ';': ConvStr[i] := ' ';
        '<': ConvStr[i] := ' ';
        '>': ConvStr[i] := ' ';
        '=': ConvStr[i] := ' ';
        '?': ConvStr[i] := ' ';
        '[': ConvStr[i] := ' ';
        ']': ConvStr[i] := ' ';
      end;
  end;
  PrepareTheString := i;
end;

function NGramMatch(TextPara, SearchStr: string; SearchStrLen, NGramLen: Integer;
  var MaxMatch: Integer): Integer;
var
  NGram: string[8];
  NGramCount: Integer;
  i, Count: Integer;
begin
  NGramCount := SearchStrLen - NGramLen + 1;
  Count := 0;
  MaxMatch := 0;
  for i := 1 to NGramCount do
  begin
    NGram := Copy(SearchStr, i, NGramLen);
    if (NGram[NGramLen - 1] = ' ') and (NGram[1] < > ' ') then
      Inc(i, NGramLen - 3) {will be increased in the loop}
    else
    begin
      Inc(MaxMatch, NGramLen);
      if Pos(NGram, TextPara) > 0 then
        Inc(Count);
    end;
  end;
  NGramMatch := Count * NGramLen;
end;

procedure FuzzyMatching(SearchStr: string; Treshold: Integer; var InFile: Text);
var
  TextPara: string;
  TextBuffer: string;
  TextLen: Integer;
  SearchStrLen: Integer;
  NGram1Len: Integer;
  NGram2Len: Integer;
  MatchCount1: Integer;
  MatchCount2: Integer;
  MaxMatch1: Integer;
  MaxMatch2: Integer;
  Similarity: Real;
  BestSim: Real;
begin
  BestSim := 0.0;
  SearchStrLen := PrepareTheString(SearchStr, SearchStr);
  NGram1Len := 3;
  if SearchStrLen < 7 then
    NGram2Len := 2
  else
    NGram2Len := 5;
  while not Eof(InFile) do
  begin
    Readln(InFile, TextBuffer);
    TextLen := PrepareTheString(TextBuffer, TextPara) + 1;
    TextPara := Concat(' ', TextPara);
    if TextLen < MaxParLen - 2 then
    begin
      MatchCount1 := NGramMatch(TextPara, SearchStr, SearchStrLen, NGram1Len, MaxMatch1);
      MatchCount2 := NGramMatch(TextPara, SearchStr, SearchStrLen, NGram2Len, MaxMatch2);
      Similarity := 100.0 * (MatchCount1 + MatchCount2) / (MaxMatch1 + MaxMatch2);
      if Similarity > BestSim then
        BestSim := Similarity;
      if Similarity >= Treshold then
      begin
        Writeln;
        Writeln('[', Similarity, '] ', TextBuffer);
      end;
    end;
  else
    Writeln('Paragraph too long');
end;
if BestSim < Treshold then
  Writeln('No match; Best Match was ', BestSim);
end;

begin
  Writeln;
  Writeln('+------------------------------------------+');
  Writeln('| Fuzzy Search in Information Retrieval |');
  Writeln('|         (C) 1997 Reinhard Rapp           |');
  Writeln('+------------------------------------------+');
  Writeln;
  Write('Name of file to search in: ');
  Readln(Filename);
  Write('Search string: ');
  Readln(InputStr);
  SearchStr := Concat(' ', InputStr, ' ');
  Write('Minimum hit quality in % : ');
  Readln(Treshold);
  if (Treshold > 0) and (Treshold <= 100) and (SearchStr < > '') and (Filename < > '') then
  begin
    Assign(InFile, Filename);
    Reset(InFile);
    FuzzyMatching(SearchStr, Treshold, InFile);
    Close(InFile);
  end;
  Writeln;
  Writeln('Bye!');
end.


Solve 3:

unit FuzzyMatch;

{This unit provides a basic 'fuzzy match' index on how alike two strings are
     The result is of type 'single': near 0 - poor match
                                     near 1 - close match
     The intention is that HowAlike(s1,s2)=HowAlike(s2,s1)
     The Function is not case sensitive}

interface

uses sysutils;

function HowAlike(s1, s2: string): single;

implementation

function instr(start: integer; ToSearch, ToFind: string): integer;
begin
  //This is a quick implementation of the VB InStr, since Pos just doesn't do what is needed!!
  //NB - case sensitive!!
  if start > 1 then
    Delete(ToSearch, 1, start - 1);
  result := pos(ToFind, ToSearch);
  if (result > 0) and (start > 1) then
    inc(result, start);
end;

function HowAlike(s1, s2: string): single;
var
  l1, l2, pass, position, size, foundpos, maxscore: integer;
  score, scored, string1pos, string2pos, bestmatchpos: single;
  swapstring, searchblock: string;
begin
  s1 := Uppercase(trim(s1));
  s2 := Uppercase(trim(s2));

  score := 0;
  maxscore := 0;
  scored := 0;

  //deal with zero length strings...
  if (s1 = '') and (s2 = '') then
  begin
    result := 1;
    exit;
  end
  else if (s1 = '') or (s2 = '') then
  begin
    result := 0;
    exit;
  end;

  //why perform any mathematics is the result is clear?
  if s1 = s2 then
  begin
    result := 1;
    exit;
  end;

  //make two passes,
  //     with s1 and s2 each way round to ensure
  //     consistent results
  for pass := 1 to 2 do
  begin
    l1 := length(s1);
    l2 := length(s2);
    for size := l1 downto 1 do
    begin
      for position := 1 to (l1 - size + 1) do
      begin
        //try to find implied block in the other string
        //Big blocks score much better than small blocks
        searchblock := copy(s1, position, size);
        foundpos := pos(searchblock, s2);

        if size = l1 then
          string1pos := 0.5
        else
          string1pos := (position - 1) / (l1 - size);

        if foundpos > 0 then
        begin
          //the string is in somewhere in there
          //    - find the 'closest' one.
          bestmatchpos := -100; //won't find anything that far away!

          repeat
            if size = l2 then
              string2pos := 0.5
            else
              string2pos := (foundpos - 1) / (l2 - size);

            //If this closer than the previous best?
            if abs(string2pos - string1pos) < abs(bestmatchpos - string1pos) then
              bestmatchpos := string2pos;

            foundpos := instr(foundpos + 1, s2, searchblock);
          until foundpos = 0; //loop while foundpos>0..

          //The closest position is now known: Score it!
          //Score as follows: (1-distance of best match)
          score := score + (1 - abs(string1pos - bestmatchpos));
        end;

        //Keep track if the maximum possible score
        //BE CAREFUL IF CHANGING THIS FUNCTION!!!

        //maxscore:=maxscore+1;
        inc(maxscore);
      end; //for position..
    end; //for size..

    if pass = 1 then
    begin
      //swap the strings around
      swapstring := s1;
      s1 := s2;
      s2 := swapstring;
    end;

    //Each pass is weighted equally

    scored := scored + (0.5 * (score / maxscore));
    score := 0;
    maxscore := 0;
  end; //for pass..

  //HowAlike=score/maxscore
  result := scored;
end;


Solve 4:

A Delphi implementation of the Levenshtein Distance Algorithm

unit Levenshtein;

{Objeto que calcula la distancia de Levenshtein entre 2 cadenas.
Alvaro Jeria Madariaga. 04/10/2002
barbaro@hotpop.com}

interface

uses
  sysutils, Math;

type
  Tdistance = class(TObject)
  private
    function minimum(a, b, c: Integer): Integer;
  public
    function LD(s, t: string): Integer;
  end;

implementation

function Tdistance.minimum(a, b, c: Integer): Integer;
var
  mi: Integer;
begin
  mi := a;
  if (b < mi) then
    mi := b;
  if (c < mi) then
    mi := c;
  Result := mi;
end;

function Tdistance.LD(s, t: string): Integer;
var
  d: array of array of Integer;
  n, m, i, j, costo: Integer;
  s_i, t_j: char;
begin
  n := Length(s);
  m := Length(t);
  if (n = 0) then
  begin
    Result := m;
    Exit;
  end;
  if m = 0 then
  begin
    Result := n;
    Exit;
  end;
  setlength(d, n + 1, m + 1);
  for i := 0 to n do
    d[i, 0] := i;
  for j := 0 to m do
    d[0, j] := j;
  for i := 1 to n do
  begin
    s_i := s[i];
    for j := 1 to m do
    begin
      t_j := t[j];
      if s_i = t_j then
        costo := 0
      else
        costo := 1;
      d[i, j] := Minimum(d[i - 1][j] + 1, d[i][j - 1] + 1, d[i - 1][j - 1] + costo);
    end;
  end;
  Result := d[n, m];
end;

end.

MessageDlg hidden by main form (XP only)

Problem/Question/Abstract:

When calling MessageDlg (and also on certain TForm forms on calling showModal) the dialog sometimes pops up under the main form, on Windows XP systems. This does not appear to affect other operating systems.

Answer:

Setting HKEY_CURRENT_USER\Control Panel\Desktop\ForegroundLockTimeout=0 seems to fix the problem... but WHY? According to MSDN (http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/WinUI/WindowsUserInterface/Windowing/Windows/WindowReference/WindowFunctions/SetForegroundWindow.asp) the new window should be able to go to the foreground if the process is the foreground process. The process was started by the foreground process. The process received the last input event. There is no foreground process. The foreground process is being debugged. The foreground is not locked (see LockSetForegroundWindow). The foreground lock time-out has expired (see SPI_GETFOREGROUNDLOCKTIMEOUT in SystemParametersInfo). Windows 2000/XP: No menus are active.

Ok, well having checked the last point there, calling Application.ProcessMessages before popping up the dialog fixes the problem!

---
This solution taken from the DOMAJ forum: http://www.domaj.com/forum/viewthread.php?tid=348

Case statement that *accepts* string values

Problem/Question/Abstract:

You've probably tried providing a Case statement with string type selector expression, to find out that it only takes ordinal types (which string is not).

The following function enables you to use the Case statement with string type variables:


Answer:

function StringToCaseSelect
(Selector : string;
CaseList: array of string): Integer;
var cnt: integer;
begin
Result:=-1;
for cnt:=0 to Length(CaseList)-1 do
begin
if CompareText(Selector, CaseList[cnt]) = 0 then
begin
Result:=cnt;
Break;
end;
end;
end;

{
Usage:

case StringToCaseSelect('Delphi',
['About','Borland','Delphi']) of
0:ShowMessage('You''ve picked About') ;
1:ShowMessage('You''ve picked Borland') ;
2:ShowMessage('You''ve picked Delphi') ;
end;
}

Create data-aware components

Problem/Question/Abstract:

How to create data-aware components

Answer:

This document describes minimal steps necessary to create a data-aware browsing component that displays data for a single field. The example component is a panel with DataSource and DataField properties similar to the TDBText component. See the Component Writer's Guide "Making a Control Data-Aware" for further examples.


Basic steps to create a data-browsing component

Create or derive a component that allows the display, but not the entry of data. For instance, you could use a TMemo with ReadOnly set to true. In the example outlined in this document, we'll use a TCustomPanel. The TCustomPanel will allow display, but not data entry.

Add a data-link object to your component. This object manages communication between the component and the database table.
Add DataField and DataSource properties to the component.
Add methods to get and set the DataField and DataSource.
Add a DataChange method the component to handle the data-link object's OnDataChange event.
Override the component constructor to create the datalink and hook up the DataChange method.
Override the component destructor to cleanup the datalink.




Creating the TDBPanel

Create or derive a component that allows the display, but not the entry of data. We'll be using a TCustomPanel as a starting point for this example.

Choose the appropriate menu option to create a new component (this will vary between editions of Delphi), and specify TDBPanel as the class name, and TCustomPanel as the Ancestor type. You may specify any palette page.

Add DB and DBTables to your Uses clause.

Add a data-link object to the components private section. This example will display data for a single field, so we will use a TFieldDataLink to provide the connection between our new component and a DataSource. Name the new data-link object FDataLink. Example:


private
FDataLink: TFieldDataLink;


Add DataField and DataSource properties to the component. We will add supporting code for the get and set methods in following steps. Note: Our new component will have DataField and DataSource properties and FDataLink will also have its own DataField and Datasource properties. Example:


published

property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;


Add private methods to get and set the DataField and DataSource property values to and from the DataField and DataSource for FDataLink. Example:


private
FDataLink: TFieldDataLink;

function GetDataField: string;
function GetDataSource: TDataSource;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);

implementation

function TDBPanel.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

function TDBPanel.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDBPanel.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;


Add a private DataChange method to be assigned to the datalink's OnDataChange event. In the DataChange method add code to display actual database field data provided by the data-link object. In this example, we assign FDataLink's field value to the panel's caption. Example:


private

procedure DataChange(Sender: TObject);

implementation

procedure TDBPanel.DataChange(Sender: TObject);
begin
  if FDataLink.Field = nil then
    Caption := '';
else
  Caption := FDataLink.Field.AsString;
end;


Override the component constructor Create method. In the implementation of Create, create the FDataLink object, and assign the private DataChange method to FDataLink's OnDataChange event. Example:


public

constructor Create(AOwner: TComponent); override;

implementation

constructor TMyDBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.OnDataChange := DataChange;
end;


Override the component destructor Destroy method. In the implementation of Destroy, set OnDataChange to nil (avoids a GPF), and free FDatalink. Example:


public

destructor Destroy; override;

implementation

destructor TDBPanel.Destroy;
begin
  FDataLink.OnDataChange := nil;
  FDataLink.Free;
  inherited Destroy;
end;


Save the unit and install the component (see the Users Guide, and the Component Writers Guide for more on saving units and installing components).

To test the functionality of the component, add a TTable, TDatasource, TDBNavigator and TDBPanel to a form. Set the TTable DatabaseName and Tablename to 'DBDemos' and 'BioLife', and the Active property to True. Set the TDatasource Dataset property to Table1. Set the TDBNavigator and TDBPanel DataSource property to Datasource1. The TDBpanel DataField name should be set as 'Common_Name'. Run the application and use the navigator to move between records to demonstrate the TDBPanel's ability to detect the change in data and display the appropriate field value.


Full source listing:


unit Mydbp;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, ExtCtrls, DB, DBTables;

type
  TDBPanel = class(TCustomPanel)
  private
    FDataLink: TFieldDataLink;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure DataChange(Sender: TObject);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TdataSource read GetDataSource write SetDataSource;
  end;

procedure Register;

implementation

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

function TDBPanel.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

function TDBPanel.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDBPanel.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;

procedure TDBPanel.DataChange(Sender: TObject);
begin
  if FDataLink.Field = nil then
    Caption := ''
  else
    Caption := FDataLink.Field.AsString;
end;

constructor TDBPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.OnDataChange := DataChange;
end;

destructor TDBPanel.Destroy;
begin
  FDataLink.Free;
  FDataLink.OnDataChange := nil;
  inherited Destroy;
end;

end.

Beep/Sound in Delphi

Problem/Question/Abstract:

Beep/Sound in Delphi

Answer:

The following assembler Routines implement sound output via port access and work therefore only with Win3.x and Win95/98. Simply call Sound(hz) with hz as frequency in Hz, and stop the sound output with NoSound().

If your application will run under Windows NT, you may use the operating system routine:

Windows.Beep(Frequency, Duration);


function InPort(PortAddr: word): byte; assembler; stdcall;
asm
  mov dx,PortAddr
  in al,dx
end;

procedure OutPort(PortAddr: word; Databyte: byte); assembler; stdcall;
asm
  mov al,Databyte
  mov dx,PortAddr
  out dx,al
end;

procedure Sound(Hz: Word);
var
  TmpW: Word;
begin
  OutPort($43, 182);
  TmpW := InPort($61);
  OutPort($61, TmpW or 3);
  OutPort($42, lo(1193180 div hz));
  OutPort($42, hi(1193180 div hz));
end;

procedure NoSound;
var
  TmpW: Word;
begin
  OutPort($43, 182);
  TmpW := InPort($61);
  OutPort($61, TmpW and 3);
end;

TIniFile ini files are limited to 64KB - how to go beyond 64KB

Problem/Question/Abstract:

TIniFile ini files are limited to 64KB - how to go beyond 64KB

Answer:

The TIniFile class uses the Windows API which imposes a limit of 64KB on INI files. If you need to store more than 64KB of data, you may want to use TMemIniFile instead. TMemIniFile does not have a limit of 64KB.

Important:

Remember to call the UpdateFile() method when you need the data to be written to disk: it does not do that automatically.

How to check if a date exists

Problem/Question/Abstract:

Is there a possibility to check if a date exists (e.g. 35.3.2001)?

Answer:

function DateExists(Date: string; Separator: char): Boolean;
var
  OldDateSeparator: Char;
begin
  Result := True;
  OldDateSeparator := DateSeparator;
  DateSeparator := Separator;
  try
    try
      StrToDate(Date);
    except
      Result := False;
    end;
  finally
    DateSeparator := OldDateSeparator;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if DateExists('35.3.2001', '.') then
  begin
    {your code}
  end;
end;

BDE error codes by code

Problem/Question/Abstract:

Show/generate the BDE errors list.

Answer:

The list of errors of the BDE, we can obtain it investigating a little in the file bde.int
There we will see that the error codes are composed of a value ' base' and of an offset.

Here you have an invention to generate your listing of errors of the BDE:

Add 'dbiprocs' in the uses of your form
Put a TRichEdit (RE1)
And put this in the OnClick of a TButton:

procedure TForm1.Button1Click(Sender: TObject);
const
  Bases:array [1..24] of integer=(
    0,$2100,$2200,$2300,$2400,$2500,$2600,$2700,$2800,
    $2900,$2A00,$2B00,$2C00,$2D00,$2E00,$2F00,$3000,
    $3100,$3200,$3300,$3400,$3500,$3E00,$3F00);
var
   ErrorCod:integer;
   ErrorTexto:array [0..DBIMAXMSGLEN+1] of char;
   i,n:integer;
begin
  for i:=1 to 24 do
    for n:=0 to 255 do
    begin
      ErrorCod:=Bases[i]+n;
      DbiGetErrorString(ErrorCod,ErrorTexto);
      if ErrorTexto<>'' then
        Re1.Lines.Add('$'+IntToHex(ErrorCod,4)+' ('+
                      IntToStr(ErrorCod)+') = '+ErrorTexto);
      Application.ProcessMessages;
    end;
end;

How to define the client area of a window

Problem/Question/Abstract:

Is it possible to define (set the size and position) of a window's client area (without resizing the window itself)? What I want to do is increase the non-client area to get more space to paint my own custom borders around a window. I want this to be reflected to the client area so that my border is protected from anything that goes on in the client area (painting, scrolling etc.).

Answer:

You have to handle the WM_NCCALCSIZE message on your form. See win32.hlp for details. The following example handler for a TListBox descendent excludes some space for a header bar from the listboxes client area:


procedure THeaderListbox.wmnccalcsize(var msg: TWMNCCALCSIZE);
begin
  inherited;
  if msg.CalcValidRects then
    with msg.CalcSize_Params^.rgrc[0] do
      top := top + Itemheight + 4;
end;


I hope you know how to define a message handler in the class declaration.

An approach to implement alternative C/S-like database solutions without having a C/S engine

Problem/Question/Abstract:

An approach to implement alternative C/S-like database solutions without having a C/S engine

Answer:

I just came from a successful demo to our client. I used ASTA as my messaging middleware together with DBISAM. I did not use the ASTADBISAM server, just the plain ASTAServerSocket.

Here's what I did: The main concept is that only the ASTAServer socket writes to the database tables. All the data that needed to be written come from the ASTA clients and received by ASTAServer socket which writes these information into the database. The Database Tables on the Server machine are shared across all clients as READ-ONLY. All my ASTAClient applications synchronizes the lookup tables through a shared file access and not trhough ASTA. These took advantage of the LAN situation. We tested with 40 clients connected (ASTA client and shared READ-ONLY), the database flies! I avoided using ClientDataSets and AstaClientDataSets. Then we began pulling the plug on some of the Client Machines, and never was there any corruption on the main data.

I am excited because all of the client programs behave as if they are all acting like a single-user local connections! With 40 online connections, it takes under a second to retrieve and post hundreds of detail records from the server, and 40 users doing all of it at the same time!

Now I am at a point of optimizing between a LAN (shared read-only database, TCP/IP write by AstaServerSocket) and a pure TCP/IP connectivity. I am trying to create a client program that will take advantage of a LAN connection whenever available (right now, this is set manually during the initial setup of the client program).

So are you saying that you are reading the data from the clients using standard DBISAM table and/or query components, then writing changes back to the database through ASTA? Can you give us a more concrete example of how you set this up?

The clients are reading the data read-only from a shared folder. Then they are modified on the temporary tables on the client side, then only the modified portions (deltas) are sent to the AstaServer through a coded paramlist. The Astaserver receives the coded paramlist and depending upon the code, parse the data into destination tables for updates or writes, inserts, appends, deletes. One thing nice, is I can code everything on the Server side through tables and filters, wrap it around transactions, and never have to worry about corruption anymore. It is the server which does the actual writing to the shared data. This way, no client would be able to delete the data by accident on the shared folder. Only the server has the wread/write access to the data. Only occassionally I have to send data back to the clients, through coded paramlist via the socket components, that is only when they are registered to be on a modem line. Otherwise, if they are on a LAN, it is always faster for the clients to read the shared tables from a READ-ONLY folder, because the client's computer can do their own individual buffering of the database tables at a far greater capacity and efficiency than routing everything through the socket layer. With respect to security, the password table on the sahred folder is encrypted with DBISAM's own encryption, but not only that, the data contents of fields themselves are individually encrypted with my own encryption, so no one is able to get passwords and user id, they may be able to get the password's table and read the data structure but not the contents which would remain garbled unless they know how to decrypt them using my own algo. This is very good security for me.

My setup was creating the data on the Win2000 server, then it is shared as read-only. Since the AstaServer resides on the Win2000, it is the only program that has direct read/ write privileges to the data unless you set it otherwise.

Here are samples of my client-side codes sent to the server from the client's temporary tables. The whole process really works at lightning speed.

procedure TDML.PostMTO(const aMTONO: integer; aNewStatus, aHeaders, aNotes: string);
var
  lnstr: string;
  MTOParams, RetParams: TAstaParamList;
begin
  Screen.Cursor := crHourGlass;
  RetParams := TAstaParamList.Create;
  MTOParams := TAstaParamList.Create;
  try
    LoadTmpList(pvMTmpList, pvWTmpList);
    MTOParams.Add;
    MTOParams[0].Name := UserLoginID;
    MTOParams[0].AsInteger := aMTONO;
    MTOParams.Add;
    MTOParams[1].Name := aNewStatus;
    MTOParams[1].AsString := aHeaders;
    MTOParams.FastAdd(aNotes);
    MTOParams.FastAdd(pvMTmpList.Text);
    MTOParams.FastAdd(pvWTmpList.Text);
    RetParams := AstaClientSocket1.SendGetCodedParamList(2100, MTOParams);
    lnstr := RetParams[0].AsString;
    ShowMessage('MTO successfully posted at server time: ' + lnstr);
  finally
    Screen.Cursor := crDefault;
    MTOParams.Free;
    RetParams.Free;
    pvMTmpList.Clear;
    pvWTmpList.Clear;
  end;
end;

And here is how a server could receive them and call the server's datamodule to write:

procedure TIsoFabForm.AstaServerSocket1CodedParamList(Sender: TObject;
  ClientSocket: TCustomWinSocket; MsgID: Integer; Params: TAstaParamList);
var
  i: integer;
  TmpStr, TmpStr2, ErrMsg, aUserID: string;
  MList, WList: TStringList;
begin
  case MsgID of
    {...}
    2100: {Post MTO}
      begin
        aUserID := Params[0].Name;
        i := Params[0].AsInteger; {MTONo}
        MList := TStringList.Create;
        WList := TStringList.Create;
        try
          MList.Text := Params[3].Text;
          WList.Text := Params[4].Text;
          DMServer.PostMTO(i, aUserID, Params[1].Name, Params[1].AsString,
            Params[2].AsString,
            MList, WList, True);
          Params.Clear;
          Params.FastAdd(Now);
          AstaServerSocket1.SendCodedParamList(ClientSocket, MsgID, Params);
        finally
          MList.Free;
          WList.Free;
        end;
      end;
    {....}

procedure TDMServer.PostMTO(const cMTONO: integer; aUserID, aNewStatus, aHeader,
  aNotes: string; var MList, WList: TStringList; BalanceStock: boolean);

  procedure PostItHere(const aTbl: TDBISAMTable; var aList: TStringList);
  var
    i, deltarecs: integer;
    lnstr: string;
  begin
    aTbl.IndexName := 'MTONO';
    aTbl.SetRange([cMTONo], [cMTONO]);
    DeltaRecs := aList.Count - aTbl.RecordCount;
    if DeltaRecs > 0 then
    begin
      for i := 1 to DeltaRecs do
      begin
        aTbl.Append;
        aTbl.FieldByName('MTONO').AsInteger := cMTONO;
        aTbl.Post;
      end;
    end;
    if DeltaRecs < 0 then
    begin
      aTbl.First;
      for i := 1 to -DeltaRecs do
        aTbl.delete;
    end;
    aTbl.First;
    for i := 0 to aList.Count - 1 do
    begin
      lnstr := aList[i];
      aTbl.Edit;
      aTbl.FieldByName('ItemNo').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('QCode').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('QtyNeed').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('QtyRel').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('QtyScraps').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('UnitCostRel').AsString := GetLeftWord(lnstr, #9);
      aTbl.FieldByName('TagNo').AsString := GetLeftWord(lnstr, #9);
      aTbl.Post;
      aTbl.Next;
    end;
    aList.Clear;
  end;

begin
  if cMTONO <= 0 then
    exit;
  if not DB1.InTransaction then
    DB1.StartTransaction;
  MTOMain.IndexName := 'MTONO';
  if not MTOMain.FindKey([cMTONO]) then
  begin
    MTOMain.Append;
    MTOMain.FieldByName('MTONo').AsInteger := cMTONO;
  end
  else
  begin
    MTOMain.Edit;
  end;
  GetLeftWord(aHeader, #9); {discard first column which is MTONO}
  MTOMain.FieldByName('Status').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('Project').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('Customer').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('ToolOrLateral').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('JobNo').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('SubJob').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DwgNo').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('SpoolNo').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('System').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('MaterialCode').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('LaborCode').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateNeeded').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateBuilt').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateShipped').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateDrawn').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateRevised').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('DateRecvd').AsString := GetLeftWord(aHeader, #9);
  MTOMain.FieldByName('SubmittedBy').AsString := aUserID;
  MTOMain.FieldByName('Notes').AsString := aNotes;
  MTOMain.Post;
  if (BalanceStock) and (MTOMain.FieldByName('Status').AsString <> 'DS') then
  begin
    RecomputeMTO(cMTONO, False); {subtract existing MTO Items}
  end;
  PostItHere(MTOItems, MList);
  PostItHere(WeldItems, WList);
  if BalanceStock then
  begin
    RecomputeMTO(cMTONO, True); {add to stock New MTO Items}
  end;
  if DB1.InTransaction then
    DB1.Commit;
end;

And of course, here is my versatile GetLeftWord function that can successively parse a given string into individual datafields or values:

function GetLeftWord(var ASentence: string; ADelimiter: char): string;
var
  i: integer;
begin
  Result := '';
  i := Pos(ADelimiter, ASentence);
  if i = 0 then
  begin
    Result := Trim(ASentence);
    ASentence := '';
    exit;
  end;
  if i = 1 then
    Result := ''
  else
    Result := trim(Copy(ASentence, 1, i - 1));
  Delete(ASentence, 1, i);
end;

I also made intensive use of routines like this to update any table, just pass it a series of strings:

procedure TDMServer.UpdateTable(var aTbl: TDBISAMTable; anIndexField, aFieldStr:
  string);
var
  anIndexValue, fldname, fldvalue: string;
begin
  aTbl.IndexName := anIndexField;
  anIndexValue := GetLeftWord(aFieldStr, #9);
  if aTbl.FindKey([anIndexValue]) then
  begin
    aTbl.Edit;
  end
  else
  begin
    aTbl.Append;
    aTbl.FieldByName(anIndexField).AsString := anIndexValue;
  end;
  while aFieldStr < > '' do
  begin
    fldname := GetLeftWord(aFieldStr, #9);
    fldvalue := GetLeftWord(aFieldStr, #9);
    if fldname = 'CDT' then
      continue;
    try
      aTbl.FieldByName(fldname).AsString := fldvalue;
    except
    end;
  end;
  aTbl.FieldByName('CDT').AsDateTime := Now;
  aTbl.Post;
  aTbl.FlushBuffers;
end;

That's a very interesting approach and I can see how it could speed things up yet still give you the data integrity you look for with a client server approach. I can also see where it could simplify some of the typical c/s user interface issues as well. For instance you could let a client open an entire table, then view and scroll through the data in a grid component without having to send all of that data through the pipeline. Obviously you wouldn't want your remote clients to do that, but such screens could easily be limited to only the people connected via LAN. It would also allow multiple large queries to run simultaneously (such as for reports) without slowing up everything else. If the main objective is server side control of data (such as enforcement of business rules) and elimination of corruption then this technique should work very well.

How to implement TCollection.SaveToStream

Problem/Question/Abstract:

I need to implement a streaming capability for a TCollection class object. Is there anyone who knows how to do it?

Answer:

I do it via the following two utility procedures:

procedure ReadCollection(s: TStream; c: TCollection);
var
  Reader: TReader;
begin
  Reader := TReader.Create(s, 1024);
  try
    Reader.ReadValue; {collection marker}
    Reader.ReadCollection(c);
  finally
    Reader.Free;
  end;
end;

procedure WriteCollection(s: TStream; c: TCollection);
var
  Writer: TWriter;
begin
  Writer := TWriter.Create(s, 1024);
  try
    Writer.WriteCollection(c);
  finally
    Writer.Free;
  end;
end;

Both procedures assume that the stream has been created and positioned correctly.

Ms Access LastinsertID

Problem/Question/Abstract:

Ever wondered how to retrieve the last insert id in MsAccess, of the autoincrement field from a table.

Answer:

We have a table in MsAccess like :

Test, Fields (id=autoinc, name=text);

First we have to have a function like the one below :

function GetLastInsertID: integer;
begin

  // datResult = TADODataSet

  datResult.Active := False;
  datResult.CommandText := 'select @@IDENTITY as [ID]';
  datResult.Active := True;

  Result := datResult.FieldByName('id').AsInteger;

  datResult.Active := False;

end;

Now before getting the last inserted record record id = autoincrement field, in other words calling the above function. You have to do a SQL insert like the following

procedure InsertRec;
begin

  // datCommand = TADOCommand

  datCommand.CommandText := 'insert into [test] ( [name] ) values ( "Test" )';
  datCommand.Execute;

end;

Now if we like to know which is the last autoinc value ( notice that the getlastinsertid proc. only works after the insertrec proc)

procedure Test;
begin
  InsertRec;
  Showmessage(format('lastinsertid : %d', [GetLastInsertID]));
end;

Hope you can make this work, it works for me, any questions feel free to ask