How to count the number of ones in a binary word

Problem/Question/Abstract:

How to count the number of ones in a binary word

Answer:

This was written (but not necessarily invented) by Paul King. The algorithm counts the number of ones in a binary word. You could of course just look at each bit and count how many of them are ones. But that takes as many cycles as the number of bits in a word. This clever algorithm takes as many cycles as the number of ones in the word, so on average is faster (unless all your data consists of words in which all the bits are ones). I don't know if it is well known, but I have frequently shown it to younger programmers, who are always surprised by it.

I only ever saw the algorithm in assembler, but as a recursive Pascal function it would be something like this. (Asssuming that X and Y gives the bitwise 'and' of X and Y).

function CountBits(X: word): integer;
{return the number of bits that are ones in X}
begin
  if (x = 0) then
    CountBits := 0
  else
    CountBits := 1 + CountBits(X and (X - 1));
end;

This works because if X is not zero, (X and (X-1)) always has exactly one fewer ones in it than X does.

Of course making it recursive would slow it down, so I suppose the non-recursive version would be better. Something like this:

function CountBits(X: word): integer;
{return number of bits that are ones in X}
var
  temp: word;
  result: integer;
begin
  temp := X;
  result := 0;
  while temp < > 0 do
  begin
    result := result + 1;
    temp := (temp and (temp - 1));
  end;
  CountBits := result;
end;


Your non-recursive implementation can be optimized a bit further. Modern (Delphi) Pascals have a built-in "result" variable within functions. Beyond other benefits, it makes renaming functions easier, too. No hunting through for other internal name references.

Also: If you're not making the parameter a const parameter, I find it easier to read (and more efficient?) to just use the parameter in the calculations. (No need for the temp var.) Delphi would probably optimize that immediately to a register variable/ parameter, too. I also expanded the parameter and temp var. to an integer; words are only 16 bits. Integers will "grow" with the compiler and available hardware support to the largest comfortably-handled integer size within the environment.

So you'd end up with something like:

function CountBits(X: integer): integer;
{return number of bits that are ones in X}
begin
  result := 0;
  while x < > 0 do
  begin
    inc(result);
    X := (X and (X - 1));
  end;
end;


I've seen this before, but it smacks of "tricks" (which I avoid) so I fear that when I needed it I did it the obvious way by a preprepared table:

function countbits(n: cardinal): integer;
const
  bytebits: array[0..255] of byte = (0, 1, 1, 2, 1, 2, 2, 3, 1...);
    {these values generated by your program??}
begin
  result := 0;
  repeat
    inc(result, bytebits[n and $FF];
      n := n shr 8;
  until
  n = 0;
end;

Should be a lot faster and you can trade off storage against speed by using a 4-bit, 8-bit, 12-bit
or 16-bit initial array.

Microsoft Access '97 password

Problem/Question/Abstract:

Get the MicroSoft Access '97 password.

Answer:

function GetMDB97PassWord(Filename: string): string;

const
  XorArr: array[0..12] of Byte = ($86, $FB, $EC, $37, $5D, $44, $9C, $FA, $C6, $5E,
    $28, $E6, $13);

var
  I: Integer;
  Arr: array[0..12] of Byte;
  S1: string;
  FI: file of Byte;
  By: Byte;
  Access97: Boolean;
  FileError: Boolean;

begin
  // Init
  FileError := False;
  Access97 := True;

  // Open file
  AssignFile(FI, Filename);
  Reset(FI);

  // Read file
  I := 0;
  repeat
    if not Eof(FI) then
    begin
      Read(FI, By);
      Inc(I);
    end;
  until (I = $42) or Eof(FI);
  if Eof(FI) then
    FileError := True;

  // Read password string
  for I := 0 to 12 do
    if not Eof(FI) then
      Read(FI, Arr[I]);

  if Eof(FI) then
    FileError := True;

  //Close file
  CloseFile(FI);

  // Read string in S1
  S1 := '';
  for I := 0 to 12 do
    S1 := S1 + Chr(Arr[I]);

  // Is nul string?
  if S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
    Access97 := False;

  // Decode string
  S1 := '';
  for I := 0 to 12 do
    S1 := S1 + Chr(Arr[I] xor XORArr[I]);

  // Find end of string
  I := 0;
  repeat
    Inc(I);
  until (S1[I] = #0) or (I = 14);
  if I <= 14 then
    S1 := Copy(S1, 1, I - 1);

  // Gather the results
  if Access97 then
  begin
    if Length(S1) > 0 then
      Result := 'The password is: ' + S1 + '.'
    else
      Result := 'The file is NOT password protected.';
  end
  else
    Result := 'The file is not an Access 97 file / wrong format.';

  if FileError then
    Result := 'File error';
end;

How to position the cursor on the right-hand side of a TEdit

Problem/Question/Abstract:

I want to write an Edit component, but I want the cursor to stay on the right when the user types in new characters.

Answer:

procedure TForm1.Edit1Change(Sender: TObject);
begin
  if IsChanging then
    exit; {Avoid recursion}
  IsChanging := true;
  try
    {Remove the first character}
    Edit1.Text := copy(Edit1.Text, 2, length(Edit1.Text) - 1);
    {And move the cursor to the end of the text}
    Edit1.SelStart := length(Edit1.Text);
  finally
    IsChanging := false;
  end;
end;

At design time (or in Create), put several spaces as Edit1.Text. They will be replaced one by one with characters typed by the user. IsChanging is a private variable of type boolean.

Detect if Excel is installed

Problem/Question/Abstract:

In the application I am writing I need to get data from an Excel spreadsheet and then insert it into a database. I am going to automate Excel. What I would like to know is how I can detect to see if excel is installed, and if it is, what version of Excel is on the user's computer. How can I do this?

Answer:

{ ... }
var
  ClassID: TCLSID;
  strOLEObject: string;
begin
  strOLEObject := 'Excel.Application';
  if (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) = S_OK) then
  begin
    {application is installed}
  end
  else
  begin
    {application is not installed}
  end
end;

To get the version, just read Version property of Excel.Application:

xls := CreateOLEObject('Excel.Application');
v := xls.Version;

How can I put a button on a form's caption bar?

Problem/Question/Abstract:

I've seen some programs that add text or buttons on the title bar of a form. How can I do this in Delphi?

Answer:

Introduction

I got my first insight into solving this problem when I wrote a previous tip that covered rolling up the client area of forms so that only the caption bar showed. In my research for that tip, I came across the WMSetText message that is used for drawing on a form's canvas. I wrote a sample application to test drawing in the caption area. The only problem with my original code was that the button would disappear when I resized or moved the form.

I turned to Delphi/Pascal guru Neil Rubenking for help. He pointed me in the direction of his book, Delphi Programming Problem Solver, which contains an example for doing this exact thing. The code below is an adaptation of the example in his book. The most fundamental difference between our examples is that I wanted to make a speedbutton with a bitmap glyph, and Neil actually drew a shape directly on the canvas. He also placed the button created in 16-bit Delphi on the left-hand side of the frame, and Win32 button placement was on the right. I wanted my buttons to be placed on the right for both versions, so I wrote appropriate code to handle that. The deficiency in my code was the lack of handlers for activation and painting in the non-client area of the form.

One thing I'm continually discovering is that there is a very definitive structure in Windows &mdash a definite hierarchy of functions. I've realized that the thing that makes Windows programming at the API level difficult is the sheer number of functions in the API set. For those who are reluctant to dive into the WinAPI, think in terms of categories first, then narrow your search. You'll find that doing it this way will make your life much easier.

What makes all of this work is Windows messages. The messages we're interested in here are not the usual Windows messages handled by plain-vanilla Windows apps, but are specific to an area of a window called the non-client area. The client area of a window is the part inside the border where most applications present information. The non-client area consists of the window's borders, caption bar, system menu and sizing buttons. The Windows messages that pertain to this area have the naming convention of WM_NCMessageType. Taking the name apart, 'WM' stands for Windows Message, 'NC' stands for Non-client area, and MessageType is the type of message being trapped. For example, WM_NCPaint is the paint message for the non-client area. Taking into account the hierarchical and categorical nature of the Windows API, nomenclature is a very big part of it; especially with Windows messages. If you look in the help file under messages, peruse through the list of messages and you will see the order that is followed.

Let's look at a list of things that we need to consider to add a button to the title bar of a form:

We need to have a function to draw the button.
We'll have to trap drawing and painting events so that our button stays visible when the form activates, resizes or moves.
We're dropping a button on the title bar, so we have to have a way of trapping for a mouse click on the button.

I'll now discuss these topics, in the above order.

Drawing a TRect as a Button

You can't drop VCL objects onto a non-client area of a window, but you can draw on it and simulate the appearance of a button. In order to perform drawing in the title bar of a window, you have to do three very important things, in order:

You must get the current measurements of the window and the size of the frame bitmaps so you know what area to draw in and how big to draw the rectangle.
Then you have to define a TRect structure with the proper size and position within the title bar.
Finally, you have to draw the TRect to appear as a button, then add any glyphs or text you might want to draw to the buttonface.

All of this is accomplished in a single call. For this program we make a call to the DrawTitleButton procedure, which is listed below:

procedure TTitleBtnForm.DrawTitleButton;
var
  bmap: TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}
  XFrame, {X and Y size of Sizeable area of Frame}
  YFrame,
  XTtlBit, {X and Y size of Bitmaps in caption}
  YTtlBit: Integer;
begin
  {Get size of form frame and bitmaps in title bar}
  XFrame := GetSystemMetrics(SM_CXFRAME);
  YFrame := GetSystemMetrics(SM_CYFRAME);
  XTtlBit := GetSystemMetrics(SM_CXSIZE);
  YTtlBit := GetSystemMetrics(SM_CYSIZE);

{$IFNDEF WIN32}
  TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
    YFrame - 1,
    XTtlBit + 2,
    YTtlBit + 2);

{$ELSE} {Delphi 2.0 positioning}
  if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
    TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
      YFrame - 1,
      XTtlBit + 2,
      YTtlBit + 2)
  else
    TitleButton := Bounds(Width - XFrame - 4 * XTtlBit + 2,
      XFrame + 2,
      XTtlBit + 2,
      YTtlBit + 2);
{$ENDIF}

  Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}
  try
    {Draw a button face on the TRect}
    DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);
    bmap := TBitmap.Create;
    bmap.LoadFromFile('help.bmp');
    with TitleButton do
{$IFNDEF WIN32}
      Canvas.Draw(Left + 2, Top + 2, bmap);
{$ELSE}
      if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
        Canvas.Draw(Left + 2, Top + 2, bmap)
      else
        Canvas.StretchDraw(TitleButton, bmap);
{$ENDIF}

  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    bmap.Free;
    Canvas.Handle := 0;
  end;
end;

