Adding password security to your app with paradox

Problem/Question/Abstract:

Adding password security to your app with paradox

Answer:

I'm using a method to implement password security to your app using paradox.

First you make a table having a username field, name, password etc.. and you add Rights fiels type alpha(100) and a Level field of the same type.
Then in the app you got to use an actionlist to center all the commands your users will have access to.
The key here is to manage which action the user has right to use base in the rights field and (optionally) what level of access tha user has for the given action.

I use the tag property of each action in the actionlist to put the value of an accii char.
So, the first action will have a tag value o 65 the next 66,and so on.

Whe the app starts and acepts a user, it must check the chars of the Rights field againts each action's tag, if there's a macht that action is enabled.
So if a user has 'ABCZDH' in his/her rights field then will only have access to those actions marked by the asccii value in their tags.

Off course all of this comes with a nice screen where an 'administrador' can activate/deactivate the users's rights.

Get special Windows folder location (2)

Problem/Question/Abstract:

How to get special Windows folder location

Answer:

The two key functions to browse through those virtual Windows folders are

SHGetSpecialFolderLocation();

and

SHGetPathFromIDList()

They can be used as shown in the sample code. You may replace the CSIDL_PROGRAMS constant with another one from the list in the comment below.

uses ShlObj, ActiveX;

procedure TForm1.Button1Click(Sender: TObject);
var
  BI: TBrowseInfo;
  Buf: PChar;
  Dir,
    Root: PItemIDList;
  Alloc: IMalloc;
begin
  SHGetMalloc(Alloc);
  Buf := Alloc.Alloc(Max_Path);

  // CSIDL_BITBUCKET  RecycleBin
  // CSIDL_CONTROLS   ControlPanel
  // CSIDL_DESKTOP    Desktop
  // CSIDL_DRIVES     My Computer
  // CSIDL_FONTS      Fonts
  // CSIDL_NETHOOD    Network Neighborhood
  // CSIDL_NETWORK    The virtual version of the above
  // CSIDL_PERSONAL   'Personal'
  // CSIDL_PRINTERS   printers
  // CSIDL_PROGRAMS   Programs in the Start Menu
  // CSIDL_RECENT     Recent Documents
  // CSIDL_SENDTO     Folder SendTo
  // CSIDL_STARTMENU  The whole Start menu
  // CSIDL_STARTUP    The Autostart Group
  // CSIDL_TEMPLATES  Document templates

  // use of the constants above
  SHGetSpecialFolderLocation(Handle, CSIDL_PROGRAMS, Root);

  with BI do
  begin
    hwndOwner := Form1.Handle;
    // NIL means show all
    pidlRoot := Root;
    pszDisplayName := Buf;
    lpszTitle := 'Choose Folder';
    ulFlags := 0;
    lpfn := nil;
  end;

  try
    Dir := SHBrowseForFolder(BI);
    if Dir <> nil then
    begin
      SHGetPathFromIDList(Dir, Buf);
      ShowMessage(Buf);
      Alloc.Free(Dir);
    end;
  finally
    Alloc.Free(Root);
    Alloc.Free(Buf);
  end;
end;

How to programmatically change the size of the TOpenDialog window

Problem/Question/Abstract:

Is there a way to programmatically change the size of the TOpenDialog window so that more files will be shown? In Win98, the user can drag the dialog window to increase its size. Can the window size be increased under program control?

Answer:

The OnShow event seems to be a bit too early to do it. It has to be delayed a bit. Like this:

type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure OpenDialog1Show(Sender: TObject);
  private
    { Private declarations }
    procedure MoveDialog(var Msg: TMessage); message WM_USER;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    Caption := OpenDialog1.FileName;
end;

procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
  PostMessage(Self.Handle, WM_USER, 0, 0);
end;

function GetDesktopWorkArea: TRect;
begin
  if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then
    Result := Rect(0, 0, Screen.Width, Screen.Height);
end;

procedure TForm1.MoveDialog(var Msg: TMessage);
var
  rec: TRect;
  wh: HWND;
  l, t, r, b: Integer;
begin
  wh := Windows.GetParent(OpenDialog1.Handle);
  {if GetWindowRect(wh, rec) then}
  if IsWindow(wh) then
  begin
    rec := GetDesktopWorkArea;
    l := rec.Left;
    t := rec.Top;
    r := rec.Right;
    b := rec.Bottom;
    MoveWindow(wh, l, t, r, b, True);
  end;
end;

Reorder a TPageControl at runtime

Problem/Question/Abstract:

Let's say we have a TPageControl with 15 pages, the design time PageIndex of each page is 0 to 14 respectively. Now we want to change this order at runtime. The new order is saved in an *.ini file, the values for the new order is stored in an array of integer we will call MyOrder. Here is what the code would look like to change the order:

var
  i: Integer;

  for i := 0 to PageControl1.PageCount - 1 do
    PageControl1.Pages[i].PageIndex = MyOrder[i];

After executing this block of code the order of the pages is unchanged. Can you tell my why this doesn't work?

Answer:

Solve 1:

Try this chunk of code. The key is that you set the 0th page index, then the 1rst, then the 2nd and so on. Since you're doing them in order, they don't get screwed up by later assignments.

procedure TForm1.ReorderBtnClick(Sender: TObject);
const
  NewOrder: array[0..6] of Integer = (2, 0, 6, 1, 5, 3, 4);
var
  X: Integer;
  OrigPages: array of TTabSheet;
begin
  {Keep an ordered list of tab sheets}
  SetLength(OrigPages, 7);
  for X := 0 to 6 do
    OrigPages[X] := PageControl.Pages[X];
  {Reorder tab sheets}
  for X := 0 to 6 do
    OrigPages[NewOrder[X]].PageIndex := X;
  {Release ordered list of tab sheets}
  OrigPages := nil;
end;


Solve 2:

This won't make order of the pages unchanged, but it won't give you the order you expect either. Remember that while you are re-ordering the pagecontrol, the pagecontrol also reorders itself. For example, you have a pagecontrol with 5 tabs, labelled One, Two, Three, Four and Five. If you try to reorder so that these pages move to the positions 3, 5, 1, 4, 2 respectively, then the order your code will put them in will be Four, Three, Two, One, Five because of the way they get reordered by the pagecontrol while you are moving them around.

Now, the really cool thing, and what seems to be happening to you, is that if you apply the exact same reordering (using your algorithm) as first used, the tabs will go back to the positions that they started from! Step through your code, and I'm sure your reordering routine will be called twice. To reorder them successfully, you would simply use a search and position algorithm, working from the last tab position back to the first to get around the pagecontrol's own re-ordering. I'm not sure from your post whether your array of positions is "for this position, this is the page that goes here" or "for this page, this is the position it should be in", so here is how to re-order your pagecontrol. We'll use the Tag property to let the page remember where it should be. Use only *one* of the first two commented for-loops, depending on your data structure.

{ ... }
var
  i, j: Integer;
begin
  {Use this loop if the following describes your array:
  "For this position (index), this is the page that goes here (contents)"
  (that is, the contents of the array is the current pageindex, and the array
  index is the new pageindex for that page)}

  for i := 0 to PageControl1.PageCount - 1 do
    PageControl1.Pages[MyOrder[i]].Tag := i;

  {OR use this loop if the following describes your array:
  "For this page (index), this is the position it should be in (contents)"
  (That is, the array index corresponds to the current pageindex, and the contents
  of the array is the new pageindex that page should have)}

  for i := 0 to PageControl1.PageCount - 1 do
    PageControl1.Pages[i].Tag := MyOrder[i];

  {Then simply reorder the pagecontrol}
  for i := PageControl1.PageCount - 1 downto 0 do
    for j := 0 to i do
      if PageControl1.Pages[j].Tag = i then
      begin
        PageControl1.Pages[j].PageIndex := i;
        Break;
      end;
end;

One of the two will work for you.


Solve 3:

The correct method to disconnect tabsheets and reconnect them:

{ ... }
var
  I: Integer;
  L: TList;
begin
  L := TList.Create;
  try
    {This just disconnects - you should replace this with your code to disconnect
                them in the order you want to reconnect them}
    for I := PageControl1.PageCount - 1 downto 0 do
    begin
      L.Add(PageControl1.Pages[I]);
      PageControl1.Pages[I].PageControl := nil;
    end;
    {Reconnect...}
    for I := 0 to L.Count - 1 do
      TTabSheet(L[I]).PageControl := PageControl1;
  finally
    L.Free;
  end;
end;

Create a sizeable form with a 3D look

Problem/Question/Abstract:

How to create a sizeable form with a 3D look

Answer:

Try these handlers for the WMNCPaint and WMNCHitTest messages. The form should have the Sizeable border style as the code uses the sizeable border area for drawing the 3D effect, whether or not you want the user to be able to resize. To prohibit resizing, include the WMNCHitTest handler, to allow it, leave it out.

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  DC: HDC;
  Frame_H: Integer;
  Frame_W: Integer;
  Menu_H: Integer;
  Caption_H: Integer;
  Frame: TRect;
  Extra: Integer;
  Canvas: TCanvas;
begin
  { Predetermine some window parameters }
  Frame_W := GetSystemMetrics(SM_CXFRAME);
  Frame_H := GetSystemMetrics(SM_CYFRAME);
  if (Menu <> nil) then
    Menu_H := GetSystemMetrics(SM_CYMENU)
  else
    Menu_H := -1;
  Caption_H := GetSystemMetrics(SM_CYCAPTION);
  GetWindowRect(Handle, Frame);
  Frame.Right := Frame.Right - Frame.Left - 1;
  Frame.Left := 0;
  Frame.Bottom := Frame.Bottom - Frame.Top - 1;
  Frame.Top := 0;
  { Let standard frame draw }
  inherited;
  { Repaint frame area in 3-D style }
  DC := GetWindowDC(Handle);
  Canvas := TCanvas.Create;
  try
    with Canvas do
    begin
      Handle := DC;
      { Left and Top edges }
      Pen.Color := clBtnShadow;
      PolyLine([Point(Frame.Left, Frame.Bottom), Point(Frame.Left, Frame.Top),
        Point(Frame.Right, Frame.Top)]);
      { Right and Bottom edges }
      Pen.Color := clWindowFrame;
      PolyLine([Point(Frame.Left, Frame.Bottom), Point(Frame.Right, Frame.Bottom),
        Point(Frame.Right, Frame.Top - 1)]);
      { Left and Top edge, 1 pixel in }
      Pen.Color := clBtnHighlight;
      PolyLine([Point(Frame.Left + 1, Frame.Bottom - 1), Point(Frame.Left + 1,
        Frame.Top + 1),
        Point(Frame.Right - 1, Frame.Top + 1)]);
      { Right and Bottom edge, 1 pixel in }
      Pen.Color := clBtnFace;
      PolyLine([Point(Frame.Left + 1, Frame.Bottom - 1), Point(Frame.Right - 1,
        Frame.Bottom - 1),
        Point(Frame.Right - 1, Frame.Top)]);
      { Remainder of Sizing border }
      for Extra := 2 to (GetSystemMetrics(SM_CXFRAME) - 1) do
      begin
        Brush.Color := clBtnFace;
        FrameRect(Rect(Extra, Extra, Frame.Right - Extra + 1, Frame.Bottom - Extra +
          1));
      end;
      { Left and Top Edge of Caption Area }
      Pen.Color := clBtnShadow;
      PolyLine([Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1), Point(Frame_W -
        1,
          Frame_H - 1), Point(Frame.Right - Frame_W + 1, Frame_H - 1)]);
      { Right and Bottom Edge of Caption Area }
      Pen.Color := clBtnHighlight;
      PolyLine([Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1),
        Point(Frame.Right - Frame_W + 1, Frame_H + Caption_H + Menu_H - 1),
          Point(Frame.Right - Frame_W + 1, Frame_H - 1)]);
    end;
  finally
    Canvas.Free;
    ReleaseDC(Handle, DC);
  end;
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var
  HitCode: LongInt;
begin
  inherited;
  HitCode := Msg.Result;
  if ((HitCode = HTLEFT) or (HitCode = HTRIGHT) or (HitCode = HTTOP) or (HitCode =
    HTBOTTOM)
    or (HitCode = HTTOPLEFT) or (HitCode = HTBOTTOMLEFT) or (HitCode = HTTOPRIGHT) or
    (HitCode = HTBOTTOMRIGHT)) then
  begin
    HitCode := HTNOWHERE;
  end;
  Msg.Result := HitCode;
end;

Conditional defines for all compiler versions

Problem/Question/Abstract:

Conditional defines for all compiler versions

Answer:

The following standard conditional symbols tell you which compiler is used:

VER80
Delphi 1.x

VER90
Delphi 2.x

VER93
C++ Builder 1.0

VER100
Delphi 3.x

VER120
Delphi 4.x

VER130
Delphi 5.x

VER140
Delphi 6.x

How to copy selected items from a TListBox to the clipboard without using the VCL Clipbrd unit

Problem/Question/Abstract:

I want to copy selected items (only text) from a TListBox that has LBS_EXTENDEDSEL style to the standard clipboard using only API functions.

Answer:

This code is untested and requires the unit APIClipboard from Tip "Clipboard access routines which use only API functions".

procedure CopySelectedListboxItemsToClipboard(listboxwnd: HWND);

  function GetItem(num: Integer): string;
  begin
    SetLength(Result, SendMessage(listboxwnd, LB_GETTEXTLEN, num, 0));
    if Length(Result) > 0 then
      SendMessage(listboxwnd, LB_GETTEXT, num, LPARAM(@Result[1]));
  end;

var
  num: Integer;
  selIndices: array of Integer;
  sl: TStringlist;
  S: string;