Step 1 above is accomplished by making four calls to the WinAPI function GetSystemMetrics, asking the system for the width and height of the window that can be sized (SM_CXFRAME and SM_CYFRAME), and the size of the bitmaps contained on the title bar (SM_CXSIZE and SM_CYSIZE).

Step 2 is performed with the Bounds function, which returns a TRect defined by the size and position parameters that are supplied to it. Notice that I used some conditional compiler directives here. This is because the size of the title bar buttons in Windows 95 and Windows 3.1 are different, so they have to be sized differently. And since I wanted to be able to compile this in either version of Windows, I used a test for the predefined symbol, WIN32, to see which version of Windows the program is compiled under. However, since the Windows NT UI is the same as Windows 3.1, it's necessary to grab further version information under the Win32 conditional to see if the Windows version is Windows NT. If so, we define the TRect to be just like the Windows 3.1 TRect.

To perform Step 3, we make a call to the Buttons unit's DrawButtonFace to draw button features within the TRect that we defined. As added treat, I included code to draw a bitmap in the button. You'll see that I used a conditional compiler directive to draw the bitmap under different versions of Windows. I did this because the bitmap I used was 16x16 pixels, which might be too big for Win95 buttons. So I used StretchDraw under Win32 to stretch the bitmap to the size of the button.

Trapping the Drawing and Painting Events

You must make sure that the button will stay visible every time the form repaints itself. Painting occurs in response to activation and resizing, which fire off paint and text setting messages that will redraw the form. If you don't have a facility to redraw your button, you'll lose it every time a repaint occurs. So what we have to do is write event handlers which will perform their default actions and redraw our button when they fire off. The following four procedures handle the paint triggering and painting events:

{Paint triggering events}

procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);
begin
  inherited;
  DrawTitleButton;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

{Painting events}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
begin
  inherited;
  DrawTitleButton;
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
  inherited;
  DrawTitleButton;
end;

Every time one of these events fires off, it makes a call to the DrawTitleButton procedure. This will ensure that our button is always visible on the title bar. Notice that we use the default handler OnResize on the form to force it to perform a WM_NCACTIVATE.

Handling Mouse Clicks

Now that we've got code that draws our button and ensures that it's always visible, we have to handle mouse clicks on the button. The way we do this is with two procedures. The first procedure tests to see if the mouse click was in the area of our button, then the second procedure actually performs the code execution associated with our button. Let's look at the code:

{Mouse-related procedures}

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  {Check to see if the mouse was clicked in the area of the button}
  with Msg do
    if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then
      Result := htTitleBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htTitleBtn) then
    ShowMessage('You pressed the new button');
end;

The first procedure WMNCHitTest(var Msg : TWMNCHitTest) is a hit tester message to determine where the mouse was clicked in the non-client area. In this procedure we test if the point defined by the message was within the bounds of our TRect by using the PtInRect function. If the mouse click was performed in the TRect, then the result of our message is set to htTitleBtn, which is a constant that was declared as htSizeLast + 1. htSizeLast is a hit test constant generated by hit test events to test where the last hit occurred.

The second procedure is a custom handler for a left mouse click on a button in the non-client area. Here we test if the hit test result was equal to htTitleBtn. If it is, we show a message. You can make any call you choose to at this point.

Putting it All Together

Let's look at the entire code in the form to see how it all works together:

unit Capbtn;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Buttons;

type
  TTitleBtnForm = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    TitleButton: TRect;
    procedure DrawTitleButton;
    {Paint-related messages}
    procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
    {Mouse down-related messages}
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
    function GetVerInfo: DWORD;
  end;

var
  TitleBtnForm: TTitleBtnForm;

const
  htTitleBtn = htSizeLast + 1;

implementation
{$R *.DFM}

procedure TTitleBtnForm.DrawTitleButton;
var
  bmap: TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}
  XFrame, {X and Y size of Sizeable area of Frame}
  YFrame,
    XTtlBit, {X and Y size of Bitmaps in caption}
  YTtlBit: Integer;
begin
  {Get size of form frame and bitmaps in title bar}
  XFrame := GetSystemMetrics(SM_CXFRAME);
  YFrame := GetSystemMetrics(SM_CYFRAME);
  XTtlBit := GetSystemMetrics(SM_CXSIZE);
  YTtlBit := GetSystemMetrics(SM_CYSIZE);

{$IFNDEF WIN32}
  TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
    YFrame - 1,
    XTtlBit + 2,
    YTtlBit + 2);

{$ELSE} {Delphi 2.0 positioning}
  if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
    TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
      YFrame - 1,
      XTtlBit + 2,
      YTtlBit + 2)
  else
    TitleButton := Bounds(Width - XFrame - 4 * XTtlBit + 2,
      XFrame + 2,
      XTtlBit + 2,
      YTtlBit + 2);
{$ENDIF}

  Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}
  try
    {Draw a button face on the TRect}
    DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);
    bmap := TBitmap.Create;
    bmap.LoadFromFile('help.bmp');
    with TitleButton do
{$IFNDEF WIN32}
      Canvas.Draw(Left + 2, Top + 2, bmap);
{$ELSE}
      if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
        Canvas.Draw(Left + 2, Top + 2, bmap)
      else
        Canvas.StretchDraw(TitleButton, bmap);
{$ENDIF}

  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    bmap.Free;
    Canvas.Handle := 0;
  end;
end;

{Paint triggering events}

procedure TTitleBtnForm.WMNCActivate(var Msg: TWMNCActivate);
begin
  inherited;
  DrawTitleButton;
end;

procedure TTitleBtnForm.FormResize(Sender: TObject);
begin
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

{Painting events}

procedure TTitleBtnForm.WMNCPaint(var Msg: TWMNCPaint);
begin
  inherited;
  DrawTitleButton;
end;

procedure TTitleBtnForm.WMSetText(var Msg: TWMSetText);
begin
  inherited;
  DrawTitleButton;
end;

{Mouse-related procedures}

procedure TTitleBtnForm.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  {Check to see if the mouse was clicked in the area of the button}
  with Msg do
    if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then
      Result := htTitleBtn;
end;

procedure TTitleBtnForm.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htTitleBtn) then
    ShowMessage('You pressed the new button');
end;

function TTitleBtnForm.GetVerInfo: DWORD;
var
  verInfo: TOSVERSIONINFO;
begin
  verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(verInfo) then
    Result := verInfo.dwPlatformID;
  {Returns:
    VER_PLATFORM_WIN32s             Win32s on Windows 3.1
    VER_PLATFORM_WIN32_WINDOWS        Win32 on Windows 95
    VER_PLATFORM_WIN32_NT           Windows NT }
end;

end.

Suggestions for Exploring

You might want to play around with this code a bit to customize it to your own needs. For instance, if you want to add a bigger button, add pixels to the XTtlBit var. You can also mess around with creating a floating toolbar that is purely on the title bar. Also, now that you have a means of interrogating what's going on in the non-client area of the form, you might want to play around with the default actions taken with the other buttons like the System Menu button to perhaps display your own custom menu.

Take heed, though: Playing around with Windows messages can be dangerous. Save your work constantly, and be prepared for some system crashes while you experiment.

Getting a list of installed services

Problem/Question/Abstract:

Want to get a list of active, inactive or all Windows services?

Answer:

Following function can help you to do this, but be sure to read other Windows services related tips for details.

const
  //
  // Service Types
  //
  SERVICE_KERNEL_DRIVER = $00000001;
  SERVICE_FILE_SYSTEM_DRIVER = $00000002;
  SERVICE_ADAPTER = $00000004;
  SERVICE_RECOGNIZER_DRIVER = $00000008;

  SERVICE_DRIVER =
    (SERVICE_KERNEL_DRIVER or
    SERVICE_FILE_SYSTEM_DRIVER or
    SERVICE_RECOGNIZER_DRIVER);

  SERVICE_WIN32_OWN_PROCESS = $00000010;
  SERVICE_WIN32_SHARE_PROCESS = $00000020;
  SERVICE_WIN32 =
    (SERVICE_WIN32_OWN_PROCESS or
    SERVICE_WIN32_SHARE_PROCESS);

  SERVICE_INTERACTIVE_PROCESS = $00000100;

  SERVICE_TYPE_ALL =
    (SERVICE_WIN32 or
    SERVICE_ADAPTER or
    SERVICE_DRIVER or
    SERVICE_INTERACTIVE_PROCESS);

uses WinSvc;

//-------------------------------------
// Get a list of services
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \\SERVER
//   empty = local machine
//
// dwServiceType
//   SERVICE_WIN32,
//   SERVICE_DRIVER or
//   SERVICE_TYPE_ALL
//
// dwServiceState
//   SERVICE_ACTIVE,
//   SERVICE_INACTIVE or
//   SERVICE_STATE_ALL
//
// slServicesList
//   TStrings variable to storage
//

function ServiceGetList(
  sMachine: string;
  dwServiceType,
  dwServiceState: DWord;
  slServicesList: TStrings)
  : boolean;
const
  //
  // assume that the total number of
  // services is less than 4096.
  // increase if necessary
  cnMaxServices = 4096;

type
  TSvcA = array[0..cnMaxServices]
    of TEnumServiceStatus;
  PSvcA = ^TSvcA;

var
  //
  // temp. use
  j: integer;

  //
  // service control
  // manager handle
  schm: SC_Handle;

  //
  // bytes needed for the
  // next buffer, if any
  nBytesNeeded,

  //
  // number of services
  nServices,

  //
  // pointer to the
  // next unread service entry
  nResumeHandle: DWord;

  //
  // service status array
  ssa: PSvcA;
begin
  Result := false;

  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    nil,
    SC_MANAGER_ALL_ACCESS);

  // if successful...
  if (schm > 0) then
  begin
    nResumeHandle := 0;

    New(ssa);

    EnumServicesStatus(
      schm,
      dwServiceType,
      dwServiceState,
      ssa^[0],
      SizeOf(ssa^),
      nBytesNeeded,
      nServices,
      nResumeHandle);

    //
    // assume that our initial array
    // was large enough to hold all
    // entries. add code to enumerate
    // if necessary.
    //

    for j := 0 to nServices - 1 do
    begin
      slServicesList.
        Add(StrPas(
        ssa^[j].lpDisplayName));
    end;

    Result := true;

    Dispose(ssa);

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;
end;

To get a list of all Windows services into a listbox named ListBox1:

ServiceGetList('', SERVICE_WIN32, SERVICE_STATE_ALL, ListBox1.Items);

Delphi IDE freezes every 5 minutes for one minute

Problem/Question/Abstract:

My Delphi IDE freezes every five or six minutes for approximately 50 seconds. While the IDE is frozen, I can switch to any other application &#8211; they all respond normally. The IDE is completely unresponsive during the freeze, for example it does not repaint its windows. After the 50-second-freeze the IDE behaves fine for five minutes until it freezes again. This effect was seen on an installation of the demo version of Delphi 5.