begin
  num = SendMessage(listboxwnd, LB_GETSELCOUNT, 0, 0);
  if num = LB_ERR then
  begin
    {listbox is a single selection listbox}
    num := SendMessage(listboxwnd, LB_GETCURSEL, 0, 0);
    if num = LB_ERR then
      Exit; {no selected item}
    S := GetItem(num);
  end
  else
  begin
    SetLength(selIndices, num);
    SendMessage(listboxwnd, LB_GETSELITEMS, num, LPARAM(@selIndices[0]));
    sl := TStringlist.Create;
    try
      for num := 0 to High(selIndices) do
        sl.Add(GetItem(selIndices[num]));
      S := sl.Text;
    finally
      sl.free;
    end;
  end;
  StringToClipboard(S);
end;

How to automatically drop down the lookup list in a TDBGrid

Problem/Question/Abstract:

I'm trying to do this: On enter in a cell of a DBGrid that is of fkLookup FieldKind type show the lookup list immediately without clicking on the little button that appears when I click in the cell.

Answer:

Solve 1:

Here is a sample how to drop down the lookup list automatically when the user enters a column and the OnColEnter event is fired.

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
const
  MyFieldName: string = 'SomeFieldName';
var
  I: Integer;
  MyGrid: TCustomDBGrid;
begin
  MyGrid := Sender as TCustomDBGrid;
  if MyGrid.SelectedField.FullName = MyFieldName then
  begin
    { Put the grid in edit mode. }
    MyGrid.EditorMode := True;
    { TCustomGrid.InplaceEditor is declared as protected property and
                cannot be addressed directly.
                 Since the inplace editor window is a child window of the grid,
                we can find it. }
    for I := 0 to MyGrid.ControlCount - 1 do
    begin
      if MyGrid.Controls[I] is TInplaceEdit then
        { Simulate an Alt+DownArrow key stroke }
        PostMessage(TWinControl(MyGrid.Controls[I]).Handle, WM_KEYDOWN,
          VK_DOWN, $20000000);
      Break;
    end;
  end;
end;


Solve 2:

In the OnColEnter event, send an Alt-DownArrow keystroke:

{ ... }
if DBGrid1.SelectedField.FieldName = 'fieldname' then
begin
  DBGrid1.EditorMode := True;
  keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0);
  keybd_event(VK_DOWN, MapVirtualKey(VK_DOWN, 0), 0, 0);
  keybd_event(VK_DOWN, 0, KEYEVENTF_KEYUP, 0);
  keybd_event(VK_MENU, 0, KEYEVENTF_KEYUP, 0)
end;

Or use a cracker class to expose TCustomGrid.InplaceEditor:

type
  TCrackGrid = class(TDBGrid);
  { ... }

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
  with TCrackGrid(DBGrid1) do
    if SelectedField.FieldName = 'fieldname' then
    begin
      EditorMode := True;
      {send Alt-DownArrow keystroke}
      PostMessage(InplaceEditor.Handle, WM_KEYDOWN, VK_DOWN, $20000000)
    end;
end;

How to download a file from the web to a local drive

Problem/Question/Abstract:

I want to write an application that can download upgraded versions of itself.

Answer:

Solve 1:

If you are just going to download there is no need to use ActiveX controls. Windows has the function you need already declared in the UrlMon.dll. To download a file to a local disk just use this code. Note: This function is not described in Delphi Help nor in the Win32 Programmer's Reference.

uses
  URLMon;

{ ... }
if URLDownloadToFile(nil, 'http://go.to/masdp', 'c:\index.html', 0, nil) <> 0 then
  MessageBox(Handle, 'An error ocurred while downloading the file.', PChar(Application.Title), MB_ICONERROR or MB_OK);
{ ... }


Solve 2:

Downloading a file is not very difficult, something like:


uses
  Wininet;

var
  InternetBrowserUserAgent: string;
  {Set it as you like. Win98/IE uses 'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)' }

{ ... }

function GetInternetStream(URL: string; Stream: TStream): LongInt;
type
  TNetBuffer = array[0..1023] of Byte;
  PNetBuffer = ^TNetBuffer;
var
  ihConnect, iDocument: HINTERNET;
  NetBuffer: PNetBuffer;
  BufferSize: Integer;
  I: integer;
begin
  Result := -1;
  ihConnect := InternetOpen(PChar(InternetBrowserUserAgent), LOCAL_INTERNET_ACCESS, '', '', 0);
  try
    if ihConnect <> nil then
    begin
      iDocument := InternetOpenURL(ihConnect, PChar(URL), nil, Cardinal(-1),
        INTERNET_FLAG_RELOAD or INTERNET_FLAG_DONT_CACHE or
        INTERNET_FLAG_RAW_DATA, 0);
      try
        if iDocument <> nil then
        begin
          Result := 0;
          try
            New(NetBuffer);
            repeat
              InternetReadFile(iDocument, NetBuffer, SizeOf(TNetBuffer), BufferSize);
              if BufferSize > 0 then
              begin
                Result := Result + Stream.Write(NetBuffer^, BufferSize);
              end;
            until
              (BufferSize < SizeOf(TNetBuffer));
          finally
            Dispose(NetBuffer);
          end;
        end;
      finally
        internetCloseHandle(iDocument);
      end;
    end;
  finally
    InternetCloseHandle(ihConnect);
  end;
end;


If you call this function with a TFileStream, you have the file on your harddisk. If you have a ZIP, you probably want to unzip the file now, use a component that can do this (I think there are some around). The problem is that an application cannot replace itself (because it is write protected while it is running). The solution would be to call another application and terminate the first one. The second one has to update the first one (maybe wait a while until it is really terminated and not write protect any more) and start it again. If you just have to update non-executable files this is much easier. Another solution would be a separate update-application, that the user can call from somewhere (after he has closed the main application).

Creating a form without a title bar

Problem/Question/Abstract:

How can I create a form that doesn't have a caption, but can be re-sized?

Answer:

Solve 1:

As they say, "There's more than one way to skin a cat," and I can't agree more as far as programming is concerned. Let me share a little anecdote with you...

Being the "artistic dude" in my company, I'm always in search of new ways to present information to users. I do this by creating non-standard user interfaces (which I find rather boring), spicing them up with graphics and multimedia features. My philosophy centers around this question: Why should information retrieval be a boring task? Well, it shouldn't. And an extension to this question could be: Why do business programs have to all look the same? Well, they don't. So I choose to build "odd" business user interfaces.

My latest designs have followed game interfacess that use a plethora of high- resolution graphics and captionless forms (this is where it all kicks in). In the past, I didn't need my forms to move anywhere. But as my interfaces have become more complex, I've had to start providing ways to move them. Unfortunately, the method that I employed in the original article here, didn't account for clicking only in a certain area on a form. You just click and hold the mouse button down anywhere on the form, and the form will move. Unfortunately, that isn't always the best solution.

For instance, with one of my forms, I created a "pseudo" caption by aligning a TPanel at the top of the client area of my form. There's a bit more functionality built into the panel, but I wanted it to act very much like a regular caption: a click and drag would drag the form, and a double-click would maximize it. With that in mind, I set about writing the panel's click and drag method using what I originally wrote as a base. It didn't work. So doing a little research and asking a couple of questions around the newsgroups, Kerstin Thaler, a very helpful person, showed me a real cool method for implementing what I needed to do. Here it is:

procedure TMainFrm.Panel1MouseDown(Sender: TObject; Button:
  TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
  SC_DRAGMOVE = $F012;
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
  end;
end;

This is such incredibly easy code! Instead of overriding the default NC_HITTEST message handler, I could accomplish form movement from the MouseDown of my panel! Basically, all the method does is send a WM_SYSCOMMAND message to the form with the SC_DRAGMOVE constant to perform a drag move. Kerstin did say, that the $F012 isn't documented. But hey! the method works and it works well. So if you have a captionless form and want to move it by dragging from one of its child components, this is the way to do it!


Solve 2:

Many folks would say, "Just set the BorderStyle of the form to bsNone and you'll remove the caption." However, there's a problem with that suggestion: Not only do you lose the caption bar, you lose the entire border, which means you can't resize the form. The only way to get around this is to go behind the scenes in Delphi. Fortunately, it's a relatively simple process.

Delphi is not just ObjectPascal; it is also a very effective wrapper of the Windows API (Don't worry, we won't get into the Windows API too much in this article). In Windows, every window is created using one of two standard functions: CreateWindow and CreateWindowEx. CreateWindow makes a window with standard window styles, while CreateWindowEx is the same as CreateWindow, but you can add extended window styles to the window you want to create. (I encourage you to read through the help file for a thorough discussion of these two API calls since I won't be going into detail with these topics.)

When a form is created in Delphi, a call is made to CreateWindowEx &mdash TForm's Create method is the wrapper function for this call &mdash and Create passes a record structure to CreateWindowsEx through a virtual method of TForm called CreateParams.

CreateParams is a virtual method of TForm. This means you can override it which, in turn, means you can change the default style of a window when it's created to suit your particular needs. For our purposes, we want to eliminate the caption. That's easily done by changing the style bits of the LongInt Style field of the TCreateParams structure, the record that's passed to CreateWindowEx. Look at the code; we'll discuss particulars below:

unit NoCap;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    {Here's what we're overriding}
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMNCHitTest(var Msg: TWMNcHitTest); message WM_NCHITTEST;
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
  {or... Style := Style + WS_POPUP - WS_DLGFRAME; which is the
   equivalent to the above statement}
end;

procedure TForm1.WMNCHitTest(var msg: TWMNCHitTest);
begin
  inherited;
  if (msg.Result = htClient) then
    msg.Result := htCaption;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

end.

Notice in the line in CreateParams where I set the Style for the form: Style := (Style OR WS_POPUP) AND (NOT WS_DLGFRAME);. My first bit manipulation is Style OR WS_POPUP. This means give me the default style bits and make the window a regular pop-up window with a resizeable border. The second portion says don't include a dialog frame. With respect to this, the WS_DLGFRAME will produce a frame typical of dialog boxes. By masking it out, you remove the title bar. WS_POPUP ensures you have a resizeable border with which to work.

What about the WMNCHitTest message handler? Well, if you have a form with no title bar, you have absolutely no way to move it, because by convention, forms are moved by dragging the title bar. By trapping a mouse hit with the WM_NCHITTEST message and changing the default behavior of the mouse hit, you can allow dragging of the form from the client area.

Read through the Windows API help and look at all the style bits you can set. Play with different combinations to see what you get.

How to set the printer paper size (2)

Problem/Question/Abstract:

How I can select the printer's papersource through code? How I can read the printer default setting papersource in my Delphi program?

Answer:

{ ... }
var
  aDrvName, aPrtName, aPortName: array[0..127] of Char;
  aDeviceMode: THandle;
  PDevMode: ^TDevMode;
  i: Integer;
begin
  with Printer do
  begin
    GetPrinter(aDrvName, aPrtName, aPortName, aDeviceMode);
    PDevMode := GlobalLock(aDeviceMode);
    try
      if PDevMode^.dmPaperSize = DMPAPER_A4 then
        ShowMessage('A4')
      else if PDevMode^.dmPaperSize = DMPAPER_A3 then
        ShowMessage('A3')
      else
      begin
        ShowMessage('Size not supported!' + #13 + 'Resetting papersize to A4');
        PDevMode^.dmPaperSize := DMPAPER_A4;
      end;
    finally
      GlobalUnlock(aDeviceMode);
    end;
  end;
end;

How to save and load a TList to / from a stream

Problem/Question/Abstract:

Can anyone tell me how to stream a TList to a file? Given:

type
  PassWordItem = class(TObject)
    accountName: string[30];
    userName: string[25];
    passWd: string[10];
  end;

and...

PassWdList: TList;

How do I stream the contents of PassWdList to a file, and subsequently load TList from the file?

Answer:

Lets add a couple of methods to the PassWordItem class:


PassWordItem = class(TObject)
public
  accountName: string[30];
  userName: string[25];
  passWd: string[10];

  procedure SaveToStream(s: TStream);
  constructor CreatefromStream(S: TStream);
end;


With that you can write two procedures (or methods of a TPasswordList class derived from TList):


procedure SavePasswordlist(pwl: TLIst; S: TStream);
var
  i: Integer;
begin
  Assert(Assigned(pwl));
  Assert(Assigned(S));
  i := pwl.count;
  S.Write(i, sizeof(i));
  for i := 0 to pwl.count - 1 do
    PasswordItem(pwl[i]).SaveToStream(S);
end;

procedure LoadPasswordList(pwl: TList; S: TStream);
var
  count, n: Integer;
begin
  Assert(Assigned(pwl));
  Assert(Assigned(S));
  S.Read(count, sizeof(count));
  pwl.Capacity := count;
  for n := 1 to count do
    pwl.Add(PasswordItem.CreatefromStream(S));
end;

procedure Passworditem.SaveToStream(s: TStream);
begin
  Assert(Assigned(S));
  S.Write(accountname, Sizeof(accountname));
  S.Write(username, sizeof(username));
  S.Write(passwd, sizeof(passwd));
end;


constructor CreatefromStream(S: TStream);
begin
  Assert(Assigned(S));
  inherited Create;
  S.Read(accountname, Sizeof(accountname));
  S.Read(username, sizeof(username));
  S.Read(passwd, sizeof(passwd));
end;

How to toggle the AlwaysOnTop property of the Windows Taskbar

Problem/Question/Abstract:

Can anyone tell me how to set and reset the Windows TaskBar AlwaysOnTop property from within my application?

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  hw: HWND;
begin
  hw := FindWindow('Shell_TrayWnd', nil);
  if hw <> 0 then
  begin
    if (GetWindowLong(hw, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0 then
    begin
      label1.caption := 'Taskbar is topmost';
      SetWindowPos(hw, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE);
    end
    else
    begin
      label1.caption := 'Taskbar is not topmost';
      SetWindowPos(hw, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE);
    end;
  end;
end;

Get notified when another application terminates

Problem/Question/Abstract:

My application is starting processes invoking ShellExecute API calls. These processes are manipulating files stored in a database BLOB field. I'd like to be notified when the external application terminates in order to save shanges made on the file. My idea was to use windows hooks, but I didn't guess exactly how. ShellExecute returns the Instance Handle of the application that was run (or DDE handle).

Answer:

Solve 1:

How about using the WndProc procedure and listening for the WM_QUERYENDSESSION in the main application, and broadcasting another message to the other one. Then your applications do what they need to do when they receive the message. For example:

{MainApp:}

const
  EndAppMsg = $FFF8B;

  public

  procedure WndProc(var Msg: TMessage); override;

procdure TMainForm.WndProc(var Msg: TMessage);
begin
  if Msg.Msg = WM_QUERYENDSESSION then
  begin
    BroadcastSystemMessage(BSF_POSTMESSAGE, BSM_ALLCOMPONENTS, EndAppMsg, 0, 0)
  end
  else
    inherited;
end;

And then use the WndProc again in the other applications that the main application calls, and listen for the EndAppMsg message. When it is recived execute the code that you need to execute. For example:

{Client/Worker App}

procedure WndProc(var Msg: Tmessage);
const
  EnaAppMsg = $FFF8B;
begin
  if Msg.Msg = EndAppMsg then
  begin
    {Execute your code here or call another procedure to execute the code}
  end
  else
    inherited;
end;


Solve 2:

You might try using ShellExecuteEx instead, then using the returned hProcess in a WaitForSingleObject call. Here's an example I used in a small demo application:

uses
  Windows, ShellApi;

var
  Info: TShellExecuteInfo;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.cbSize := SizeOf(Info);
  Info.fMask := SEE_MASK_NOCLOSEPROCESS;
  Info.Wnd := Handle;
  Info.lpVerb := 'open';
  Info.lpFile := 'C:\SomeTextFile.Text'; {Change me!}
  Info.lpParameters := nil;
  Info.lpDirectory := nil;
  Info.nShow := SW_SHOW;
  if (ShellExecuteEx(@Info)) then
  begin
    WaitForSingleObject(Info.hProcess, INFINITE);
    MessageBox(Handle, 'You closed the app I launched!', 'Finished!', MB_OK);
    CloseHandle(Info.hProcess);
  end;
end;

I'm not sure if you want your entire application becoming unresponsive while the launched application is running (the WaitForSingleObject call doesn't return until the application is closed), but if you don't, you might consider launching individual threads for each ShellExecuteEx, then using WaitForSingleObject in those threads (and writing an OnTerminate handler for the thread object to determine when the application finally finished).

Read a sender address for MailItem (MS Outlook)

Problem/Question/Abstract:

How can I retrieve SenderAddress by SenderName?

Answer:

Sometime ago I posted a few tips for MS Outlook automation. I want to continue this serie.

If you tried to work with messages from Delphi, you know that received message have the SenderName property (name of sender) but doesn't allow to read the real address of sender. Something like SenderAddress is not  available.

Exists a few methods to retrieve this information:

1. help file says that sender is in Recipients collection with Type property - 0 (olOriginator). But this way is not work for any version of MS Outlook. So just iterate thru collection of Recipients and find an item with Type=0 couldn't return required value

2. as alternative you can read a ReplyTo property - there you'll receive an address (but generally ReplyTo and Sender could be different). For example, in messages which I send from own mail account these values are
different.

3. to create a new MailItem (just will be destroyed without saving in end of work), define a Recipient as value which you received from SenderName of your original message and call a Resolve method - after that you'll recieve a correct email address of this sender.

4. more correct and fast solution is the next:

begin
  objCDO := CreateOLEObject('MAPI.Session');
  objCDO.Logon('', '', False, False);
  objMsg := objCDO.GetMessage(itemOL.EntryID, itemOL.Parent.StoreID);

  s := objMsg.Sender.Address;
  showmessage(s);
  objMsg := UnAssigned;
  objCDO := UnAssigned;
end

where itemOL is a MailItem which contain a SenderName but doesn't contain a SenderAddress:-)

Sort list items of a TListView with integer values as captions

Problem/Question/Abstract:

I have an integer value as ListItem caption (using InttoStr). I would like to sort according to the Integer value of these captions. Any Ideas?

Answer:

function Cussort(Item1, Item2: TListItem; lParamSort: Integer): Integer; stdcall;
var
  I1, I2: Integer;
begin
  I1 := StrToIntDef(Item1.Caption, -1);
  I2 := StrToIntDef(Item2.Caption, -1);
  if I1 > I2 then
    Result := 1
  else if I2 < I1 then
    Result := -1
  else
    Result := 0;
end;

MyListView.CustomSort(@Cussort, 0);

How to modify the color of a TCheckBox

Problem/Question/Abstract:

How to modify the color of a TCheckBox

Answer:

I would do the drawing in the CN_DRAWITEM message handler. Below is the code of such a checkbox:

{ ... }
type
  TMyCheckBox = class(TCheckBox)
  protected
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CMEnabledchanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetChecked(Value: Boolean); override;
    procedure SetButtonStyle;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { ... }

constructor TMyCheckBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csDoubleClicks];
end;

procedure TMyCheckBox.CNDrawItem(var Message: TWMDrawItem);
var
  XCanvas: TCanvas;
  XCaptionRect, XGlyphRect: TRect;

  procedure xxDrawBitMap(ACanvas: TCanvas);
  const
    xx_h = 13;
    xx_w = 13;
  var
    xxGlyph: TBitmap;
    xxX, xxY, xxStepY, xxStepX: integer;
  begin
    xxGlyph := TBitmap.Create;
    try
      xxGlyph.Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));
      xxY := XGlyphRect.Top + (XGlyphRect.Bottom - XGlyphRect.Top - xx_h) div 2;
      xxX := 2;
      xxStepX := 0;
      xxStepY := 0;
      if Enabled then
      begin
        case State of
          cbChecked:
            xxStepX := xxStepX + xx_w;
          cbGrayed:
            xxStepX := xxStepX + xx_w * 3;
        end;
      end
      else if State = cbChecked then
        xxStepX := xxStepX + xx_w * 3
      else
        xxStepX := xxStepX + xx_w * 2;
      ACanvas.CopyRect(Rect(xxX, xxY, xxX + xx_w, xxY + xx_h), xxGlyph.Canvas,
        Rect(xxStepX, xxStepY, xx_w + xxStepX, xx_h + xxStepY));
    finally
      xxGlyph.Free;
    end;
  end;

  procedure xxDrawCaption;
  var
    xXFormat: longint;
  begin
    xXFormat := DT_VCENTER + DT_SINGLELINE + DT_LEFT;
    xXFormat := DrawTextBiDiModeFlags(xXFormat);
    DrawText(Message.DrawItemStruct.hDC, PChar(Caption),
      length(Caption), XCaptionRect, xXFormat);
  end;

begin
  XGlyphRect := Message.DrawItemStruct.rcItem;
  XGlyphRect.Right := 20;
  XCaptionRect := Message.DrawItemStruct.rcItem;
  XCaptionRect.Left := XGlyphRect.Right;
  XCanvas := TCanvas.Create;
  try
    XCanvas.Handle := Message.DrawItemStruct.hDC;
    XCanvas.Brush.Style := bsClear;
    xxDrawBitMap(XCanvas);
    xxDrawCaption;
  finally
    XCanvas.Free;
  end;
end;

procedure TMyCheckBox.CMEnabledchanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TMyCheckBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_Transparent;
end;

procedure TMyCheckBox.CreateWnd;
begin
  inherited CreateWnd;
  SetButtonStyle;
end;

procedure TMyCheckBox.SetChecked(Value: Boolean);
begin
  inherited SetChecked(Value);
  Invalidate;
end;

procedure TMyCheckBox.SetButtonStyle;
const
  BS_MASK = $000F;
var
  Style: Word;
begin
  if HandleAllocated then
  begin
    Style := BS_CHECKBOX or BS_OWNERDRAW;
    if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
      SendMessage(Handle, BM_SETSTYLE, Style, 1);
  end;
end;

Painting the Form Menu bar

Problem/Question/Abstract:

When i uses programs like the game freecell that comes with windows 9x i see that there is a text in the menu bar tht tells me how many cards left me.

How can i make something like that in my programs ?

Answer:

Well, First of all we need to put a main menu component on our form.
Now set the OwnerDraw property to true.

If you have an item that you wish to paint by yourself, now is the time to create it and to make the OnDrawItem.
In this line you put also this line:

{... }
ACanvas.TextOut(1, ARect.Top + 1, 'I''m in the MainMenuDrawbar');
{... }

Note, If you need to use a changed variable you can do it from another function and ll you need to do afther the change is to call the API function DrawMenuBar.

If you are using Delphi 2,3 Use the Messages WM_MESUREITEM and the message WM_DRAWITEM to make this effect.

How to print bitmaps and controls placed on a TPanel

Problem/Question/Abstract:

I have placed several images and assorted graphic controls on a TPanel. Now I want to print it. My problem is that the panel does not have a canvas property. Somehow I should be able to manipulate the "graphics" on the panel. What I thought might work is to do a screen capture of the panel area, but I am not sure what the function calls are. Does anybody have any ideas? I want to be able to scale the image and print it to a specific part of the page.

Answer:

The form has a canvas. You can create a new bitmap the same size as your panel and then use CopyRect to copy the panel and its content from the form to this in- memory bitmap. Then you can print the in-memory bitmap. Here's an example:

procedure TFormPrintWindows.ButtonPrintPanelClick(Sender: TObject);
var
  Bitmap: TBitmap;
  FromLeft, FromTop, PrintedWidth, PrintedHeight: Integer;
begin
  Printer.BeginDoc;
  try
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Panel1.Width;
      Bitmap.Height := Panel1.Height;
      Bitmap.PixelFormat := pf24bit; {Avoid palettes}
      {Copy the panel area from the form into a separate bitmap}
      Bitmap.Canvas.CopyRect(Rect(0, 0, Bitmap.Width, Bitmap.Height),
                        FormPrintWindows.Canvas, Rect(Panel1.Left, Panel1.Top, Panel1.Left +
                        Panel1.Width - 1, Panel1.Top + Panel1.Height - 1));
      {Assumes 10% left, right and top margin}
      {Assumes bitmap aspect ratio > ~0.75 for portrait mode}
      PrintedWidth := MulDiv(Printer.PageWidth, 80, 100); {80%}
      PrintedHeight := MulDiv(PrintedWidth, Bitmap.Height, Bitmap.Width);
      FromLeft := MulDiv(Printer.PageWidth, 10, 100); {10%}
      FromTop := MulDiv(Printer.PageHeight, 10, 100); {10%}
      PrintBitmap(Printer.Canvas, Rect(FromLeft, FromTop, FromLeft + PrintedWidth,
        FromTop + PrintedHeight), Bitmap);
    finally
      Bitmap.Free
    end;
  finally
    Printer.EndDoc
  end;
end;

Can your video handle 16, 256, 32768, 16777216, or more colors

Problem/Question/Abstract:

Can your video handle 16, 256, 32768, 16777216, or more colors?

Answer:

You can use WIN API function GetDeviceCaps() to calculate the number of colors supported by the current video mode. To make it even easier to use, here's a function that will simply return the number of maximum simultaneous colors current video device can handle:

function GetColorsCount: integer;
var
  h: hDC;
begin
  Result := 0;
  try
    h := GetDC(0);
    Result :=
      1 shl
      (
      GetDeviceCaps(h, PLANES) *
      GetDeviceCaps(h, BITSPIXEL)
      );
  finally
    ReleaseDC(0, h);
  end;
end;

How to use TCollection and TCollectionItem

Problem/Question/Abstract:

Has anyone out there attempted to use TCollection and TCollectionItem? What I am trying to do is mimic what the Columns Editor does in the TDBGrid for the TStringGrid component. This is the first time that I have made a component that needs properties and sub-properties. I am not sure how to go about this.

Answer:

This one worked for me:


unit ggImgLst;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs,
  ExtCtrls, Dsgnintf; {, jpeg;}

type
  TAboutProperty = class(TPropertyEditor)
  private
  protected
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetName: string; override;
    function GetValue: string; override;
  end;

  TggImageListPropertyEditor = class(TPersistent);

  TggImageListProperty = class(TClassProperty);

  TggImageSizes = (ggSmall, ggMedium, ggLarge);
  {TggImageSize  = set of TggImageSizes;}

  TggImage = class;
  TggImageList = class;

  TggImage = class(TCollectionItem)
  private
    FSize: TggImageSizes;
    FPicture: TPicture;
    FName: string;
    function GetDisplayName: string; override;
    procedure SetPicture(Value: TPicture);
  public
    constructor Create(Collection: TCollection); override;
    destructor destroy; override;
  published
    property Size: TggImageSizes read FSize write FSize;
    property Name: string read FName write FName;
    property Picture: TPicture read FPicture write SetPicture;
  end;

  TggImageClass = class of TggImage;

  TggImages = class(TCollection)
  private
    FggImageList: TggImageList;
    FggImageListPropertyEditor: TggImageListPropertyEditor;
    function GetImage(Index: Integer): TggImage;
    procedure SetImage(Index: Integer; Value: TggImage);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor create(ggImageList: TggImageList; ggImageClass: TggImageClass);
    function Add: TggImage;
    property ggImageList: TggImageList read FggImageList;
    property Items[Index: Integer]: TggImage read GetImage write SetImage; default;
  published
  end;

  TggImageList = class(TComponent)
  private
    FAbout: TAboutProperty;
    FImages: TggImages;
    procedure WriteImages(Writer: TWriter);
    procedure ReadImages(Reader: TReader);
    procedure SetImages(Value: TggImages);
  protected
    function CreateImages: Tggimages; dynamic;
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner: TComponent); override;
    function GetImageNameList: TStringList;
    function GetPicture(PictureName: string): TPicture;
  published
    property About: TAboutProperty read FAbout write FAbout;
    property Images: TggImages read FImages write SetImages;
  end;