Answer:

As a first guess, I would turn off Delphi Direct. Do you have a permanent Internet connection? Maybe something is configured wrong and Delphi tries repeatedly to connect to www.Borland.com. You can turn off Delphi Direct in Tools | Environment Options

The freeze may occur because you have a bad directory in your (library) search path. Check all directories in your paths and make sure that all drives are actually mapped. The 50-second-freeze sounds like Windows tries to open a network connection. It could also be that a directory/ drive name points to a CD-ROM now and there is no CD in it or it contains a different CD than expected. Trim your paths to what is needed.

You may want to find out what is installed in your IDE that makes it searches your path periodically. I recommend de-activating as many packages as you can. This is done via Components | Packages.

The fact that it is a demo version should not be relevant. Good luck!

How to handle multiple, simultaneous key presses

Problem/Question/Abstract:

If I want to write a simple game where you can move and shoot at the same time, what would be the best way of handling the multiple key presses?

Answer:

unit KeysForm;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Keys: array[Byte] of Boolean;

implementation

{$R *.DFM}

procedure TForm1.Timer1Timer(Sender: TObject);
var
  KeyNum, c: Integer;
begin
  for KeyNum := 0 to 255 do
  begin
    c := Ord(Keys[KeyNum]) * 255;
    Canvas.Pixels[KeyNum * 2, 10] := RGB(c, c, c);
    Canvas.Pixels[KeyNum * 2 + 1, 10] := RGB(c, c, c);
    Canvas.Pixels[KeyNum * 2 + 1, 11] := RGB(c, c, c);
    Canvas.Pixels[KeyNum * 2, 11] := RGB(c, c, c);
  end;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  Keys[Key] := True;
  Key := 0;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  Keys[Key] := False;
  Key := 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  KeyNum: Integer;
begin
  for KeyNum := 0 to 255 do
    Keys[KeyNum] := False;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) then
    Keys[VK_LBUTTON] := True
  else if (Button = mbMiddle) then
    Keys[VK_MBUTTON] := True
  else if (Button = mbRight) then
    Keys[VK_RBUTTON] := True;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) then
    Keys[VK_LBUTTON] := False
  else if (Button = mbMiddle) then
    Keys[VK_MBUTTON] := False
  else if (Button = mbRight) then
    Keys[VK_RBUTTON] := False;
end;

end.

How to intercept a click on the forms' minimize button

Problem/Question/Abstract:

Does anybody know how to capture the minimize button press and act on it before it actually minimizes the form?

Answer:

You should intercept WM_SYSCOMMAND messages like this:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  public
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
  if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
    MessageBeep(0);
  DefaultHandler(Msg);
end;

end.

Credit Card Validation (2)

Problem/Question/Abstract:

How can I know if a number is a valid credit card number?

Answer:

The following unit can be used to make credit card verification

unit Creditc;

{*****************************************************************************

Credit Card Number Validator Unit for Delphi

Version: 1.1
Date: December 20, 1996

This unit is based on the public domain program ccard by Peter Miller.
It is released to the public for free of charge use, but the author
reserves all rights.

copyright 1996 by Shawn Wilson Harvell ( shawn@inet.net )

usage:

Add this unit to the uses clause of any unit that needs access to the
validation function.

IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean

for example, use it in an if statement that Messages user if invalid.

CardNumber is a string containing the number that you want to validate
ReturnMessage is a string where the function can place any messages it
may return ( meaning that it will overwrite whatever is in it )

returns true if valid, false otherwise.

dashes and space in the input value are taken care of by the function,
if other characters are possible, you may wish to remove them as well.
The function RemoveChar will take care of this quite easily, simply
pass the input string and the char you wish to delete.

Users are free to modify this unit for their own use, but in
distributing you should advise all users of the changes made.

Use this unit at your own risk, it does not come with any warranties
either express or implied. Damages resulting from the use of this
unit are the sole responsibility of the user.

This should work as is for Delphi versions 1 and 2, some slight
modifications may be necessary for Turbo Pascal ( mainly due to use to
conversion functions from the SysUtils unit ).

If you do find this useful, have any comments or suggestions, please
drop the author an email at shawn@inet.net

Revision History

version 1.1 -- December 20, 1996
blooper with Discover cards, added their length mask to the "database"

version 1.0 -- October 26, 1996
initial release

*****************************************************************************}

interface

uses SysUtils;

function IsValidCreditCardNumber(CardNumber: string; var MessageText: string): Boolean;

implementation

const
  CardPrefixes: array[1..19] of string =
  ('2014', '2149', '300', '301', '302',
    '303', '304', '305', '34', '36', '37',
    '38', '4', '51', '52', '53', '54', '55', '6011');

  CardTypes: array[1..19] of string =
  ('enRoute',
    'enRoute',
    'Diner Club/Carte Blanche',
    'Diner Club/Carte Blanche',
    'Diner Club/Carte Blanche',
    'Diner Club/Carte Blanche',
    'Diner Club/Carte Blanche',
    'Diner Club/Carte Blanche',
    'American Express',
    'Diner Club/Carte Blanche',
    'American Express',
    'Diner Club/Carte Blanche',
    'Visa',
    'MasterCard',
    'MasterCard',
    'MasterCard',
    'MasterCard',
    'MasterCard',
    'Discover');

function RemoveChar(const Input: string; DeletedChar: Char): string;
var
  Index: Word; { counter variable }
begin
  { all this function does is iterate through string looking for char, if found }
  { it deletes it }
  Result := Input;
  for Index := Length(Result) downto 1 do
    if Result[Index] = DeletedChar then
      Delete(Result, Index, 1);
end;

function ShiftMask(Input: Integer): Integer;
begin
  { simply a wrapper for this left bit shift operation }
  result := (1 shl (Input - 12));
end;

function ConfirmChecksum(CardNumber: string): Boolean;
var
  CheckSum: Integer; { Holds the value of the operation }
  Flag: Boolean; { used to indicate when ready }
  Counter: Integer; { index counter }
  PartNumber: string; { used to extract each digit of number }
  Number: Integer; { used to convert each digit to integer }
begin

  {**************************************************************************
  This is probably the most confusing part of the code you will see, I know
  that it is some of the most confusing I have ever seen. Basically, this
  function is extracting each digit of the number and subjecting it to the
  checksum formula established by the credit card companies. It works from
  the end to the front.
  **************************************************************************}

  { get the starting value for our counter }
  Counter := Length(CardNumber);
  CheckSum := 0;
  PartNumber := '';
  Number := 0;
  Flag := false;

  while (Counter >= 1) do
  begin
    { get the current digit }
    PartNumber := Copy(CardNumber, Counter, 1);
    Number := StrToInt(PartNumber); { convert to integer }
    if (Flag) then { only do every other digit }
    begin
      Number := Number * 2;
      if (Number >= 10) then
        Number := Number - 9;
    end;
    CheckSum := CheckSum + Number;

    Flag := not (Flag);

    Counter := Counter - 1;
  end;

  result := ((CheckSum mod 10) = 0);
end;

function GetMask(CardName: string): Integer;
begin
  { the default case }
  result := 0;

  if (CardName = 'MasterCard') then
    result := ShiftMask(16);
  if (CardName = 'Visa') then
    result := (ShiftMask(13) or ShiftMask(16));
  if (CardName = 'American Express') then
    result := ShiftMask(15);
  if (CardName = 'Diner Club/Carte Blanche') then
    result := ShiftMask(14);
  if (CardName = 'Discover') then
    result := ShiftMask(16);

end;

function IsValidCreditCardNumber(CardNumber: string; var MessageText: string):
  Boolean;