procedure Register;

implementation

uses
  jpeg;

{ggImage}

constructor TggImage.Create(Collection: TCollection);
var
  ggImageList: TggImageList;
begin
  FPicture := TPicture.Create;
  ggImageList := nil;
  if assigned(Collection) and (Collection is TggImages) then
    ggImageList := Tggimages(Collection).ggImageList;
  if assigned(ggImageList) then
    inherited Create(Collection);
end;

destructor TggImage.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;

procedure TggImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

function TggImage.GetDisplayName: string;
begin
  Result := Name;
  if Result = '' then
    Result := inherited GetDisplayName;
end;

{TggImages}

function TggImages.GetImage(Index: Integer): TggImage;
begin
  Result := TggImage(inherited Items[Index]);
end;

procedure TggImages.SetImage(Index: Integer; Value: TggImage);
begin
  Items[Index].Assign(Value);
end;

constructor TggImages.Create(ggImageList: TggImageList;
  ggImageClass: TggImageClass);
begin
  inherited Create(ggImageClass);
  FggImageList := ggImageList;
  FggImageListPropertyEditor := TggImageListPropertyEditor.Create;
end;

function TggImages.GetOwner: TPersistent;
begin
  Result := FggImageList;
end;

function TggImages.Add: TggImage;
begin
  Result := TggImage(inherited Add);
end;

{ggImageList}

procedure TggImageList.WriteImages(Writer: TWriter);
begin
  Writer.WriteCollection(Images);
end;

procedure TggImageList.ReadImages(Reader: TReader);
begin
  Images.Clear;
  Reader.ReadValue;
  Reader.ReadCollection(Images);
end;

procedure TggImageList.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('ggImages', ReadImages, WriteImages, Filer.Ancestor < > nil);
end;

procedure TggImageList.SetImages(Value: TggImages);
begin
  Images.Assign(Value);
end;

function TggImageList.CreateImages: TggImages;
begin
  Result := TggImages.Create(Self, TggImage);
end;

function TggImageList.GetImageNameList: TStringList;
var
  I: Integer;
begin
  Result := TStringList.Create;
  for I := 0 to Self.Images.Count - 1 do
    Result.Add(Self.Images.Items[I].Name);
end;

function TggImageList.GetPicture(PictureName: string): TPicture;
var
  I: Integer;
begin
  I := 0;
  Result := nil;
  PictureName := uppercase(Picturename);
  while I <= Self.Images.Count - 1 do
  begin
    if PictureName = uppercase(Self.Images.Items[I].Name) then
    begin
      Result := Self.Images.Items[I].Picture;
      I := Self.Images.Count;
    end
    else
      Inc(I);
  end;