var
  StrippedNumber: string; { used to hold the number bereft of extra chars }
  Index: Integer; { general purpose counter for loops, etc }
  TheMask: Integer; { number we will use for the mask }
  FoundIt: Boolean; { used to indicate when something is found }
  CardName: string; { stores the name of the type of card }
  PerformChecksum: Boolean; { the enRoute type of card doesn't get it }
begin

  { first, get rid of spaces, dashes }
  StrippedNumber := RemoveChar(CardNumber, ' ');
  StrippedNumber := RemoveChar(StrippedNumber, '-');

  { if the string was zero length, then OK too }
  if (StrippedNumber = '') then
  begin
    result := true;
    exit;
  end;

  { initialize return variables }
  MessageText := '';
  result := true;

  { set our flag variable }
  FoundIt := false;

  { check for invalid characters right off the bat }
  for Index := 1 to Length(StrippedNumber) do
  begin
    case StrippedNumber[Index] of
      '0'..'9': FoundIt := FoundIt; { non op in other words }
    else
      MessageText := 'Invalid Characters in Input';
      result := false;
      exit;
    end;
  end;

  { now let's determine what type of card it is }
  for Index := 1 to 19 do
  begin
    if (Pos(CardPrefixes[Index], StrippedNumber) = 1) then
    begin
      { we've found the right one }
      FoundIt := true;
      CardName := CardTypes[Index];
      TheMask := GetMask(CardName);
    end;
  end;

  { if we didn't find it, indicates things are already ary }
  if (not FoundIt) then
  begin
    CardName := 'Unknown Card Type';
    TheMask := 0;
    MessageText := 'Unknown Card Type ';
    result := false;
    exit;
  end;

  { check the length }
  if ((Length(StrippedNumber) > 28) and result) then
  begin
    MessageText := 'Number is too long ';
    result := false;
    exit;
  end;

  { check the length }
  if ((Length(StrippedNumber) < 12) or
    ((shiftmask(length(strippednumber)) and themask) = 0)) then
  begin
    messagetext := 'number length incorrect';
    result := false;
    exit;
  end;

  { check the checksum computation }
  if (cardname = 'enroute') then
    performchecksum := false
  else
    performchecksum := true;

  if (performchecksum and (not confirmchecksum(strippednumber))) then
  begin
    messagetext := 'bad checksum';
    result := false;
    exit;
  end;

  { if result is still true, then everything is ok }
  if (result) then
    messagetext := 'number ok: card type: ' + cardname;

  { if the string was zero length, then ok too }
  if (strippednumber = '') then
    result := true;

end;

end.

Creating a system tray application

Problem/Question/Abstract:

How I can make my application not appear on the main display and but just in the system tray on startup?

Answer:

You could use RxLib (freeware component collection) - it contains a component that does this. Drop the RxTrayIcon component on your main form and minimize/ hide your application with this code:

ShowWindow(Application.Handle, SW_HIDE);
Application.Minimize;

If using RxLib is not an option, then you can build it yourself with the ShellAPI function Shell_NotifyIcon(). Use the application from below as a starting point.

  
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    Open1: TMenuItem;
    Exit1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { private declarations }
    procedure WndProc(var Msg: TMessage); override;
  public
    { public declarations }
    IconData: TNotifyIconData;
    IconCount: integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc(var Msg: TMessage);
var
  aPoint: TPoint;
begin
  case Msg.Msg of
    WM_USER + 1:
      case Msg.lParam of
        WM_RBUTTONDOWN:
          begin
            SetForegroundWindow(Handle);
            GetCursorPos(aPoint);
            PopupMenu1.Popup(aPoint.x, aPoint.y);
            PostMessage(Handle, WM_NULL, 0, 0);
          end
      end;
  end;
  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BorderIcons := [biSystemMenu];
  IconCount := 0;
  IconData.cbSize := sizeof(IconData);
  IconData.Wnd := Handle;
  IconData.uID := 100;
  IconData.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
  IconData.uCallbackMessage := WM_USER + 1;
  IconData.hIcon := Application.Icon.Handle;
  StrPCopy(IconData.szTip, Application.Title);
  Shell_NotifyIcon(NIM_ADD, @IconData);
end;

procedure TForm1.Open1Click(Sender: TObject);
begin
  Form1.Show;
  ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_DELETE, @IconData);
  Application.ProcessMessages;
  Application.Terminate;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caNone;
  Form1.Hide;
end;

begin
  ShowWindow(Application.Handle, SW_HIDE);
end;

DSOAP, ADO and XML

Problem/Question/Abstract:

DSOAP, ADO and XML

Answer:

Introduction

Developing distributed applications is a big shift from the client/server world. The traditional client/server model is based on the assumption that a client application can open a database connection and hold it until the task is terminated. While this approach simplifies the task of programmers, it tremendously impacts scalability and maintenance. There are multiple reasons for this: Hardware is a finite resource: for the big a server can be, it's very easy to terminate its resources as the number of connected and concurrent clients increase. Database licenses are expensive and for each client a license is being used. It is not easy if not impossible in some situations to effectively load balance the database tier. Finally, by using a two tier model, business rules are coded in either the client or the database via stored procedures. It is difficult to update these two tiers. Technologies such as COM+ and Corba or frameworks such as Java's J2EE and Microsoft .Net push towards the development of distributed systems and provide the necessary infostructure to build scalable multi-tier systems. Regardless of your needs (LAN or Internet) by developing a multi-tier system you will have a product that is much easier to update and scale (both up or out). Before jumping to the example, I want to reserve a few words to two very important aspects of efficient multi tier development: Client independence: If your middle tier (the one that contains business logic) is accessed by both web and desktop clients, you need to plan ahead and make sure it will work with both. Web clients are very different from desktop clients. The architecture of HTTP makes them implicitly stateless and there's no preservation of state between an HTML page and the other. Internet Information Server has a Session object that can help you storing values of any type (simple data types as well as COM objects) and keeping them until the user keeps his/her browser open. Unfortunately, if you have a cluster of webservers (web farm), this information is not propagated across the servers. Using IIS Session object is not a good idea in a clustered environment. You will need to use other techniques to store client's state. You need to design your middle tier using patterns that do not depend on any specific capability of the clients that will use it. Preferabily you should conform to the lowest denominator which is the web client. I will cover this topic in another article but for now let's continue with the other key requirement. Openness: In a world of web services like the one we are moving towards you don't know who or what will access your system. This is another reason for being client independent but it creates another requirement for successful multi-tier development: when facing the outside world, you need to use open standards that are globally accepted and used. Do not expect your clients will be able to use ADO Recordsets or communicate via Corba. The standards are represented today by SOAP and XML.

The example

The following example illustrates how to retrieve data from the Northwind sample database included in SQL Server. We will create a business object that queries the database using ADO and generates an XML streams that is used by the client for data presentation/manipulation. On the client we will access this XML stream using a common ADO Recordset (I will use the TADODataset included in ADOExpress). Finally, when we are done modifiying the data we will convert the recordset in XML and send it back to the business object. Finally, this will update the database. All this will be done using SOAP. The XML that ADO generates is perfectly usable from any type client. A Java client could use it as well after converting it into a format it's more convenient.

How to install the sample

In my previous article DSOAP Toolkit I explained how you create a COM object and how you expose this to the world using the Microsoft SOAP SDK. In this article I will focus on the implementation of the business object. I will show how you can convert an ADO Recordset in XML and vice versa. I incuded the WSDL and WSML files in the zip so you will not need to recreate them. Download the example, register the ActiveX library DSOAPXMLLib.dll and move the WSDL and WSML files under c:\inetpub\wwwroot. When you are done with this, open the client application and test the webservice by pressing the "Get Customers" button. I assume your computer has SQL Server installed. If SQL Server is installed on a remote machine, modify the constant DBConnStr in the unit uCustomersDataObject_Impl.pas before registering the ActiveX library and launcing the client application. If you need to change the folder where the WSDL file will be contained, make sure you update the URL specified at the end of it top match the new directory.

The business object

The ActiveX library contains one COM object called CustomersDataObject. Its interface contains only two methods (GetCustomers and UpdateCustomers) as shown below:



GetCustomers is declared as:

function GetCustomers(const aFilter: WideString; out Errors: WideString): WideString;

The "aFilter" parameter takes a valid SQL WHERE condition such as "CustomerID line 'A%' " without the WHERE keyword. You will use this to filter the amount of data you want to receive. The method returns the XML generated by an ADO Recordset. UpdateCustomers is declared as:

function UpdateCustomers(const someChanges: WideString; out Errors: WideString):
  WordBool;

The parameter someChanges takes the delta of changes that have been committed on the client and updates the database. It will return TRUE if succesful or FALSE if it failed. Notice the out parameter Errors in both methods. This is not required in order to handle error notification. As I explained in my other article Using SOAP with Delphi, the protocol defines a standard way to report errors. If an exception would be raise on the client, the Microsoft SOAP SDK would trap it and encode it in a SOAP error condition which would then be reraised client side. Sometimes I prefer to trap everything myself. By doing this you could log every error in a database table and have more control over things. Still, leaving the exception unhandled, is a valid approach as well.

Streaming a Recordset in XML

Streaming a Recordset in XML is a matter of calling the Recordset.Save method passing an object that implements IStream as parameter. You can use the ADO Stream or the XMLDOMDocument object for this porpouse. The second one is generally faster because it uses UTF8 encoding (1 byte character) and is optimized for XML processing. The ADO Stream instead works with UTF16 encoding (try saving both XML streams to a file and see the difference in size. I realized this thanks to the comments of Shiv Kumar. Have a look at his site at http://www.matlus.com In the unit uADOCommon.pas you will find the following function that, given a connection string and a SQL command, creates a Recordset and converts it into XML:

function SQLToXML(const aConnection: OleVariant; const aSQLCommand: string): string;
var
  rs: _Recordset;
  xml: IXMLDOMDocument2;
begin
  // Creates a disconnected recordset that will be streamed into XML
  rs := CoRecordset.Create;
  rs.CursorLocation := adUseClient;
  rs.Open(aSQLCommand, aConnection, adOpenForwardOnly, adLockBatchOptimistic, 0);
  rs.Set_ActiveConnection(nil);

  // Streams _Recordset into XML
  xml := CoDOMDocument30.Create;
  rs.Save(xml, adPersistXML);
  rs.Close;

  result := xml.xml;
end;

Pay special attention to the line in which I call the Recordset's Open method. I specified adOpenForwardOnly as cursor type. This has an immediate effect on performances while querying data from a SQL database. Generally speaking, the more flexible the cursor you open, the slower and more resource intensive it will be. Take a look at the article SQL Server Cursor library if you want to know more about the subject. Another important thing I did in the function above is to set the Recordset's connection to NIL and the CursorLocation to adUseClient. When using this combination of values you will generate a disconnected, client side Recordset. The resulting XML will look like this:

<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882" xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882" xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
<s:Schema id="RowsetSchema">
  <s:ElementType name="row" content="eltOnly" rs:updatable="true">
   <s:AttributeType name="CustomerID" rs:number="1" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CustomerID" rs:keycolumn="true">
    <s:datatype dt:type="string" dt:maxLength="5" rs:fixedlength="true" rs:maybenull="false"/>
   </s:AttributeType>
   <s:AttributeType name="CompanyName" rs:number="2" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CompanyName">
    <s:datatype dt:type="string" dt:maxLength="40" rs:maybenull="false"/>
   </s:AttributeType>
   [..]

   <s:extends type="rs:rowbase"/>
  </s:ElementType>
</s:Schema>
<rs:data>
  <z:row CustomerID="ALFKI" CompanyName="Alfreds Futterkiste" ContactName="Maria Anders" ContactTitle="Sales Representative" Address="Obere Str. 57" City="Berlin" PostalCode="12209" Country="Germany" Phone="030-0074321" Fax="030-0076545"/>
  <z:row CustomerID="ANATR" CompanyName="Ana Trujillo Emparedados y helados" ContactName="Ana Trujillo" ContactTitle="Owner" Address="Avda. de la Constituci�n 2222" City="M�xico D.F." PostalCode="05021" Country="Mexico" Phone="(5) 555-4729" Fax="(5) 555-3745"/>
[..]

</rs:data>
</xml>

Make it a WebService

What you need to do now is to register your ActiveX library and generate the correct WSDL files using the Microsoft SOAP SDK like I explained in my previous article DSOAP Toolkit. I included the correct WSDL files in the example and the only thing you need to do is to copy them in the root c:\inetpub\wwwroot.

The client

So far so good. We know how to get our data, how to convert it in XML and how to stream it to the client. What we need now is to a way to invoke all this functionality from the client. By using the DSOAP WSDL Import Wizard specifying "http://localhost/DSOAPXMLLib.WSDL" as source, you will be able to generate the unit uCustomersDataObject_Impl.pas. See my other article for details. In order to make the example a little bit more interesting, I decided to show how to feed a TADODataset with this XML stream. By doing this, you will still be able to use all your third party data aware components like it were a regular MIDAS Clientdataset or a BDE TTable. From inside the Delphi IDE the client will look like this:  



Receiving data

In order to receive data you need to invoke the GetCustomers method and ceonvert the XML back into a Recordset. The function XMLToRecordset contained in the common unit uADOCommon.pas takes care of this conversion and returns a Recordset. Once you have that, just assign it to the ADODataset by setting its Recordset property. The following code is execute when you press the "Get Customers" button:

procedure TForm1.bGetCustomersClick(Sender: TObject);
var
  errs: widestring;
  xml: string;
  rs: OleVariant;
begin
  xml := fCustomersDataObject.GetCustomers(eFilter.Text, errs);

  [...]

  ADODataSet1.Recordset := XMLToRecordset(xml) as ADODB._Recordset;
  [...]

end;

While this is the XMLToRecordset funtions' code:

function XMLToRecordset(const someXML: string): _Recordset;
var
  xml: IXMLDOMDocument2;
  rs: OleVariant;
begin
  xml := CoDOMDocument30.Create;
  xml.LoadXML(someXML);
  rs := CoRecordset.Create;
  rs.Open(xml);

  result := IUnknown(rs) as _Recordset;
end;

By reversing what we did on the server side, we can feed the Recordset back with its rows. It almost cannot get simpler than this!

Sending updates back to the middle tier

Here's where it gets a little bit tricky, client side. The ADO Recordset keeps track of all the changes the user made to the original data we received. In order for us to update the database, we need to send these changes back by invoking the server side method UpdateCustomers. The problem we have now is that the XML stream generated client side will contain both the changes and the original data. This is extremely not efficient since the only thing the server needs are the updates. Take a look at the code associated to the button bUpdateCustomers:

procedure TForm1.bUpdateCustomersClick(Sender: TObject);
var
  xml, errs: widestring;
begin
  xml := FilterUpdates(ADODataSet1.Recordset as _Recordset);
  [..]

  if not fCustomersDataObject.UpdateCustomers(xml, errs) then
    MessageDlg(errs, mtError, [mbOK], 0)
  else
  begin
    ShowMessage('Updated!');
    ADODataSet1.Recordset.CancelUpdate;
  end;
end;

I am generating XML using the function FilterUpdates. Here's the code:

function FilterUpdates(const aRecordset: _Recordset): string;
var
  DOMDoc: IXMLDOMDocument2;
  RemNode, DataNode: IXMLDOMNode;
  i, offset: integer;
begin
  DOMDoc := CoDOMDocument30.Create;
  DOMDoc.Async := FALSE;
  aRecordset.Save(DOMDoc, adPersistXML);

  DataNode := DOMDoc.selectSingleNode('xml/rs:data');
  offset := 0;

  for i := 0 to (DataNode.childNodes.length - 1) do
  begin
    if (DataNode.childNodes[i - offset].nodeName = 'z:row') then
    begin
      RemNode := DataNode.removeChild(DataNode.childNodes[i - offset]);
      offset := offset + 1;
    end;
  end;

  result := DOMDoc.xml
end;

This function was inspired by an article I found on the MSDN website. Take a look at it by clicking here. What I do here is nothing but filtering out all the original data while keeping the updates. This is how the XML stream will look after this operation:

<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882" xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882" xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
<s:Schema id="RowsetSchema">
  <s:ElementType name="row" content="eltOnly" rs:updatable="true">
   <s:AttributeType name="CustomerID" rs:number="1" rs:writeunknown="true" rs:basecatalog="Northwind" rs:basetable="CUSTOMERS" rs:basecolumn="CustomerID" rs:keycolumn="true">
    <s:datatype dt:type="string" dt:maxLength="5" rs:fixedlength="true" rs:maybenull="false"/>
   </s:AttributeType>
   [..]   <s:extends type="rs:rowbase"/>
  </s:ElementType>
</s:Schema>
<rs:data>
  <rs:update>
   <rs:original>
    <z:row CustomerID="WOLZA" CompanyName="Wolski  Zajazd" ContactName="Zbyszek Piestrzeniewicz" ContactTitle="Owner" Address="ul. Filtrowa 68" City="Warszawa" PostalCode="01-012" Country="Poland" Phone="(26) 642-7012" Fax="(26) 642-7012"/>
   </rs:original>
   <z:row CompanyName="Wolski  Zajazdxxx"/>
  </rs:update>
  <rs:insert>
   <z:row CustomerID="A    " CompanyName="Test"/>
   <z:row CustomerID="B    " CompanyName="Test #2"/>
  </rs:insert>
</rs:data>
</xml>

The final step: updating the database

We are almost done. Now we sent the batch of updates back to the server using XML and we invoked the method UpdateCustomers. If you take a look at the code, you will find the following:

function TCustomersDataObject.UpdateCustomers(const someChanges: WideString; out
  Errors: WideString): WordBool;
begin
  result := FALSE;
  Errors := '';
  try
    // Updates the database
    UpdateSource(DBConnStr, someChanges);

    result := TRUE;
  except
    on E: Exception do
      Errors := E.Message;
  end;
end;

There's nothing particoular in that code except the call to the method UpdateSource listed below:

procedure UpdateSource(const aConnection: OleVariant; const someChanges: string);
var
  rs, conn: OleVariant;
begin
  rs := XMLToRecordset(someChanges);

  case VarType(aConnection) of

    varUnknown,
      varDispatch: conn := IUnknown(aConnection) as _Connection;

  else
    begin
      conn := CoConnection.Create;
      conn.Open(aConnection, '', '', 0);
    end;
  end;

  rs.ActiveConnection := conn;
  rs.Filter := adFilterPendingRecords;
  rs.UpdateBatch(adAffectAllChapters);

  rs.Close;
end;

We just converted the delta of changes into a Recordset and we finally used its UpdateBatch method to persist the changes to the database.

Conclusion

You can find more information about ADO on the Microsoft website. What you saw above should give you a pretty good idea of how updates work in a distributed, stateless environment and how you can use existing technologies to do this efficiently and in a very simple way.

Show/Hide the "Start" button

Problem/Question/Abstract:

Show/Hide the "Start" button

Answer:

Solve 1:

The following procedure hides or shows the start button:

procedure hideStartbutton(visi: boolean);
var
  Tray,Child: HWnd;
  c: array[0..127] of Char;
  s: string;
begin { hideStartButton }
  Tray := FindWindow('Shell_TrayWnd', nil);
  Child := GetWindow(Tray, GW_CHILD);
  while Child <> 0 do
  begin
    if GetClassName(Child, c, SizeOf(c)) > 0 then
    begin
      s := StrPas(c);
      if UpperCase(s) = 'BUTTON' then
      begin
        // IsWindowVisible(Child)
        startbutton_handle := Child;
        if visi then
          ShowWindow(Child, 1)
        else
          ShowWindow(Child, 0)
      end
    end;
    Child := GetWindow(Child, GW_HWNDNEXT)
  end
end; { hideStartButton }


Solve 2:

To show:

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), TRUE);

To hide:

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), FALSE);

Viewing Targa Bitmap File Format in Delphi (256-colors)

Problem/Question/Abstract:

How to view Bitmap in Targa File Format (*.tga) using Delphi ?

Answer:

This is quite simple way to answer above question: viewing Targa file format using Delphi (not compress and limited only 256 colors).

Here is the example code:

const
  FERRORMSG2 = 'Sorry, Unsupported Compressed(RLE) File Format';
  FERRORMSG3 = 'Sorry, Unsupported More Than 256 Colours File Format';

type
  TArrBuff = array[1..512] of Byte;
  TPalette_Cell = record
    b2, g2, r2: byte;
  end;
  TPal = array[0..255] of TPalette_Cell;
  TPPal = ^TPal;
  TTGA_Header = record // Targa(TGA) HEADER //
    IDLength, ColorMap, ImageType: byte;
    ClrMapSpes: array[1..5] of byte;
    XAwal, YAwal, Width, Height: SmallInt;
    BpPixel, ImageDescription: byte;
  end;

var
  pal: TPPal;
  pFile: file;
  buffer: TArrBuff;
  FTgaHeader: TTGA_Header;

procedure THPTGA.ReadImageData2Bitmap;
var
  i, j, idx: integer;
begin
  Seek(pFile, sizeof(FtgaHeader) + FtgaHeader.IDLength + 768);
  for i := FtgaHeader.Height - 1 downto FtgaHeader.YAwal do
  begin
    BlockRead(pFile, buffer, FtgaHeader.Width);
    for j := FtgaHeader.XAwal to FtgaHeader.Width - 1 do
    begin
      idx := j - FtgaHeader.XAwal + 1;
      SetPixel(Bitmap.Canvas.Handle, j, i, rgb(pal^[buffer[idx]].r2,
        pal^[buffer[idx]].g2, pal^[buffer[idx]].b2));
    end;
  end;
end;

procedure THPTGA.LoadFromFile(const FileName: string);
begin
  AssignFile(pFile, FileName);
{$I-}Reset(pFile, 1);
{$I+}
  if (IOResult = 0) then
  begin
    try
      BlockRead(pFile, FtgaHeader, SizeOf(FtgaHeader));
      // checking unsupported features here
      if (FtgaHeader.ImageType > 3) then
      begin
        MessageBox(Application.Handle, FERRORMSG2, 'TGA Viewer Error', MB_ICONHAND);
        exit;
      end;
      if (FtgaHeader.BpPixel > 8) then
      begin
        MessageBox(Application.Handle, FERRORMSG3, 'TGA Viewer Error', MB_ICONHAND);
        exit;
      end;
      GetMem(pal, 768);
      try
        Bitmap.Width := FtgaHeader.Width;
        Bitmap.Height := FtgaHeader.Height;
        // if use Color-Map and Uncompressed then read it
        if (FtgaHeader.ImageType = 1) then
          BlockRead(pFile, pal^, 768);
        ReadImageData2Bitmap;
      finally
        FreeMem(pal);
      end;
    finally
      CloseFile(pFile);
    end;
  end
  else
    MessageBox(Application.Handle, 'Error Opening File', 'TGA Viewer Error',
      MB_ICONHAND);
end;

How to try this code ?? Just call the "LoadFromFile" procedure above in your application (probably with little modification offcourse, especially about the name of mainForm that I used here [THPTGA]).

Hopefully It can help you.

For full source code and simple application that use this, you can look and download from my website: www.geocities.com/h4ryp/delphi.html.

Note: At http://www.delphi-gems.com/Graphics.php you can download the freeware Delphi unit GraphicEx.pas which makes a bunch of graphics formats available to Delphi programs, among them PCX, TIFF, TGA, etc. The formats are embedded into Delphi in the same way as Borland's jpeg unit.

Auxiliary TQuery used with queries built at run time

Problem/Question/Abstract:

Auxiliary queries built at run time make you copy-paste a lot, replicating your code. Why not keep it to a minimum, making it easy to read and mantain ?

Answer:

Do you have an auxiliary TQuery on your form that you use to build dynamic queries, like

'SELECT Count(id) FROM Clients'

and a bit latter you use the same TQuery to

'SELECT Count(Phone_numbers) FROM Clients WHERE area = '1''

and latter on you use it again to

'SELECT Count(area) FROM Contacts'

and so on...

If you have an auxiliar TQuery to run all these queries, you probably have a lot of similar code replicated in your application to load the query string, prepare the query, run the query and finally close the query.
Since replication is not a good thing when it comes to maintenance, why not abstract the queries from the code so that you just have to pass the TQuery object, the query string and, optionally, the database, if you use different databases.

Here's sometinh I've been using for a while that creates that abstraction layer:

procedure Execute(Q: TQuery; S: string; DBName = '');
begin
  with Q do
  begin
    if DBName <> '' then
      DatabaseName := DBName;
    try
      Close;
    finally
      SQL.Clear;
    end;

    SQL.Add(S);
    try
      Prepare;
      while not (Prepared) do
        ;
      Open;
    finally
      ;
    end;
  end;
end;

Using this procedure, you can reduce the amount of code and maintenance effort to a minimum, since you can prepare and open the queries just by using:

Execute(MyTQuery, 'SELECT Count(id) FROM Clients');

Execute(MyTQuery, 'SELECT Count(Phone_numbers) FROM Clients WHERE area = ' 1 '');

Execute(MyTQuery, 'SELECT Count(area) FROM Contacts', 'Contacts_database');

Execute(MyTQuery, 'SELECT Count(ZIP) FROM Zip_Codes', 'Address_database');

Execute(MyTQuery, 'SELECT Names FROM Vip_Clients', 'clients_database');

After calling the Execute procedure, you are able to read the result from the TQuery as usual.
This procedure simplifies the process of checking if the object is opened, close it if necessary, prepare the query for execution, release the resources to other processes while not ready and finally run the query.

Have a menu in any form

Problem/Question/Abstract:

I need to display a menu in the expert's "main" form. Now this form was created with TForm1.Create() and therefore not an application's main window.

Answer:

Although the menu is displayed in design mode properly, at runtime it will not appear. Even manually assigning the menu with  Menu := MainMenu   will not help.

Use the API function SetMenu in the FormCreate handler as shown below:


procedure TForm1.FormCreate(Sender: TObject);
var
  h: integer;
begin
  h := ClientHeight;
  SetMenu(Handle, MainMenu1.Handle);
  ClientHeight := h;
end;

Convert a RFC time string into TDateTime and VV

Problem/Question/Abstract:

How to convert a RFC time string into TDateTime and vv.

Answer:

Conversion of date & time formats: RFC <-> TDateTime (local & UNC) RFC: e.g. 03.01.2001 05:45:00 -0500

TDateTime -> RFC use

DateTimeToRfcTime(date, diff, gmt)

RFC -> TDateTime  use

RfcTimeToDateTime(time, gmt)

function DateTimeToRfcTime(
  dt: TDateTime;
  iDiff: integer;
  blnGMT: boolean = false): string;
{*
Explanation:
iDiff is the local offset to GMT in minutes
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -300 minutes
    dt is TDateTime of 3 Jan 2001 5:45am
      blnGMT = true  -> Result = 'Wed, 03 Jan 2001 05:45:00 GMT'
      blnGMT = false -> Result = 'Wed, 03 Jan 2001 05:45:00 -0500'
*}
const
  Weekday: array[1..7] of string =
  ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  Month: array[1..12] of string = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
  iDummy: Word;
  iYear: Word;
  iMonth: Word;
  iDay: Word;
  iHour: Word;
  iMinute: Word;
  iSecond: Word;
  strZone: string;
begin
  if blnGMT then
  begin
    dt := dt - iDiff / 1440;
    strZone := 'GMT';
  end
  else
  begin
    iDiff := (iDiff div 60) * 100 + (iDiff mod 60);
    if iDiff < 0 then
      strZone := Format('-%.4d', [-iDiff])
    else
      strZone := Format('+%.4d', [iDiff]);
  end;
  DecodeDate(dt, iYear, iMonth, iDay);
  DecodeTime(dt, iHour, iMinute, iSecond, iDummy);
  Result := Format('%s, %.2d %s %4d %.2d:%.2d:%.2d %s', [
    Weekday[DayOfWeek(dt)], iDay, Month[iMonth], iYear,
      iHour, iMinute, iSecond, strZone]);
end;

function RfcTimeToDateTime(
  strTime: string;
  blnGMT: boolean = true): TDateTime;
{*
Explanation:
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -0500
    strTime = 'Wed, 03 Jan 2001 05:45:00 -0500'
      blnGMT = true  -> FormatDateTime('...', Result) = '03.01.2001 10:45:00'
      blnGMT = false -> FormatDateTime('...', Result) = '03.01.2001 05:45:00'
*}
const
  wd = 'sun#mon#tue#wed#thu#fri#sat';
  month = 'janfebmaraprmayjunjulaugsepoctnovdec';
var
  s: string;
  dd: Word;
  mm: Word;
  yy: Word;
  hh: Word;
  nn: Word;
  ss: Word;
begin
  s := LowerCase(Copy(strTime, 1, 3));
  if Pos(s, wd) > 0 then
    Delete(strTime, 1, Pos(' ', strTime));
  s := Trim(Copy(strTime, 1, Pos(' ', strTime)));
  Delete(strTime, 1, Length(s) + 1);
  dd := StrToIntDef(s, 0);
  s := LowerCase(Copy(strTime, 1, 3));
  Delete(strTime, 1, 4);
  mm := (Pos(s, month) div 3) + 1;
  s := Copy(strTime, 1, 4);
  Delete(strTime, 1, 5);
  yy := StrToIntDef(s, 0);
  Result := EncodeDate(yy, mm, dd);
  s := strTime[1] + strTime[2];
  hh := StrToIntDef(strTime[1] + strTime[2], 0);
  nn := StrToIntDef(strTime[4] + strTime[5], 0);
  ss := StrToIntDef(strTime[7] + strTime[8], 0);
  Delete(strTime, 1, 9);
  Result := Result + EncodeTime(hh, nn, ss, 0);
  if (CompareText(strTime, 'gmt') <> 0) and blnGMT then
  begin
    hh := StrToIntDef(strTime[2] + strTime[3], 0);
    nn := StrToIntDef(strTime[4] + strTime[5], 0);
    if strTime[1] = '+' then
      Result := Result - EncodeTime(hh, nn, 0, 0)
    else
      Result := Result + EncodeTime(hh, nn, 0, 0);
  end;
end;

Determine the default browser

Problem/Question/Abstract:

This article describes how to determine the default browser and its version

Answer:

The WinAPI provides an excellent function for this purpose: FindExecutable. This function returns the application associated with the given file. The application associated with a .htm file is the default browser.
The prototype is

function FindExecutable(FileName, Directory: PChar; Result: PChar): HINST;

Unfortunately this function needs an existent file. For this reason it is necessary to create a temporary one.

Basic function

The basic function performs the following steps:

Determine the temp directory
Create a file with ".htm" extension.
Use FindExecutable
Delete the temporary file

type
  TBrowserInformation = record
    Name: string;
    Path: string;
    Version: string;
  end;

function GetDefaultBrowser: TBrowserInformation;
var
  tmp: PChar;
  res: PChar;

begin
  tmp := StrAlloc(255);
  res := StrAlloc(255);

  try
    GetTempPath(255, tmp);
    FileCreate(tmp + 'htmpl.htm');
    FindExecutable('htmpl.htm', tmp, Res);
    Result.Name := ExtractFileName(res);
    Result.Path := ExtractFilePath(res);
    SysUtils.DeleteFile(tmp + 'htmpl.htm');
  finally
    StrDispose(tmp);
    StrDispose(res);
  end;
end;


Long File Name

Now, if you run that function you will notice that there is a small inconvenience: The function returns the location of the default browser as short path. The next function will try to convert it to the long format.

function LongPathName(ShortPathName: string): string;
var
  PIDL: PItemIDList;
  Desktop: IShellFolder;
  WidePathName: WideString;
  AnsiPathName: AnsiString;
begin
  Result := ShortPathName;
  if Succeeded(SHGetDesktopFolder(Desktop)) then
  begin
    WidePathName := ShortPathName;
    if Succeeded(Desktop.ParseDisplayName(0, nil, PWideChar(WidePathName), ULONG(nil^), PIDL, ULONG(nil^))) then
    try
      SetLength(AnsiPathName, MAX_PATH);
      SHGetPathFromIDList(PIDL, PChar(AnsiPathName));
      Result := PChar(AnsiPathName);
    finally CoTaskMemFree(PIDL);
    end;
  end;
end;

Version Information

The next step is to extend the basic function with error handling and the ability to get the default browsers version.

function GetDefaultBrowser: TBrowserInformation;
var
  tmp: PChar;
  res: PChar;
  Version: Pointer;
  VersionInformation: Pointer;
  VersionInformationSize: Integer;
  Dummy: Integer;

begin
  tmp := StrAlloc(255);
  res := StrAlloc(255);

  Version := nil;

  try
    GetTempPath(255, tmp);

    if FileCreate(tmp + 'htmpl.htm') <> -1 then
    begin
      if FindExecutable('htmpl.htm', tmp, res) > 32 then
      begin
        Result.Name := ExtractFileName(res);
        Result.Path := LongPathName(ExtractFilePath(res));

        // Try to determine the Browser Version

        VersionInformationSize := GetFileVersionInfoSize(Res, Dummy);

        if VersionInformationSize > 0 then
        begin
          GetMem(VersionInformation, VersionInformationSize);
          GetFileVersionInfo(Res, 0, VersionInformationSize, VersionInformation);

          VerQueryValue(VersionInformation, ('StringFileInfo040904E4ProductVersion'),
            Pointer(Version), Dummy);

          if Version <> nil then
            Result.Version := PChar(Version);

          FreeMem(VersionInformation);
        end;
      end
      else
        raise EGetDefaultBrowser.Create('Can''t determine the executable.');

      SysUtils.DeleteFile(tmp + 'htmpl.htm');
    end
    else
      raise EGetDefaultBrowser.Create('Can''t create temporary file.');

  finally
    StrDispose(tmp);
    StrDispose(res);
  end;
end;

How to highlight a TBitmap with a color overlay

Problem/Question/Abstract:

Does anyone know of a way that I can achieve the same effect on a bitmap that Windows achieves when you single click on an icon on the desktop? In other words, I want to "highlight" a bitmap and let the user know that it is selected.

Answer:

To me it appears as if the icons on my desktop are highlighted by overlaying them with a certain color, so I guess the following routine is of use.

procedure Highlight(aSource, ATarget: TBitmap; AColor: TColor);
{Alters ASource to ATarget by making it appear as if looked through colored glass as given by AColor.
ASource, ATarget must have been created. Isn't as slow as it looks. Physics courtesy of a post by K.H. Brenner}
var
  i, j: Integer;
  s, t: pRGBTriple;
  r, g, b: byte;
  cl: TColor;
begin
  cl := ColorToRGB(AColor);
  r := GetRValue(cl);
  g := GetGValue(cl);
  b := GetBValue(cl);
  aSource.PixelFormat := pf24bit;
  ATarget.PixelFormat := pf24bit;
  ATarget.Width := aSource.Width;
  ATarget.Height := aSource.Height;
  for i := 0 to aSource.Height - 1 do
  begin
    s := ASource.Scanline[i];
    t := ATarget.Scanline[i];
    for j := 0 to aSource.Width - 1 do
    begin
      t^.rgbtBlue := (b * s^.rgbtBlue) div 255;
      t^.rgbtGreen := (g * s^.rgbtGreen) div 255;
      t^.rgbtRed := (r * s^.rgbtRed) div 255;
      inc(s);
      inc(t);
    end;
  end;
end;

Getting a lot of files in one stream

Problem/Question/Abstract:

How to get a lot of files in one stream
And get it back to :)