end;

constructor TggImageList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FImages := CreateImages;
end;

{TAboutProperty}

procedure TAboutProperty.Edit;
begin
  MessageBox(0, PChar('TggImageList component' + #13 + #13 + 'by Geurts Guido -
    guido.geurts@advalvas.be ' + #13 + ' 10 / 03 / 1999'),
    PChar('The GuidoG utilities present...'), MB_OK);
end;

function TAboutProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paReadOnly];
end;

function TAboutProperty.GetName: string;
begin
  Result := 'About';
end;

function TAboutProperty.GetValue: string;
begin
  Result := GetStrValue;
end;

{Non class related procedures and functions:}

procedure register;
begin
  RegisterComponents('GuidoG', [TggImageList]);
  RegisterPropertyEditor(TypeInfo(TggImageListPropertyEditor), TGGImages,
    'Images', TGGImageListProperty);
  RegisterPropertyEditor(TypeInfo(TAboutProperty), TggImageList, 'About',
    TAboutProperty);
end;

end.

How to access a single object in a metafile

Problem/Question/Abstract:

How to access a single object in a metafile

Answer:

Below is an example of getting metafile information and enumerating each metafile record :

function MyEnhMetaFileProc(DC: HDC; {handle to device context}
  lpHTable: PHANDLETABLE; {pointer to metafile handle table}
  lpEMFR: PENHMETARECORD; {pointer to metafile record}
  nObj: integer; {count of objects}
  TheForm: TForm1): integer; stdcall;
begin
  {draw the metafile record}
  PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
  {set to zero to stop metafile enumeration}
  result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyMetafile: TMetafile;
  lpENHMETAHEADER: PENHMETAHEADER; {extra metafile info}
  lpENHMETAHEADERSIZE: DWORD;
  NumMetaRecords: DWORD;
begin
  {Create a metafile}
  MyMetafile := TMetafile.Create;
  with TMetafileCanvas.Create(MyMetafile, 0) do
  try
    Brush.Color := clRed;
    Ellipse(0, 0, 100, 100);
    Ellipse(100, 100, 200, 200);
    Ellipse(200, 200, 300, 300);
    Ellipse(300, 300, 400, 400);
    Ellipse(400, 400, 500, 500);
    Ellipse(500, 500, 600, 600);
  finally
    Free;
  end;
  {we might as well get some extra metafile info}
  lpENHMETAHEADERSIZE := GetEnhMetaFileHeader(MyMetafile.Handle, 0, nil);
  NumMetaRecords := 0;
  if (lpENHMETAHEADERSIZE > 0) then
  begin
    GetMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
    GetEnhMetaFileHeader(MyMetafile.Handle, lpENHMETAHEADERSIZE, lpENHMETAHEADER);
    {Here is an example of getting number of metafile records}
    NumMetaRecords := lpENHMETAHEADER^.nRecords;
    {enumerate the records}
    EnumEnhMetaFile(Canvas.Handle, MyMetafile.Handle, @MyEnhMetaFileProc, self,
      Rect(0, 0, 600, 600));
    FreeMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
  end;
  MyMetafile.Free;
end;

Reference a column of a TDBGrid by name instead of integer index

Problem/Question/Abstract:

Is there a way in TDBGrid to reference a column by name rather than by integer index? Right now I am using "ListGrd.Columns[ 5 ]" (for example) to access a particular column but that is dangerous if moving columns is enabled. Can I reference a column by a column name instead?

Answer:

function TForm1.ColumnByFieldName(AGrid: TDBGrid; const AFieldName: string): TColumn;
var
  I: Integer;
begin
  for I := 0 to AGrid.Columns.Count - 1 do
  begin
    Result := AGrid.Columns[I];
    if AnsiCompareText(Result.FieldName, AFieldName) = 0 then
      Exit;
  end;
  raise Exception.Create(AGrid.Name + ', ' + AFieldName);
end;

How to create a countdown timer (2)

Problem/Question/Abstract:

All I want to do is to read the system time of the computer, then read it again a little later, and compare the times. I want hours, minutes, seconds and milliseconds. I have looked into TimeStamp and GetSystemTime, but I just can't get it to work. What should I do?

Answer:

var
  T0, T1: TDateTime;
  ElapsedSeconds: Double;
begin
  T0 := Now;
  { ... }
  T1 := Now;
  ElapsedSeconds := 86400.0 * (T1 - T0);
end;

How to put the content of a TStringGrid into an Excel range

Problem/Question/Abstract:

How to put the content of a TStringGrid into an Excel range

Answer:

{ ... }
var
  ArrV: Variant;
  Cell: Range;
  { ... }