Answer:

Some times i want to Have multiple files in a stream couse then i dont have to send a lot of files but just one .

So heres a little code sniped to get it in and out again.

procedure TForm1.ThisISHowIPutFilesIn;
var
  ABigFileStream, SomeSmallFiles: TMemoryStream;

begin
  ABigFileStream := TMemoryStream.Create;
  try
    SomeSmallFiles := TMemoryStream.Create;
    try
      SomeSmallFiles.LoadFromFile('C:\SomeSmalFile1.txt');
      AddToStream(SomeSmallFiles, ABigFileStream);
      SomeSmallFiles.LoadFromFile('C:\SomeSmalFile2.txt');
      AddToStream(SomeSmallFiles, ABigFileStream);
      // enz
    finally
      SomeSmallFiles.Free;
    end;
    ABigFileStream.SaveToFile('C:\MrBig.DDD')
  finally
    ABigFileStream.free;
  end;
end;

procedure TForm1.ThisISHowIGetStufOut;
var
  ABigFileStream, SomeSmallFiles: TMemoryStream;

begin
  ABigFileStream := TMemoryStream.Create;
  try
    ABigFileStream.LoadFromFile('C:\MrBig.DDD');
    SomeSmallFiles := TMemoryStream.Create;
    try
      GetFromStream(ABigFileStream, SomeSmallFiles, 0);
      SomeSmallFiles.SaveToFile('C:\SomeSmalFile1.txt');
      GetFromStream(ABigFileStream, SomeSmallFiles, 1);
      SomeSmallFiles.SaveToFile('C:\SomeSmalFile2.txt');
      // enz
    finally
      SomeSmallFiles.Free;
    end;
  finally
    ABigFileStream.free;
  end;
end;

procedure TForm1.AddToStream(Source, Dest: TStream);
var
  Size: Integer;
begin
  Source.position := 0;
  // Keep the size by puting it in the first byte
  Size := Source.Size;
  Dest.Write(Size, SizeOf(Integer));
  Dest.CopyFrom(Source, Source.size);
end;

procedure TForm1.GetFromStream(Source, Dest: TStream; Index: Integer);
var
  Size, I: Integer;

begin
  Source.Position := 0;
  for i := 0 to index - 1 do
  begin
    Source.Read(Size, SizeOf(Integer));
    Source.Position := Source.Position + Size;
  end;
  // if where all the way up the file pointer then someting went wrong :(
  if Source.position = Source.Size then
    raise EAccessViolation.Create('Index Out Of Bounds');
  // Get the desired file size
  Source.Read(Size, SizeOf(Integer));
  // Clear Dest Buffer
  Dest.Position := 0;
  Dest.Size := 0;
  Dest.CopyFrom(Source, Size);
end;

Get Computer MAC Address

Problem/Question/Abstract:

How can you get the computers MAC address?

Answer:

Solve 1:

The following code will allow you to retrieve the MAC address of your computer. It is a close translation of the C++ code found at the Borland Community at:
http://community.borland.com/article/0,1410,26040,00.html

You must include the NB30 unit in your uses clause for this code to work.

Simply call the GetMACAddress routine for the address of the first network adapter installed.

uses
  NB30;

function GetAdapterInfo(Lana: Char): string;
var
  Adapter: TAdapterStatus;
  NCB: TNCB;
begin
  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBRESET);
  NCB.ncb_lana_num := Lana;
  if Netbios(@NCB) <> Char(NRC_GOODRET) then
  begin
    Result := 'mac not found';
    Exit;
  end;

  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBASTAT);
  NCB.ncb_lana_num := Lana;
  NCB.ncb_callname := '*';

  FillChar(Adapter, SizeOf(Adapter), 0);
  NCB.ncb_buffer := @Adapter;
  NCB.ncb_length := SizeOf(Adapter);
  if Netbios(@NCB) <> Char(NRC_GOODRET) then
  begin
    Result := 'mac not found';
    Exit;
  end;
  Result :=
    IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[5]), 2);
end;

function GetMACAddress: string;
var
  AdapterList: TLanaEnum;
  NCB: TNCB;
begin
  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBENUM);
  NCB.ncb_buffer := @AdapterList;
  NCB.ncb_length := SizeOf(AdapterList);
  Netbios(@NCB);
  if Byte(AdapterList.length) > 0 then
    Result := GetAdapterInfo(AdapterList.lana[0])
  else
    Result := 'mac not found';
end;


Solve 2:

function TUserInfo.GetPrimaryNicMacAddress(): string;
// Here is a function that we use to get the MAC address.
// It comes from the CoCreateGUID API call.  In W2K
// Microsoft changed the underlying call in CoCreateGUID
// to a random value instead of the MAC address that is
// why the function checks which version of Windows is
// running and then makes the appropriate API call.
type
  TGUID = record
    A, B: word;
    D, M, S: word;
    MAC: array[1..6] of byte;
  end;
var
  UuidCreateFunc: function(var guid: TGUID): HResult; stdcall;
  handle: THandle;
  g: TGUID;
  WinVer: _OSVersionInfoA;
  i: integer;
  ErrCode: HResult;
begin
  WinVer.dwOSVersionInfoSize := sizeof(WinVer);
  getversionex(WinVer);

  handle := LoadLibrary('RPCRT4.DLL');
  if WinVer.dwMajorVersion >= 5 then {Windows 2000 }
    @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreateSequential')
  else
    @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreate');

  UuidCreateFunc(g);
  result := '';
  for i := 1 to 6 do
    result := result + IntToHex(g.MAC[i], 2);
end;

How to get a list of all table names in a database

Problem/Question/Abstract:

How does one get a list of the table names in a database? The TDatabase.Datasets list seems to be only open tables. I need to get at the unopened ones as well.

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  ts: TStringlist;
begin
  ts := TStringlist.create;
  Session.GetTableNames('DBDEMOS', '*.DB', false, false, ts);
  listbox1.items.assign(ts);
  ts.free;
end;

Updating a table with data from another table with Local SQL

Problem/Question/Abstract:

The UPDATE sentence of Local SQL (the SQL used by the BDE) doesn't support JOIN... How two update a table with data from another table?

Answer:

Orders.db

Customer.db
CustNo
ShipToAddr1
ShipToAddr2
<<--------->
CustNo
Addr1
Addr2



Assuming that we wanted to update the fields ShipToAddr1 and ShipToAddr2 of the Orders.db table with the values of the fields Addr1 and Addr2 respectively from the table Customer.db, for those records of Orders that have both fields blank, and joining the tables by the field CustNo present in both tables, perhaps we would be temped to write:

  UPDATE Orders INNER JOIN Customer
    ON Customer.CustNo = Orders.CustNo
  SET ShipToAddr1 = Addr1, ShipToAddr2 = Addr2
  WHERE ShipToAddr1 = "" AND ShipToAddr2 = ""

However, in Local SQL (the one used by the BDE), joins are not supported in the UPDATE statement, and we have to use subqueries to achieve the expected result:

  UPDATE Orders
  SET ShipToAddr1 = (SELECT Addr1 FROM Customer WHERE
                     Customer.CustNo = Orders.CustNo),
      ShipToAddr2 = (SELECT Addr2 FROM customer WHERE
                     Customer.CustNo = Orders.CustNo)
  WHERE ShipToAddr1 = "" AND ShipToAddr2 = ""

In the "UPDATE statement" topic of the Local SQL Guide you can find an example of a 1-to-many relationship that uses grouping the subqueries.


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

Basic authentication in ISAPI/CGI applications

Problem/Question/Abstract:

How to password protect ISAPI/CGI actions with basic authentication?

Answer:

It is very easy to protect a web server virtual directory with basic authentication.
Supose you have an ISAPI application with 3 actions and you want to password protect only one of them. This example shows you how you could do that with only one ISAPI application.

Source Code:

- This 2 lines tells browser to prompt for user name and password:

Response.StatusCode := 401; // Promp for user name and password
Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Title

- Browser sends user name and password and we can get it:

Request.Authorization

- But information is encoded with Base64. There a lot of free source code that implements Base64 encode/decode. The following line returns decoded data in mAuthorization.

FBase64.DecodeData(Copy(Request.Authorization, 6, Length(Request.Authorization)),
  mAuthorization);


Component Download: authen.zip

How to animate a window while opening a form

Problem/Question/Abstract:

How to animate a window while opening a form

Answer:

This project uses two forms:


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormClick(Sender: TObject);
  private
    procedure FocusAnimation(DC: HDC; AnimRect: TRect; Steps, Speed, Direction: Integer);
  public
  end;

const
  FA_IN = 0;
  FA_OUT = 1;

var
  Form1: TForm1;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.FormClick(Sender: TObject);
var
  WRect: TRect;
begin
  GetWindowRect(Form2.handle, WRect);
  FocusAnimation(GetDC(0), WRect, 20, 10, FA_OUT);
  {Open form2}
  Form2.ShowModal;
end;

procedure TForm1.FocusAnimation(DC: HDC; AnimRect: TRect; Steps, Speed, Direction: Integer);
var
  cv, animx, animy, animwidth, animheight: Integer;
  xp, yp: Double;
  FRect: TRect;
  cancel: Boolean;
begin
  {Steps = number of steps during open/close operation,
  Speed = time between the steps,
  Direction = inner/outer direction}
  animx := AnimRect.left + (AnimRect.right - AnimRect.left) div 2;
  animy := AnimRect.top + (AnimRect.bottom - AnimRect.top) div 2;
  animwidth := AnimRect.right - AnimRect.left;
  animheight := AnimRect.bottom - AnimRect.top;
  xp := animwidth div 2 / Steps; {horizontal}
  yp := animheight div 2 / Steps; {vertical}
  if Direction = FA_OUT then
    cv := 0
  else
    cv := Steps;
  while not cancel do
  begin
    FRect := Rect(Round(animx - cv * xp), Round(animy - cv * yp),
      Round(animx + cv * xp), Round(animy + cv * yp));
    DrawFocusRect(DC, FRect);
    Sleep(Speed);
    DrawFocusRect(DC, FRect);
    if Direction = FA_OUT then
    begin
      Inc(cv);
      if cv > Steps then
        cancel := True;
    end
    else
    begin
      Dec(cv);
      if cv < 0 then
        cancel := True;
    end;
  end;
end;

end.

Creating threads straight from the WinAPI