ArrV := VarArrayCreate([0, NumRows, 0, NumCols], varOleStr);
for Row := 0 to NumRows do
  for Col := 0 to NumCols do
    ArrV[Row, Col] := StringGrid1.Cells[Col, Row];
Cell := Excel.ActiveCell;
WS.Range[Cell, Cell.Offset[NumRows, NumCols]].Value := ArrV;
{ ... }

Retrieve a list of available BDE language drivers

Problem/Question/Abstract:

How can I retrieve a list of available BDE language drivers?  

Answer:

The following Delphi procedure returns a formatted list of available BDE language drivers. The procedure can be called as shown in the buttonclick method below.

Add BDE and DBTables to your unit's uses clause.

procedure GetLdList(Lines: TStrings);
var
  hCur: hDBICur;
  LD: LDDesc;
  cnt: integer;
begin
  // get a cursor to the in-mem table containing language
  // driver information...
  cnt := 0;
  check(dbiinit(nil));
  Check(DbiOpenLdList(hCur));
  try
    while (DbiGetNextRecord(hCur, dbiNOLOCK, @LD, nil) = DBIERR_NONE) do
    begin
      cnt := cnt + ;
      Lines.Add(format('%4d %-6s%- 0s %- 0s%5s %- 0s %- 0s', [cnt, 'Name:', LD.szName,
        'Code Page:', IntToStr(LD.iCodePage), 'Description:', LD.szDesc]));
    end;
  finally Check(DbiCloseCursor(hCur));
    check(dbiexit);
  end;
end;

procedure TForm.Button Click(Sender: TObject);
begin
  getldlist(memo.lines);
end;

end.

How to compare two strings and measure the percentage they match

Problem/Question/Abstract:

Does anyone know how or does anyone know of a good procedure to match two strings? What I want is a % match between two strings. Something like Hart and Harts are 80% equal.

Answer:

uses
  math;

function IsStrMatch(s1, s2: string): Double;
var
  i, iMin, iMax, iSameCount: Integer;
begin
  iMax := Max(Length(s1), Length(s2));
  iMin := Min(Length(s1), Length(s2));
  iSameCount := -1;
  for i := 0 to iMax do
  begin
    if i > iMin then
      break;
    if s1[i] = s2[i] then
      Inc(iSameCount)
    else
      break;
  end;
  if iSameCount > 0 then
    Result := (iSameCount / iMax) * 100
  else
    Result := 0.00;
end;

How to create non-selectable separator lines in a TComboBox

Problem/Question/Abstract:

How to create non-selectable separator lines in a TComboBox

Answer:

Note that the Combobox1.Style is csOwnerDrawvariable.

procedure TForm1.FormCreate(Sender: TObject);
begin
  with combobox1 do
  begin
    items.add('Item 1');
    items.add('Item 2');
    items.addObject('Item 3', Pointer(1));
    Perform(CB_SetItemHeight, 2, ItemHeight + 5);
    items.add('Item 4');
    items.add('Item 5');
  end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer);
begin
  Height := (Control as TCombobox).Itemheight;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  needsSeparator: Boolean;
begin
  with Control as TCombobox do
  begin
    needsSeparator := Assigned(Items.Objects[index]) and not (odComboBoxEdit in State);
    if needsSeparator then
      Rect.Bottom := Rect.Bottom - 5;
    Canvas.FillRect(Rect);
    Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[index]);
    if needsSeparator then
    begin
      Rect.Top := Rect.Bottom;
      Rect.Bottom := Rect.Bottom + 5;
      Canvas.Brush.Color := color;
      Canvas.Pen.Color := font.Color;
      Canvas.Pen.Style := psSolid;
      Canvas.Fillrect(Rect);
      Canvas.MoveTo(rect.left, rect.top + 2);
      Canvas.LineTo(rect.right, rect.top + 2);
    end;
  end;
end;

Get filepath from shortcut

Problem/Question/Abstract:

How to obtain the linked file from a shortcut

Answer:

uses ShellAPI;

function ExeFromLink(const linkname: string): string;
var
  FDir,
    FName,
    ExeName: PChar;
  z: integer;
begin
  ExeName := StrAlloc(MAX_PATH);
  FName := StrAlloc(MAX_PATH);
  FDir := StrAlloc(MAX_PATH);
  StrPCopy(FName, ExtractFileName(linkname));
  StrPCopy(FDir, ExtractFilePath(linkname));
  z := FindExecutable(FName, FDir, ExeName);
  if z > 32 then
    Result := StrPas(ExeName)
  else
    Result := '';
  StrDispose(FDir);
  StrDispose(FName);
  StrDispose(ExeName);
end;

How to catch windows keystrokes and pass them to an assigned event

Problem/Question/Abstract:

How to catch windows keystrokes and pass them to an assigned event

Answer:

For those interested, here's a keyboard hook component that catches windows keystrokes and passes them to an assigned event.

unit KeyboardHook;
{
  By William Egge
  Sep 20, 2002
  egge@eggcentric.com
  http://www.eggcentric.com

  This code may be used/modified however you wish.
}

interface

uses
  Windows, Classes;

type
  TCallbackThunk = packed record
    POPEDX: Byte;
    MOVEAX: Byte;
    SelfPtr: Pointer;
    PUSHEAX: Byte;
    PUSHEDX: Byte;
    JMP: Byte;
    JmpOffset: Integer;
  end;

  {See windows help on KeyboardProc or press F1 while your cursor is on "KeyboardProc"}
  TKeyboardCallback = procedure(code: Integer; wparam: WPARAM; lparam: LPARAM) of
    object;

  TKeyboardHook = class(TComponent)
  private
    { Private declarations }
    FHook: HHook;
    FThunk: TCallbackThunk;
    FOnCallback: TKeyboardCallBack;
    function CallBack(code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
    procedure SetOnCallback(const Value: TKeyboardCallBack);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property OnCallback: TKeyboardCallBack read FOnCallback write SetOnCallback;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EggMisc', [TKeyboardHook]);
end;

{ TKeyboardHook }

function TKeyboardHook.CallBack(code: Integer; wparam: WPARAM; lparam: LPARAM):
  LRESULT;
begin
  if Code < 0 then
    Result := CallNextHookEx(FHook, Code, wparam, lparam)
  else
  begin
    if Assigned(FOnCallback) then
      FOnCallback(Code, wParam, lParam);
    Result := 0;
  end;
end;

constructor TKeyboardHook.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FThunk.POPEDX := $5A;
  FThunk.MOVEAX := $B8;
  FThunk.SelfPtr := Self;
  FThunk.PUSHEAX := $50;
  FThunk.PUSHEDX := $52;
  FThunk.JMP := $E9;
  FThunk.JmpOffset := Integer(@TKeyboardHook.Callback) - Integer(@FThunk.JMP) - 5;
  FHook := SetWindowsHookEx(WH_KEYBOARD, TFNHookProc(@FThunk), 0, MainThreadID);
end;

destructor TKeyboardHook.Destroy;
begin
  UnhookWindowsHookEx(FHook);
  inherited;
end;

procedure TKeyboardHook.SetOnCallback(const Value: TKeyboardCallBack);
begin
  FOnCallback := Value;
end;

end.