Problem/Question/Abstract:

How can I implement threads in my programs without using the VCL TThread object?

Answer:

I've done extensive work in multi-threaded applications. And in my experience, there have been times when a particular program I'm writing should be written as a multi-threaded application, but using the TThread object just seems like overkill. For instance, I write a lot of single function programs; that is, the entire functionality (beside the user interface portion) of the program is contained in one single execution procedure or function. Usually, this procedure contains a looping mechanism (e.g. FOR, WHILE, REPEAT) that operates on a table or an incredibly large text file (for me, that's on the order of 500MB-plus!). Since it's just a single procedure, using a TThread is just too much work for my preferences.

For those experienced Delphi programmers, you know what happens to the user interface when you run a procedure with a loop in it: The application stops receiving messages. The most simple way of dealing with this situation is to make a call to Application.ProcessMessages within the body of the loop so that the application can still receive messages from external sources. And in many, if not most, cases, this is a perfectly valid thing to do. However, if some or perhaps even one of the steps within the loop take more than a couple of seconds to complete processing &#8212; as in the case of a query &#8212; Application.ProcessMessages is practically useless because the application will only receive messages at the time the call is made. So what you ultimately achieve is intermittent response at best. Using a thread, on the other hand, frees up the interface because the process is running completely separate from the main thread of the program where the interface resides. So regardless of what you execute within a loop that is running in a separate thread, your interface will never get locked up.

Don't confuse the discussion above with multi-threaded user interfaces. What I'm talking about is executing long background threads that won't lock up your user interface while they run. This is an important distinction to make because it's not really recommended to write multi-user interfaces, because each thread that is created in the system has its own message queue. Thus, a message loop must be created to fetch messages out of the queue so they can be dispatched appropriately. The TApplication object that controls the UI would be the natural place to set up message loops for background threads, but it's not set up to detect when other threads are executed. The gist of all this is that the sole reason you create threads is to distribute processing of independent tasks. Since the UI and controls are fairly integrated, threads just don't make sense here because in order to make the separate threads work together, you have to synchronize them to work in tandem, which practically defeats threading altogether!

I mentioned above that the TThread object is overkill for really simple threaded stuff. This is strictly an opinion, but experience has made me lean that way. In any case, what is the alternative to TThread in Delphi?

The solution isn't so much an alternative as it is going a bit more low-level into the Windows API. I've said this several times before: The VCL is essentially one giant wrapper around the Windows API and all its complexities. But fortunately for us, Delphi provides a very easy way to access lower-level functionality beyond the wrapper interface with which it comes. And even more fortunate for us, we can create threads using a simple Windows API function called CreateThread to bypass the TThread object altogether. As you'll see below, creating threads in this fashion is incredibly easy to do.

Setting Yourself Up

There are two distinct steps for creating a thread: 1)Create the thread itself, then 2) Provide a function that will act as the thread entry point. The thread function or thread entry point is the function (actually the address of the function) that tells your thread where to start.

Unlike a regular function, there are some specific requirements regarding the thread function that you have to obey:

You can give the function any name you want, but it must be a function name (ie. function MyThreadFunc)
The function must have a single formal parameter of type Pointer (I'll discuss this below)
The function return type is always LongInt
Its declaration must always be preceded by the stdcall directive. This tells the compiler that the function will be passing parameters in the standard Windows convention.

Whew! That seems like a lot but it's really not as complicated as it might seem from the description above. Here's an example declaration:

function MyThreadFunc(Ptr: Pointer): LongInt; stdcall;

That's it! Hope I didn't get you worried. The CreateThread call is a bit more involved, but it too is not very complicated once you understand how to call it. Here's its declaration, straight out of the help file:

function CreateThread
  (lpThreadAttributes: Pointer; //Address of thread security attributes
  dwStackSize: DWORD; //Thread stack size
  lpStartAddress: TFNThreadStartRoutine; //Address of the thread function
  lpParameter: Pointer; //Input parameter for the thread
  dwCreationFlags: DWORD; //Creation flags
  var lpThreadId: DWORD): //ThreadID reference
THandle; stdcall; //Function returns a handle to the thread

This is not as complicated as it seems. First of all, you rarely have to set security attributes, so that can be set to nil. Secondly, in most cases, your stack size can be 0 (actually, I've never found an instance where I have to set this to a value higher than zero). You can optionally pass a parameter through the lpParameter argument as a pointer to a structure or address of a variable, but I've usually opted to use global variables instead (I know, this breaking a cardinal rule of structured programming, but it sure eases things). Lastly, I've rarely had to set creation flags unless I want my thread to start in a suspended state so I can do some preprocessing. For the most part, I set this value as zero.

Now that I've thoroughly confused you, let's look at an example function that creates a thread:

procedure TForm1.Button1Click(Sender: TObject);
var
  thr: THandle;
  thrID: DWORD;
begin
  FldName := ListBox1.Items[ListBox1.ItemIndex];
  thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID);
  if (thr = 0) then
    ShowMessage('Thread not created');
end;

Embarrassingly simple, right? It is. To make the thread in the function above, I declared two variables, thr and thrID, which stand for the handle of the thread and its identifier, respectively. I set a global variable that the thread function will access immediately before the call to CreateThread, then make the declaration, assigning the return value of the function to thr and inputting the address of my thread function, and the thread ID variable. The rest of the parameters I set to nil or 0. Not much to it.

Notice that the procedure that actually makes the call is an OnClick handler for a button on a form. You can pretty much create a thread anywhere in your code as long as you set up properly. Here's the entire unit code for my program; you can use it for a template. This program is actually fairly simple. It adds an incremental numeric key value to a table called RecID, based on the record number (which makes things really easy). Browse the code; we'll discuss it below:

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs, DB, DBTables, StdCtrls, ComCtrls,
  Buttons;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    OpenDialog1: TOpenDialog;
    SpeedButton1: TSpeedButton;
    Label2: TLabel;
    StatusBar1: TStatusBar;
    Button1: TButton;
    ListBox1: TListBox;
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  end;

var
  Form1: TForm1;
  TblName: string;
  FldName: string;

implementation

{$R *.DFM}

function CreateRecID(P: Pointer): LongInt; stdcall;
var
  tbl: TTable;
  I: Integer;
  ses: TSession;
  msg: string;
begin
  Randomize; //Initialize random number generator
  I := 0;
  {Disable the Execute button so another thread can't be executed
   while this one is running}
  EnableWindow(Form1.Button1.Handle, False);

  {If you're going to access any data in a thread, you have to create a
   separate }
  ses := TSession.Create(Application);
  ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000));

  tbl := TTable.Create(Application);
  with tbl do
  begin
    Active := False;
    SessionName := ses.SessionName;
    DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set
    TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler
    Open;
    First;
    try
      {Start looping structure}
      while not EOF do
      begin
        if (State <> dsEdit) then
          Edit;
        msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);
        {Display message in status bar}
        SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
        FieldByName(FldName).AsInteger := RecNo;
        Next;
      end;
    finally
      Free;
      ses.Free;
      EnableWindow(Form1.Button1.Handle, True);
    end;
  end;
  msg := 'Operation Complete!';
  SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  tbl: TTable;
  I: Integer;
begin
  with OpenDialog1 do
    if Execute then
    begin
      Edit1.Text := FileName;
      TblName := FileName;
      tbl := TTable.Create(Application);
      with tbl do
      begin
        Active := False;
        DatabaseName := ExtractFilePath(TblName);
        TableName := ExtractFileName(TblName);
        Open;
        LockWindowUpdate(Self.Handle);
        for I := 0 to FieldCount - 1 do
        begin
          ListBox1.Items.Add(Fields[I].FieldName);
        end;
        LockWindowUpdate(0);
        Free;
      end;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  thr: THandle;
  thrID: DWORD;
begin
  FldName := ListBox1.Items[ListBox1.ItemIndex];
  thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID);
  if (thr = 0) then
    ShowMessage('Thread not created');
end;

end.

The most important function here, obviously, is the thread function, CreateRecID. Let's take a look at it:

function CreateRecID(P: Pointer): LongInt; stdcall;
var
  tbl: TTable;
  I: Integer;
  ses: TSession;
  msg: string;
begin
  Randomize; //Initialize random number generator
  I := 0;
  {Disable the Execute button so another thread can't be executed
   while this one is running}
  EnableWindow(Form1.Button1.Handle, False);

  {If you're going to access any data in a thread, you have to create a
   separate }
  ses := TSession.Create(Application);
  ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000));

  tbl := TTable.Create(Application);
  with tbl do
  begin
    Active := False;
    SessionName := ses.SessionName;
    DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set
    TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler
    Open;
    First;
    try
      {Start looping structure}
      while not EOF do
      begin
        if (State <> dsEdit) then
          Edit;
        msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);
        {Display message in status bar}
        SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
        FieldByName(FldName).AsInteger := RecNo;
        Next;
      end;
    finally
      Free;
      ses.Free;
      EnableWindow(Form1.Button1.Handle, True);
    end;
  end;
  msg := 'Operation Complete!';
  SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));
end;

This is a pretty basic function. I'll leave it up to you to follow the flow of execution. However, let's look at some very interesting things that are happening in the thread function.

First of all, notice that I created a TSession object before I created the table I was going to access. This is to ensure that the program will behave itself with the BDE. This is required any time you access a table or other data source from within the context of a thread. I've explained this in more detail in another article called How Can I Run Queries in Threads? Directly above that, I made a call to the Windows API function EnableWindow to disable the button that executes the code. I had to do this because since the VCL is not thread-safe, there's no guarantee I'd be able to successfully access the button's Enabled property safely. So I had to disable it using the Windows API call that performs enabling and disabling of controls.

Moving on, notice how I update the caption of a status bar that's on the bottom of the my form. First, I set the value of a text variable to the message I want displayed:

msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount);

Then I do a SendMessage, sending the WM_SETTEXT message to the status bar:

SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));

SendMessage will send a message directly to a control and bypass the window procedure of the form that owns it.

Why did I go to all this trouble? For the very same reason that I used EnableWindow for the button that creates the thread. But unfortunately, unlike the single call to EnableWindow, there's no other way to set the text of a control other than sending it the WM_SETTEXT message.

The point to all this sneaking behind the VCL is that for the most part, it's not safe to access VCL properties or procedures in threads. In fact, the objects that are particularly dangerous to access from threads are those descended from TComponent. These comprise a large part of the VCL, so in cases where you have to perform some interaction with them from a thread, you'll have to use a roundabout method. But as you can see from the code above, it's not all that difficult.

Of the thousands of functions in the Windows API, CreateThread is one of the most simple and straightforward. I spent a lot of time explaining things here, but there's a lot of ground I didn't cover. Use this example as a template for your thread exploration. Once you get the hang of it, you'll use threads in practically everything you do.