Un-registering an OLE server

Problem/Question/Abstract:

How do you get rid of a "registered" ServerName if you don't want to use it any longer?

Answer:

Run the executable with the /UNREGSERVER flag:

MYSERVER.EXE /UNREGSERVER

This is the standard way of unregistering a self-registering OLE automation server.

Create a full screen form without auto-hiding the Windows Taskbar

Problem/Question/Abstract:

How do I set my form to display in full screen? No title bar, no borders, and it goes over the task bar (not by setting the task bar to "Auto Hide").

Answer:

Emulating full screen mode:

private {in form declaration}

procedure WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;

procedure TForm1.WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo);
begin
  inherited;
  with msg.MinMaxInfo^.ptMaxTrackSize do
  begin
    X := GetDeviceCaps(Canvas.handle, HORZRES) + (Width - ClientWidth);
    Y := GetDeviceCaps(Canvas.handle, VERTRES) + (Height - ClientHeight);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
const
  Rect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
  FullScreen: Boolean = False;
begin
  FullScreen := not FullScreen;
  if FullScreen then
  begin
    Rect := BoundsRect;
    SetBounds(Left - ClientOrigin.X, Top - ClientOrigin.Y,
      GetDeviceCaps(Canvas.handle, HORZRES)
      + (Width - ClientWidth), GetDeviceCaps(Canvas.handle, VERTRES) + (Height -
      ClientHeight));
    {Label2.caption := IntToStr(GetDeviceCaps( Canvas.handle, VERTRES ));}
  end
  else
    BoundsRect := Rect;
end;

How to create a system wide windows hook

Problem/Question/Abstract:

How to create a system wide windows hook

Answer:

The following example demonstrates creating a system wide windows hook under Win32. The example provides both the code for the system hook dll and an example application. The hook function that we will create will also demonstrate advanced coding techniques such as sharing global memory across process boundaries using memory mapped files, sending messages from the key hook function back to the originating application, and dynamic loading of a dll at runtime.

The example keyboard hook that we create will keep a count of the number of keystrokes a user enters on the keyboard. Further, we will demonstrate trapping the enter key, and passing a message back to the application that initiated the keyboard hook each time the enter key is pressed. Finally, we will demonstrate trapping the left arrow key and instead of letting it through to the current application, we will instead replace it with a right arrow keystroke. (Note: that this can cause much confusion to a unsuspecting user).

Adding a hook to the windows system involves calling the Windows API function SetWindowsHookEx() and passing it the type of hook you wish to install, and address of the hook function you are installing. System wide hook functions are required to reside in a dynamic link library, since they must be mapped into each process on the system. The SetWindowsHookEx() function adds your hook function into the Windows "hook chain", returning a handle (or id) of the hook you are installing. You will use this handle to identify your hook to windows, and to remove your hook when you are done trapping the keyboard.

The Windows "hook chain" is a linked list of functions that Windows uses to keep track of all the installed hooks, allowing multiple hooks to be installed at any given time. Occasionally, Windows will ask your hook function to call the next hook in the chain, allowing all the hooks an opportunity to function. When we do call the next hook in the chain, we will need to identify ourselves by passing the handle of our hook function to the next hook.

Creating a Windows hook requires special handling under Win32, since the dll must be mapped (on the fly) into the process space of every application that receives keystrokes. Normally, this is not an issue, however, when operating inside a keyhook procedure, global variables (such as your hook handle) must be preserved while the dll is mapped into other process spaces. Under Win16, this would not be a program, since dlls had a single data segment that was shared across all process mappings. Under Win32, each mapping of the dll receives its own data segment. This means that as the dll that contains the keyboard hook is mapped into each process that receives keystrokes, it receives a new data segment, and new unitialized variables with it. This is a problem, since global variables (such as your hook handle) must be preserved across process mappings. To solve this problem, we will take advantage of Win32's ability to memory map variables from the system paging file.

Each time our dll is mapped into a process, the DllMain() function in our dll will be called by windows, with a parameter flag indicating the reason for the call. When we receive the DLL_PROCESS_ATTACH flag (indicating our dll is getting mapped into a different process), we will create a file mapping to the system paging file and get a pointer to our memory mapped variables. When we receive the DLL_PROCESS_DETACH flag (indicating our dll is getting un-mapped from a process), we will free our file mapping of the system paging file. The variables we will need to keep track of (and have access to from both the dll and the application that originally loaded the keyboard hook) are placed in a record structure called THookRec. The THookRec structure has the following fields:



TheHookHandle:

The handle (id) of the Keyboard hook that we set. We will need access to this variable during the execution of the keyhook function, to identify ourselves to windows when we are asked to call the next hook in the hook chain. We will also need access to this variable when we remove our hook. Finally, the originating application that will receive the messages from our hook function can access this variable to see if and when the hook is active.



TheAppWinHandle:

While this variable is not used in our example dll or application, it is a starting place for adding additional messaging capabilities between the hook function and your application that initiates the hook. It can also be useful for determining if the hook is functioning while mapped into the context of the initiating application.



TheCtrlWinHandle:

This variable will hold the handle to a button control in our initiating application. We will use this handle to send messages from the keyboard hook function to the button control. Every time the enter key is pressed, we will send a WM_KEYDOWN and a WM_KEYUP message to the button and a key value of 0 (zero). We will trap the OnKeyDown event in the button control, and keep count of the number of times the user presses the enter key.



TheKeyCount:

This variable will keep track of the total number of key presses made by the user. Obviously our keyhook will need access to this variable to increment its value, and the originating application that will receive the messages from our hook function will want to access this variable to display real time results.



The DLL contains the following functions:

MapFileMemory:
Creates a system paging file mapping object and initializes a pointer to our mapping variable of type THookRec.

UnMapFileMemory:
Frees the system paging file mapping object and mapping variable created by the MapFileMemory() function.

GetHookRecPointer:
An exported function that returns a pointer to the mapping variable created by the MapFileMemory() function. The initiating application can both set and examine this memory block, and effectively share memory that is used by our hook function during the time the hook function is operating in the context of another process space.

KeyBoardProc:
The actual hook function. This function receives both keydown, and keyup messages as well as a message from windows indicating we should call the next hook in the windows "hook chain". This function increments TheKeyCount field of the memory mapped THookRec structure if the keystroke we are processing is a keyup message. If the key being processed is the enter key, we will fire the OnKeyDown event of the window provided in "TheCtrlWinHandle" field of the memory mapped THookRec structure. Finally, if the left arrow key is pressed, we will swallow the keystroke, and instead send a right arrow key stroke to the application. Note that the following variables and initializing code has been included in this function for your convience. The variables have been commented out in the code (as not to compile). To use them, simply remove the comments in the code:

IsAltPressed  {Determines if the Alt key is currently down}
IsCtrlPressed  {Determines if the Control key is currently down}
IsShiftPressed  {Determines if the Shift key is currently down}


StartKeyBoardHook:
An exported function that allows the application to initiate installing the keyboard hook.

StopKeyBoardHook:
An exported function that allows the application to initiate removing the keyboard hook.

DllEntryPoint:
The main entry point into our dll, allowing us to know when our dll is being mapped in, and out of, different application's address space.



Delphi Hook DLL Example:



library TheHook;

uses
  Windows, Messages, SysUtils;

{Define a record for recording and passing information process wide}
type
  PHookRec = ^THookRec;
  THookRec = packed record
    TheHookHandle: HHOOK;
    TheAppWinHandle: HWND;
    TheCtrlWinHandle: HWND;
    TheKeyCount: DWORD;
  end;

var
  hObjHandle: THandle; {Variable for the file mapping object}
  lpHookRec: PHookRec; {Pointer to our hook record}

procedure MapFileMemory(dwAllocSize: DWORD);
begin
  {Create a process wide memory mapped variable}
  hObjHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, dwAllocSize,
    'HookRecMemBlock');
  if (hObjHandle = 0) then
  begin
    MessageBox(0, 'Hook DLL', 'Could not create file map object', MB_OK);
    exit;
  end;
  {Get a pointer to our process wide memory mapped variable}
  lpHookRec := MapViewOfFile(hObjHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize);
  if (lpHookRec = nil) then
  begin
    CloseHandle(hObjHandle);
    MessageBox(0, 'Hook DLL', 'Could not map file', MB_OK);
    exit;
  end;
end;

procedure UnMapFileMemory;
begin
  {Delete our process wide memory mapped variable}
  if (lpHookRec <> nil) then
  begin
    UnMapViewOfFile(lpHookRec);
    lpHookRec := nil;
  end;
  if (hObjHandle > 0) then
  begin
    CloseHandle(hObjHandle);
    hObjHandle := 0;
  end;
end;

function GetHookRecPointer: pointer stdcall;
begin
  {Return a pointer to our process wide memory mapped variable}
  result := lpHookRec;
end;

{The function that actually processes the keystrokes for our hook}

function KeyBoardProc(Code: integer; wParam: integer; lParam: integer): integer;
  stdcall;
var
  KeyUp: bool;
  {Remove comments for additional functionability ... :

  IsAltPressed: bool;
  IsCtrlPressed: bool;
  IsShiftPressed: bool;
  }
begin
  result := 0;
  case Code of
    HC_ACTION:
      begin
        {We trap the keystrokes here}
        {Is this a key up message?}
        KeyUp := ((lParam and (1 shl 31)) <> 0);

        {Remove comments for additional functionability ... :

        {Is the Alt key pressed}
        if ((lParam and (1 shl 29)) <> 0) then
        begin
          IsAltPressed := TRUE;
        end
        else
        begin
          IsAltPressed := FALSE;
        end;
        {Is the Control key pressed}
        if ((GetKeyState(VK_CONTROL) and (1 shl 15)) <> 0) then
        begin
          IsCtrlPressed := TRUE;
        end
        else
        begin
          IsCtrlPressed := FALSE;
        end;
        {if the Shift key pressed}
        if ((GetKeyState(VK_SHIFT) and (1 shl 15)) <> 0) then
        begin
          IsShiftPressed := TRUE;
        end
        else
        begin
          IsShiftPressed := FALSE;
        end;
        }

        {If KeyUp then increment the key count}
        if (KeyUp <> FALSE) then
        begin
          Inc(lpHookRec^.TheKeyCount);
        end;
        case wParam of
          {Was the enter key pressed?}
          VK_RETURN:
            begin
              {if KeyUp}
              if (KeyUp <> FALSE) then
              begin
                {Post a bogus message to the window control in our app}
                PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0);
                PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0);
              end;
              {If you wanted to swallow the keystroke then return -1, else if you want
                                                        to allow the keystroke then return 0}
              result := 0;
              exit;
            end; {VK_RETURN}
          {If the left arrow key is pressed then lets play a joke!}
          VK_LEFT:
            begin
              {if KeyUp}
              if (KeyUp <> FALSE) then
              begin
                {Create a UpArrow keyboard event}
                keybd_event(VK_RIGHT, 0, 0, 0);
                keybd_event(VK_RIGHT, 0, KEYEVENTF_KEYUP, 0);
              end;
              {Swallow the keystroke}
              result := -1;
              exit;
            end; {VK_LEFT}
        end; {case wParam}
        {Allow the keystroke}
        result := 0;
      end; {HC_ACTION}
    HC_NOREMOVE:
      begin
        {This is a keystroke message, but the keystroke message has not been removed
                         from the message queue, since an application has called PeekMessage()
                        specifying PM_NOREMOVE}
        result := 0;
        exit;
      end;
  end; {case code}
  if (Code < 0) then
    {Call the next hook in the hook chain}
    result := CallNextHookEx(lpHookRec^.TheHookHandle, Code, wParam, lParam);
end;

procedure StartKeyBoardHook stdcall;
begin
  {If we have a process wide memory variable and the hook has not already been set...}
  if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle = 0)) then
  begin
    {Set the hook and remember our hook handle}
    lpHookRec^.TheHookHandle := SetWindowsHookEx(WH_KEYBOARD, @KeyBoardProc,
      hInstance, 0);
  end;
end;

procedure StopKeyBoardHook stdcall;
begin
  {If we have a process wide memory variable and the hook has already been set...}
  if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle <> 0)) then
  begin
    {Remove our hook and clear our hook handle}
    if (UnHookWindowsHookEx(lpHookRec^.TheHookHandle) <> FALSE) then
    begin
      lpHookRec^.TheHookHandle := 0;
    end;
  end;
end;

procedure DllEntryPoint(dwReason: DWORD);
begin
  case dwReason of
    Dll_Process_Attach:
      begin
        {If we are getting mapped into a process, then get a pointer to our
                                process wide memory mapped variable}
        hObjHandle := 0;
        lpHookRec := nil;
        MapFileMemory(sizeof(lpHookRec^));
      end;
    Dll_Process_Detach:
      begin
        {If we are getting unmapped from a process then, remove the pointer to
                                our process wide memory mapped variable}
        UnMapFileMemory;
      end;
  end;
end;

exports
  KeyBoardProc name 'KEYBOARDPROC',
  GetHookRecPointer name 'GETHOOKRECPOINTER',
  StartKeyBoardHook name 'STARTKEYBOARDHOOK',
  StopKeyBoardHook name 'STOPKEYBOARDHOOK';

begin
  {Set our Dll's main entry point}
  DLLProc := @DllEntryPoint;
  {Call our Dll's main entry point}
  DllEntryPoint(Dll_Process_Attach);

end.


Application notes:

The test application we have created demonstrates loading the dll that contains the keyboard hook, installing the keyboard hook, displaying the total keystroke count and the number of times the enter key has been pressed (in real time), uninstalling the keyboard hook and unloading the dll.

The application code starts out by defining a form containing two labels, a button, and timer component. Once we install our hook function, we will start the timer, and upon every timer event, we will display in label1 the total number of keystrokes that have been entered by the user since the hook was set. The hook will also fire the button's OnKeyDown event each time the enter key is pressed, giving us the opportunity to display the total number of times the enter key has been pressed in the caption of label2.

After the form is defined, we then define the THookRec structure in the same manner as it is defined in the hook dll. Other variables we will use include: a handle variable used for loading the hook dll, and three function pointer variables used to call the GetHookRecPointer(), StartKeyBoardHook(), and StopKeyBoardHook() functions. Finally we define a pointer to a THookRec structure used to access the memory mapped variables used by the hook function, a variable to keep track of the number of times the enter key is pressed, and a variable used to indicate the success of loading the dll, getting its functions, and setting the hook.



The application logic goes something like this:

On form create, we will initialize our form's components, attempt to dynamically load the hook dll, and get the address of the GetHookRecPointer(), StartKeyBoardHook(), and StopKeyBoardHook() functions located in the hook dll. If we are successful, we will retrieve a pointer to THookRec structure used by the hook dll, we will then initialize structure, adding the handle of the button control so the keyboard hook will know which window control to call when the enter key is pressed. We will then attempt to start the keyboard hook. If we are successful, at setting the hook, we can then start the timer.

On form destroy, if we where previously successful in installing the windows hook and loading the hook dll, we will now uninstall the windows hook, and unload the KeyHook dll.

On the timer's timer event, we will simply display the total number of key presses in the form's label1 caption by accessing the KeyHook dll's THookRec structure.

On the Buttons KeyDown event, if the key value passed is zero we increment our EnterKeyCount variable and display the total number of times the enter key has been pressed by accessing the KeyHook dll's THookRec structure.


Delphi TestApp Example:


unit TestHk1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Timer1: TTimer;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{Functions prototypes for the hook dll}
type
  TGetHookRecPointer = function: pointer stdcall;
type
  TStartKeyBoardHook = procedure stdcall;
type
  TStopKeyBoardHook = procedure stdcall;

  {The record type filled in by the hook dll}
type
  THookRec = packed record
    TheHookHandle: HHOOK;
    TheAppWinHandle: HWND;
    TheCtrlWinHandle: HWND;
    TheKeyCount: DWORD;
  end;

  {A pointer type to the hook record}
type
  PHookRec = ^THookRec;

var
  hHookLib: THandle; {A handle to the hook dll}
  GetHookRecPointer: TGetHookRecPointer; {Function pointer}
  StartKeyBoardHook: TStartKeyBoardHook; {Function pointer}
  StopKeyBoardHook: TStopKeyBoardHook; {Function pointer}
  LibLoadSuccess: bool; {If the hook lib was successfully loaded}
  lpHookRec: PHookRec; {A pointer to the hook record}
  EnterKeyCount: DWORD; {An internal count of the Enter Key}

procedure TForm1.FormCreate(Sender: TObject);
begin
  {Set our initial variables}
  Timer1.Enabled := FALSE;
  Timer1.Interval := 1000;
  Label1.Caption := '0 Keys Logged';
  Label2.Caption := '0 Enter Keys Logged';
  EnterKeyCount := 0;
  lpHookRec := nil;
  LibLoadSuccess := FALSE;
  @GetHookRecPointer := nil;
  @StartKeyBoardHook := nil;
  @StopKeyBoardHook := nil;
  {Try to load the hook dll}
  hHookLib := LoadLibrary('THEHOOK.DLL');
  {If the hook dll was loaded successfully}
  if hHookLib <> 0 then
  begin
    {Get the function addresses}
    @GetHookRecPointer := GetProcAddress(hHookLib, 'GETHOOKRECPOINTER');
    @StartKeyBoardHook := GetProcAddress(hHookLib, 'STARTKEYBOARDHOOK');
    @StopKeyBoardHook := GetProcAddress(hHookLib, 'STOPKEYBOARDHOOK');
    {Did we find all the functions we need?}
    if ((@GetHookRecPointer <> nil) and (@StartKeyBoardHook <> nil) and
      (@StopKeyBoardHook <> nil)) then
    begin
      LibLoadSuccess := TRUE;
      {Get a pointer to the hook record}
      lpHookRec := GetHookRecPointer;
      {Were we successfull in getting a ponter to the hook record}
      if (lpHookRec <> nil) then
      begin
        {Fill in our portion of the hook record}
        lpHookRec^.TheHookHandle := 0;
        lpHookRec^.TheCtrlWinHandle := Button1.Handle;
        lpHookRec^.TheKeyCount := 0;
        {Start the keyboard hook}
        StartKeyBoardHook;
        {Start the timer if the hook was successfully set}
        if (lpHookRec^.TheHookHandle <> 0) then
        begin
          Timer1.Enabled := TRUE;
        end;
      end;
    end
    else
    begin
      {We failed to find all the functions we need}
      FreeLibrary(hHookLib);
      hHookLib := 0;
      @GetHookRecPointer := nil;
      @StartKeyBoardHook := nil;
      @StopKeyBoardHook := nil;
    end;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {Did we load the dll successfully?}
  if (LibLoadSuccess = TRUE) then
  begin
    {Did we sucessfully get a pointer to the hook record?}
    if (lpHookRec <> nil) then
    begin
      {Did the hook get set?}
      if (lpHookRec^.TheHookHandle <> 0) then
      begin
        Timer1.Enabled := FALSE;
        StopKeyBoardHook;
      end;
    end;
    {Free the hook dll}
    FreeLibrary(hHookLib);
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  {Display the number of keystrokes logged}
  Label1.Caption := IntToStr(lpHookRec^.TheKeyCount) + ' Keys Logged';
end;

procedure TForm1.Button1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  {Process message sent from hook dll and display number of time the enter key was pressed}
  if (Key = 0) then
  begin
    Inc(EnterKeyCount);
    Label2.Caption := IntToStr(EnterKeyCount) + ' Enter Keys Logged';
  end;
end;

end.

How to turn menu accelerators on and off

Problem/Question/Abstract:

How can I turn off menu accelerators? It's not done with MenuItem.enabled:=false. I need that because I have set the accelerators 'Delete' and 'Insert' to menu items, but in some situations those keys need to be "free" for other purposes (when the user is editing an EditBox, in my case).

Answer:

Your message implies, but doesn't state, that you are using standard windows shortcuts for Delete (Del key) and Insert (Ins key) features. You want to use them as the standard when the active control is an edit box but not under other circumstances.

I had a similar situation and resolved the problem using a TActionList. Use the OnExecute event to determine if you are using your own or windows processing. Unfortunately, the windows processing doesn't occur automatically and you have to handle the action yourself. Here's my solution for Delete:

procedure TfrmBuildQuery.alExpressionExecute(Action: TBasicAction; var Handled:
  Boolean);
begin
  if Action = aDelete then
    if eValue.Focused then
      {This is the edit control I needed to have windows-like changes}
    begin
      Handled := True; {Stops it from going to the delete action}
      with eValue do
      begin
        {If no selection, then select the char to the right of the cursor.}
        if SelLength = 0 then
          SelLength := 1;
        {Do the delete}
        SelText := '';
      end;
    end
    else
      Handled := False
  else
    Handled := False;
end;

How to draw dotted or dashed lines using a pen with a width greater than 1

Problem/Question/Abstract:

How to draw dotted or dashed lines using a pen with a width greater than 1

Answer:

I once got around this silly limitation by writing a wrapper procedure that would figure out where each dot or dash belonged, and draw many tiny line segments using a solid pen. One of the parameters to the procedure was a string indicating the pattern, which looked like morse code (any arrangement of dots and dashes is allowed).

However, the procedure is ugly. It will handle polylines, and if a polyline vertex falls right in the middle of a dash, then the dash will bend around the corner correctly.

The LineTo method of TCanvas cannot reliably render dashed lines more than one pixel wide. This procedure provides a workaround.


{Copyright (c) 1996 G. Williams}

procedure PlotDashedLine(const Canvas: TCanvas; const Vertices: array of TPoint;
  const Pattern: string; const DashLength: Integer);
var
  PenDown: Boolean;
  Index: Integer;

  procedure PlotTo(const Position: TPoint);
  begin
    with Canvas, Position do
      if (PenDown) then
        LineTo(X, Y)
      else
        MoveTo(X, Y);
  end;

  function Advance(const Distance: Integer): Boolean;
  var
    DistanceRemaining: Single;
    DistanceToNextVertex: Single;
  begin
    Result := false;
    DistanceRemaining := Distance;
    DistanceToNextVertex := PointDist(Canvas.PenPos, Vertices[Index]);
    while (DistanceRemaining > DistanceToNextVertex) do
    begin
      DistanceRemaining := DistanceRemaining - DistanceToNextVertex;
      PlotTo(Vertices[Index]);
      Inc(Index);
      if (Index > High(Vertices)) then
        Exit;
      DistanceToNextVertex := PointDist(Canvas.PenPos, Vertices[Index]);
    end;
    with Canvas.PenPos do
      if (FltEqual(DistanceToNextVertex, 0)) then
        PlotTo(Vertices[Index])
      else
        PlotTo(Point(Round(X + DistanceRemaining / DistanceToNextVertex * (Vertices[Index].X - X)), Round(Y + DistanceRemaining / DistanceToNextVertex * (Vertices[Index].Y - Y))));
    Result := true;
  end;

var
  PatternIndex: Integer;
  OldPenStyle: TPenStyle;

begin
  OldPenStyle := Canvas.Pen.Style;
  Canvas.Pen.Style := psSolid;
  Canvas.MoveTo(Vertices[0].X, Vertices[0].Y);
  PatternIndex := 1;
  Index := 1;
  while (true) do
  begin
    PenDown := true;
    case Pattern[PatternIndex] of
      '.':
        if not (Advance(0)) then
          Break;
      '-':
        if not (Advance(DashLength)) then
          Break;
    else
      ShowError('');
    end;
    PenDown := false;
    if not (Advance(DashLength)) then
      Break;
    Inc(PatternIndex);
    if (PatternIndex > Length(Pattern)) then
      PatternIndex := 1;
  end;
  Canvas.Pen.Style := OldPenStyle;
end;

Detect the current URL in Internet Explorer

Problem/Question/Abstract:

Detect the current URL in Internet Explorer

Answer:

You can quickly retrieve the current Internet Explorer's URL with DDE.

There are a few problems with this technique:

multiple instances of IE could be open - you have no control to which one you connect
one instance with multiple windows could be open (created with IE's menu File | New | Window). Again, you have no control which one you connect to.

Ultimately, you could use EnumChildWindows() calls to check for any open IE window. This could would have to be customized for each new IE release..

uses
  DDEMan;

// TForm type declaration...

procedure TForm1.Button1Click(Sender: TObject);
var
  DDE: TDDEClientConv;
begin
  DDE := TDDEClientConv.Create(self);
  if DDE.SetLink('IExplore', 'WWW_GetWindowInfo') then
    Memo1.Lines.Add(DDE.RequestData('0xFFFFFFFF,sURL,sTitle'));
  DDE.Free;
end;

Embedding files as resources in a Delphi executable

Problem/Question/Abstract:

This article attempts to explain how to include files inside a Delphi application as different kinds of resources, and how to manage them.

Answer:

It is possible to embed any kind of file in an executable using resource files (*.RES). Certain kinds of resources are recognized by the API and can be used directly. Others are simply taken as binary data and its up to you to use them. In this article we will see examples of both kinds.

To create the resource file we start with the source file (*.RC), for example named RESOURCES.RC, which is a simple text file that contains the resource entries (name, class and file):

sample_bmp
BITMAP
sample.bmp
sample_ico
ICON
sample.ico
sample_cur
CURSOR
sample.cur
sample_ani
ANICURSOR
sample.ani
sample_jpg
JPEG
sample.jpg
sample_wav
WAVE
sample.wav
sample_txt
TEXT
sample.txt

    
The names of the resources (sample_bmp, sample_ico, etc.) are arbitrary. The kind of resource may be one recognized by the APIs (BITMAP, ICON, CURSOR) or arbitrary (JPEG, WAVE, TEXT). The file names specify the files that will be included in the .RES file (and later in the .EXE).

Now we have to compile the .RC file to produce the .RES file. For that we can use the Borland Resource Compiler (brcc32.exe) that you can probably find in Delphi's BIN folder. It's a simple command-line utility that expects the name of the source file as parameter:

  C:\DELPHI\P0025>brcc32 resources
  Borland Resource Compiler  Version 5.40
  Copyright (c) 1990, 1999 Inprise Corporation.  All rights reserved.

  C:\DELPHI\P0025>_

To instruct the linker to embed the resource file in the executable, we use the resource file directive ($R or $RESOURCE) in our Pascal ource code:

{$R resources.res}

Loading the resources in your application is easy for the "recongnized" resources like BITMAP, ICON and CURSOR since the Windows API provides functions (LoadBitmap, LoadIcon and LoadCursor respectively) to get handles for these elements, that for example we can assign to the Handle property of the corresponding object:

Image1.Picture.Bitmap.Handle := LoadBitmap(hInstance, 'sample_bmp');
Icon.Handle := LoadIcon(hInstance, 'sample_ico');
Screen.Cursors[1] := LoadCursor(hInstance, 'sample_cur');

For more alternatives when loading image resources, see the API LoadImage.

Other resources are little bit more difficult to manage. Let's start with JPEG images. The following function uses TResourceStream to load the resource as a stream that will be loaded into a TJPEGImage object:

function GetResourceAsJpeg(const resname: string): TJPEGImage;
var
  Stream: TResourceStream;
begin
  Stream := TResourceStream.Create(hInstance, ResName, 'JPEG');
  try
    Result := TJPEGImage.Create;
    Result.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

Example:

var
  Jpg: TJPEGImage;
begin
  // ...
  Jpg := GetResourceAsJpeg('sample_jpg');
  Image2.Picture.Bitmap.Assign(Jpg);
  Jpg.Free;
  // ...
end;

For WAV files we need a pointer to the resource loaded in memory, and for a text file we need to load a resource in a string. We can do it using TResourceStream, but let's see an example using the API:

function GetResourceAsPointer(ResName: pchar; ResType: pchar;
  out Size: longword): pointer;
var
  InfoBlock: HRSRC;
  GlobalMemoryBlock: HGLOBAL;
begin
  InfoBlock := FindResource(hInstance, resname, restype);
  if InfoBlock = 0 then
    raise Exception.Create(SysErrorMessage(GetLastError));
  size := SizeofResource(hInstance, InfoBlock);
  if size = 0 then
    raise Exception.Create(SysErrorMessage(GetLastError));
  GlobalMemoryBlock := LoadResource(hInstance, InfoBlock);
  if GlobalMemoryBlock = 0 then
    raise Exception.Create(SysErrorMessage(GetLastError));
  Result := LockResource(GlobalMemoryBlock);
  if Result = nil then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;

function GetResourceAsString(ResName: pchar; ResType: pchar): string;
var
  ResData: PChar;
  ResSize: Longword;
begin
  ResData := GetResourceAsPointer(resname, restype, ResSize);
  SetString(Result, ResData, ResSize);
end;

Sample calls:

var
  sample_wav: pointer;

procedure TForm1.FormCreate(Sender: TObject);
var
  size: longword;
begin
  {...}
  sample_wav := GetResourceAsPointer('sample_wav', 'wave', size);
  Memo1.Lines.Text := GetResourceAsString('sample_txt', 'text');
end;

Once we have the wave resource loaded into memory we can play it as many times as we want by using the API sndPlaySound declared in the MMSystem unit:

procedure TForm1.Button1Click(Sender: TObject);
begin
  sndPlaySound(sample_wav, SND_MEMORY or SND_NODEFAULT or SND_ASYNC);
end;

There are some resources (like fonts and animated cursors) that can't be used from memory. We necessarily have to save these resources to a temporary disk file and load them from there. The following function saves a resource to a file:

procedure SaveResourceAsFile(const ResName: string; ResType: pchar;
  const FileName: string);
begin
  with TResourceStream.Create(hInstance, ResName, ResType) do
  try
    SaveToFile(FileName);
  finally
    Free;
  end;
end;

The following function makes use of the previous one to save a resource in a temporary file:

function SaveResourceAsTempFile(const ResName: string;
  ResType: pchar): string;
begin
  Result := CreateTempFile;
  SaveResourceAsFile(ResName, ResType, Result);
end;

The discussion of the function CreateTempFile falls beyond the scope of this article and its implementation can be seen in the example attached to the newsletter.

The following function makes use of SaveResourceAsTempFile to save an animated-cursor resource to a temporary file, then it loads the cursor from the file with LoadImage and finally deletes the temporary file. The function returns the handle returned by LoadImage:

function GetResourceAsAniCursor(const ResName: string): HCursor;
var
  CursorFile: string;
begin
  CursorFile := SaveResourceAsTempFile(ResName, 'ANICURSOR');
  Result := LoadImage(0, PChar(CursorFile), IMAGE_CURSOR, 0,
    0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
  DeleteFile(CursorFile);
  if Result = 0 then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;

Sample call:

Screen.Cursors[1] := GetResourceAsAniCursor('sample_ani');
Form1.Cursor := 1;

Well, that's it. I hope you find it useful. You can find more information about resource files in the MSDN Library.

FAQ

1. I was trying to acces some resources like a textfile for example or some variables, but i want to be able to change them and access them at any time. Is this possible??? How?

In some Windows there is an API to update resources in an executable, but the operating system won't allow you to write to an executable file that is running... Basically, take resources as read-only. The first time you can extract them from the executable, but if you need to write to them and preserve their values, I'm afraid that from them on you'll have to use separate files.

2. However I would like to point out something, sndPlaySound is reported as a windows 3.1 api wich of course is great since this makes a program degrade gracefully when run on older windows, but the windows api recommends instead the use of playsound (defined in MMSYSTEM I think) wich even has a SND_RESOURCE flag (yep direct playing from a resource)

PlaySound can play a resource, it's true, however sndPlaySond is not a Windows 3.1 API but a Windows NT 3.1 API. It's a 32-bit function and it doesn't degrade the system's performance as you suggest (actually it's very likely that it is implemented as a call to PlaySound). In certain contexts, for example a game that plays a sound too often, it won't hurt if the resource is loaded in memory instead of playing it from the file.

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

How to get the Icon of a CD-ROM

Problem/Question/Abstract:

I want to write an File explorer, but how can I get the Icon of a CD-ROM? The problem is it can be stored as an ICO File or as a Win32 Resource into an Executable File.

Answer:

With the following Code you can get the Icon of a CD inserted in your CD-ROM Drive. It opens the icon which is specified in the  "AutoRun.inf" of your CD. It's unimportant weather the icon is saved as a file or as a resource in a Win32 Executable File (*.EXE or *.DLL). If the "AutoRun.inf" doesn't exist, the function will stop themself.


function GetCDIcon(Drive: Char): TICon;
var
  ico: TIcon;
  ini: TIniFile;
  s, p: string;
  i, j: integer;
begin
  Result := nil;

  if GetDriveType(PChar(Drive + ':\')) <> DRIVE_CDROM then
    exit;

  //Abort if "AutoRun.inf" doesn't exists.
  if FileExists(Drive + ':\autorun.inf') = False then
    exit;

  //Open the "AutoRun.inf"
  ini := TIniFile.create(Drive + ':\autorun.inf');
  ico := TIcon.create;

  try
    //Read the filename
    s := ini.ReadString('Autorun', 'ICON', '');

    //Abort if there is no icon specified
    if s = '' then
      exit;

    //load the icon from a file
    if FileExists(s) then
      ico.LoadFromFile(s);
    if FileExists(Drive + ':\' + s) then
      ico.LoadFromFile(Drive + ':\' + s);

    //Load the icon from a Win32 resource
    if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then
    begin
      for j := (Pos(',', s) + 1) to Length(s) do
      begin
        p := p + s[j];
      end;
      i := strtoint(p);
      for j := Length(s) downto (Pos(',', s)) do
        Delete(s, j, Length(s));

      if FileExists(s) = False then
        s := Drive + ':\' + s;

      ico.handle := ExtractIcon(hinstance, PChar(s), i);
    end;

    Result := ico;
  finally
    ini.free;
  end;
end;


Here an example how to use this function:


procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.picture.assign(GetCDIcon('F'));
end;

How to determine the font that is used in a menu

Problem/Question/Abstract:

How would I get the font used in menus? I want to setup a TFont that is the same.

Answer:

Returned font becomes callers property and must be freed by it!

function GetMenuFont: TFont;
var
  ncMetrics: TNonClientMetrics;
begin
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(TNonClientMetrics), @ncMetrics,
    0);
  Result := TFont.Create;
  Result.Handle := CreateFontIndirect(ncMetrics.lfMenuFont);
end;

The TNonClientMetrics structure also contains information on other fonts used in the non-client area
information:

lfCaptionFont: Font used in regular captions
lfSmCaptionFont: Font used in small captions
lfMenuFont: Font used in menus
lfStatusFont: Font used in status bars
lfMessageFont: Font used in message boxes

Scroll a TForm through code

Problem/Question/Abstract:

I'm using a form with a TPaintBox element that exceeds the size of the form, so the form has two scrollbars. I want the user to be able to scroll the form using the keyboard (with cursor keys). How can I perform scrolling programmatically? I tried using the TForm.ScrollBy method, but the results are a bit strange.

Answer:

Do not use ScrollBy, instead send WM_VSCROLL messages to the form to make it do the work for you.

procedure TfrmMain.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_DOWN: {scroll down}
      begin
        Perform(WM_VSCROLL, SB_LINEDOWN, 0);
        Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
      end;
    VK_UP: {scroll up}
      begin
        Perform(WM_VSCROLL, SB_LINEUP, 0);
        Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
      end;
  end;
end;

If you use ScrollBy you also have to manually adjust the scrollbar position since it only scrolls the windows client area, completely independent of any scrollbar.

Create an appointment in MS Outlook

Problem/Question/Abstract:

How to create an appointment in MS Outlook

Answer:

Today I want to continue a serie of tips for MS Outlook automatization from Delphi.

If you want to create a new appointment, you can use a code sample below:

uses ComObj;

procedure CreateNewAppointment;
const
  olAppointmentItem = $00000001;

  olImportanceLow = 0;
  olImportanceNormal = 1;
  olImportanceHigh = 2;

  {to find a default Contacts folder}
  function GetCalendarFolder(folder: OLEVariant): OLEVariant;
  var
    i: Integer;
  begin
    for i := 1 to folder.Count do
    begin
      if (folder.Item[i].DefaultItemType = olAppointmentItem) then
      begin
        Result := folder.Item[i];
        break
      end
      else
        Result := GetCalendarFolder(folder.Item[i].Folders);
    end;
  end;

var
  outlook, ns, folder, appointment: OLEVariant;
begin
  {initialize an Outlook}
  outlook := CreateOLEObject('Outlook.Application');
  {get MAPI namespace}
  ns := outlook.GetNamespace('MAPI');
  {get a default Contacts folder}
  folder := GetCalendarFolder(ns.Folders);
  {if Contacts folder is found}
  if not VarIsNull(folder) then
  begin
    {create a new item}
    appointment := folder.Items.Add(olAppointmentItem);
    {define a subject and body of appointment}
    appointment.Subject := 'new appointment';
    appointment.Body := 'call me tomorrow';

    {duration: 10 days starting from today}
    appointment.Start := Now();
    appointment.End := Now() + 10; {10 days for execution}
    appointment.AllDayEvent := 1; {all day event}

    {set reminder in 20 minutes}
    appointment.ReminderMinutesBeforeStart := 20;
    appointment.ReminderSet := 1;

    {set a high priority}
    appointment.Importance := olImportanceHigh;

    {to save an appointment}
    appointment.Save;

    {to display an appointment}
    appointment.Display(True);

    {to print a form}
    appointment.PrintOut;
  end;

  {to free all used resources}
  folder := UnAssigned;
  ns := UnAssigned;
  outlook := UnAssigned
end;

How to determine if a property has inherited from a particular class

Problem/Question/Abstract:

How can I propogate through an object's published properties and extract an actual class reference in order to perform operations like: if GiveProperty is TSomeObjectType then do something?

Answer:

function GetFontProp(anObj: TObject): TFont;
var
  PInfo: PPropInfo;
begin
  {Try to get a pointer to the property information for a
        property with the name 'Font'.
  TObject.ClassInfo returns a pointer to the RTTI table, which we need to pass
  to GetPropInfo}
  PInfo := GetPropInfo(anObj.ClassInfo, 'font');
  Result := nil;
  if PInfo <> nil then
    {found a property with this name, check if it has the correct type}
    if (PInfo^.Proptype^.Kind = tkClass) and
      GetTypeData(PInfo^.Proptype^)^.ClassType.InheritsFrom(TFont) then
      Result := TFont(GetOrdProp(anObj, PInfo));
end;

Auto Hide Form

Problem/Question/Abstract:

Auto Hide Form

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FAnchors: TAnchors;
    procedure WMMOVING(var Msg: TMessage); message WM_MOVING;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Math;

procedure TForm1.WMMOVING(var Msg: TMessage);
begin
  inherited;
  with PRect(Msg.LParam)^ do
  begin
    Left := Min(Max(0, Left), Screen.Width - Width);
    Top := Min(Max(0, Top), Screen.Height - Height);
    Right := Min(Max(Width, Right), Screen.Width);
    Bottom := Min(Max(Height, Bottom), Screen.Height);
    FAnchors := [];
    if Left = 0 then
      Include(FAnchors, akLeft);
    if Right = Screen.Width then
      Include(FAnchors, akRight);
    if Top = 0 then
      Include(FAnchors, akTop);
    if Bottom = Screen.Height then
      Include(FAnchors, akBottom);
    Timer1.Enabled := FAnchors <> [];
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Timer1.Enabled := False;
  Timer1.Interval := 200;
  FormStyle := fsStayOnTop;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
const
  cOffset = 2;
var
  vHandle: THandle;
begin
  vHandle := WindowFromPoint(Mouse.CursorPos);
  while (vHandle <> 0) and (vHandle <> Handle) do
    vHandle := GetParent(vHandle);
  if vHandle = Handle then
  begin
    if akLeft in FAnchors then
      Left := 0;
    if akTop in FAnchors then
      Top := 0;
    if akRight in FAnchors then
      Left := Screen.Width - Width;
    if akBottom in FAnchors then
      Top := Screen.Height - Height;
  end
  else
  begin
    if akLeft in FAnchors then
      Left := -Width + cOffset;
    if akTop in FAnchors then
      Top := -Height + cOffset;
    if akRight in FAnchors then
      Left := Screen.Width - cOffset;
    if akBottom in FAnchors then
      Top := Screen.Height - cOffset;
  end;
end;

end.

How to get TRichEdit to use the RichEd20.dll

Problem/Question/Abstract:

Is there any easy way to get TRichEdit to use RichEd20.dll? We need to use the latest RTF v3, not the 1.0 currently supported by TRichEdit.

Answer:

It's better to use a third-party wrapper, but you can try to trick the standard TRichEdit. Override CreateParams and call CreateSubClass(Params, RICHEDIT_CLASS) there. The RICHEDIT_CLASS constant designates a Rich Edit version 2.0 and higher control. Also, you should call the LoadLibrary('RICHED20.DLL') function to verify which version of Rich Edit is installed. Check the code listed below for details. There is additional code to suppress exceptions, which the RichEdit strings object generates, after the new string was inserted.

{ ... }
type
  TMyRichEdit20 = class(TRichEdit)
  protected
    FMax: integer;
    FSelection: TCharRange;
    procedure EMExSetSel(var Message: TMessage); message EM_EXSETSEL;
    procedure EMReplaceSel(var Message: TMessage); message EM_REPLACESEL;
    function GetSelStart: integer; override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { ... }

constructor TMyRichEdit20.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMax := 0;
  FSelection.cpMin := 0;
  FSelection.cpMax := 0;
end;

procedure TMyRichEdit20.EMExSetSel(var Message: TMessage);
var
  ISel: integer;
  XSel: ^TCharRange absolute ISel;
begin
  inherited;
  ISel := Message.LParam;
  FSelection := XSel^;
end;

procedure TMyRichEdit20.EMReplaceSel(var Message: TMessage);
begin
  inherited;
  FMax := FSelection.cpMax + length(PChar(Message.LParam));
end;

function TMyRichEdit20.GetSelStart: Integer;
begin
  if FMax = 0 then
    Result := inherited GetSelStart
  else
  begin
    Result := FMax;
    FMax := 0;
  end;
end;

var
  FRichEditModule: THandle;

procedure TMyRichEdit20.CreateParams(var Params: TCreateParams);
begin
  if FRichEditModule = 0 then
  begin
    FRichEditModule := LoadLibrary('RICHED20.DLL');
    if FRichEditModule <= HINSTANCE_ERROR then
      FRichEditModule := 0;
  end;
  inherited CreateParams(Params);
  CreateSubClass(Params, RICHEDIT_CLASS);
end;

{ ... }

initialization

finalization
  if FRichEditModule <> 0 then
    FreeLibrary(FRichEditModule);

end.

How to adjust the width of THeaderControl sections automatically, when the first section is resized

Problem/Question/Abstract:

I have THeaderControl with 4 sections. When I resize the first section, I need the remaining 3 sections to resize proportionally to their size to ensure that they don't go out of visibility (I mean that the last section end position always remains the same). I tried to use OnSectionResize or OnSectionTrack events, but without success. Can anyone help?

Answer:

procedure TForm1.ResizeMyHeader();
const
  MIN_COL_WIDTH = 10;
var
  iColWidth: Integer;
  iColExtra: Integer;
  iSection: Integer;
begin
  if HeaderControl1.Sections.Count > 1 then
  begin
    iColWidth := HeaderControl1.Width;
    Dec(iColWidth, HeaderControl1.Sections[0].Width);
    iColWidth := (iColWidth div (HeaderControl1.Sections.Count - 1));
    iColExtra := HeaderControl1.Width - (HeaderControl1.Sections[0].Width +
      (HeaderControl1.Sections.Count - 1) * iColWidth);
    {resize the 2nd to the last columns}
    if iColWidth >= MIN_COL_WIDTH then
    begin
      for iSection := 1 to HeaderControl1.Sections.Count - 2 do
      begin
        HeaderControl1.Sections[iSection].Width := iColWidth;
      end;
      HeaderControl1.Sections[HeaderControl1.Sections.Count - 1].Width := iColWidth + iColExtra;
    end;
  end;
end;

procedure TForm1.HeaderControl1_OnSectionResize(HeaderControl: THeaderControl;
  Section: THeaderSection);
begin
  Self.ResizeMyHeader;
end;

procedure TForm1.Form_OnResize(Sender: TObject);
begin
  Self.ResizeMyHeader;
end;

Create a *.jpg image from a TRichEdit

Problem/Question/Abstract:

How to create a *.jpg image from a TRichEdit

Answer:

uses
  RichEdit;

procedure RichEditToJPEG(const aRichEdit: TRichEdit; const aJPEGImage: TJPEGImage);
var
  lBMP: TBitmap;
  liStyle: Integer;
  liExStyle: Integer;
  lR: TRect;
  liTwipsPerPixel: Integer;
  lfrFormatRange: TFormatRange; { Defined in RichEdit }
begin
  lBMP := TBitmap.Create;
  try
    lBMP.Height := aRichEdit.Height;
    lBMP.Width := aRichEdit.Width;
    { Paint the richedit control's border }
    aRichEdit.PaintTo(lBMP.Canvas.Handle, 0, 0);
    { Store the richedit's window styles }
    liStyle := GetWindowLong(aRichEdit.Handle, GWL_STYLE);
    liExStyle := GetWindowLong(aRichEdit.Handle, GWL_EXSTYLE);
    { Get canvas rect and adjust for the richedit's border if necessary }
    lR := lBMP.Canvas.ClipRect;
    if ((liStyle and WS_BORDER) <> 0) or ((liExStyle and WS_EX_CLIENTEDGE) <> 0) then
    begin
      Inc(lR.Left, GetSystemMetrics(SM_CXEDGE));
      Inc(lR.Top, GetSystemMetrics(SM_CYEDGE));
      Dec(lR.Right, lR.Left);
      Dec(lR.Bottom, lR.Top);
    end;
    { Adjust richedit's border by another pixel }
    InflateRect(lR, -1, -1);
    { We need twips to calculate sizes }
    liTwipsPerPixel := 1400 div Screen.PixelsPerInch;
    { Fill the TFormatRange record }
    with lfrFormatRange do
    begin
      hdc := lBMP.Canvas.Handle;
      hdcTarget := lBMP.Canvas.Handle;
      { Convert the coordinates to twips }
      rc := Rect(lR.Left * liTwipsPerPixel, lR.Top * liTwipsPerPixel,
        lR.Right * liTwipsPerPixel, lR.Bottom * liTwipsPerPixel);
      rcPage := rc;
      chrg.cpMin := 0;
      chrg.cpMax := -1;
    end;
    aRichEdit.Perform(EM_FORMATRANGE, 0, 0);
    aRichEdit.Perform(EM_FORMATRANGE, 0, DWORD(@lfrFormatRange));
    aRichEdit.Perform(EM_FORMATRANGE, 1, DWORD(@lfrFormatRange));
    aRichEdit.Perform(EM_FORMATRANGE, 0, 0);
    aJPEGImage.Assign(lBMP);
  finally
    lBMP.Free;
  end;
end;

Keep your IF ... ELSE conditions reduced to a minimum

Problem/Question/Abstract:

Make simple conditions easier to read and mantain

Answer:

Sometimes you have conditions like

if condition then
  Result := what_ever
else
  Result := something;

Or, even worst, sometimes you have several conditions, like

if condition1 then
  Result1 := what_ever1
else
  Result1 := something1;

if condition2 then
  Result2 := what_ever2
else
  Result2 := something2;

if conditionN then
  ResultN := what_everN
else
  ResultN := somethingN;

Woundt it be much easy to write something like

Result := IFF(condition, result_when_condition_is_true,
  result_when_condition_is_false);

What I propose here is a simple function that will reduce simple conditions into a single line, by receiving a condition and the values  to return when the condition is true or false.

function IFF(C: Boolean; T, F: Variant): Variant;
begin
  if C then
    Result := T
  else
    Result := F;
end;

Since the variables are variant type, you can pass any data type you want, like in these examples:

// will return 'Correct', since the condition is true
MyStr = IFF(TRUE, 'Correct', 'Incorrect');

// will return 'Incorrect', since the condition is false
MyStr = IFF(TALSE, 'Correct', 'Incorrect');

// will return X if X > Y, otherwise returns Y
MyInt = IFF(X > Y, X, Y);

// will return TRUE, since TRUE or FALSE is TRUE
MyBool = IFF((TRUE or FALSE), TRUE, FALSE);

// will return 0, since TRUE and FALSE is FALSE
MyInt = IFF((TRUE and FALSE), 1, 0);

// is MyStr has a lenght grater then 0, returns its lenght, otherwise returns 0
MyInt = IFF(Lenght(MyStr) > 0, Lenght(MyStr), 0);

// if 'Address:' is present on MyStr, it will return the lenght of the string, otherwise will return the string 'Not Found!'
MyVar = IFF(Pos('Address:', MyStr) > 0, Length(MyStr), 'Not found!');

// if x is smaller or equal to 1, it returns X, otherwise it returns the multiplication of X by its predecessor
MyInt = IFF(X <= 1, X, X * (X - 1));

I've been using this funtion for a while and noticed that the code is easier to read and maintain.

Create and Manage Modal and Modeless forms in a DLL

Problem/Question/Abstract:

Displaying and using forms from a DLL can be difficult if you don't know the way. Fortunately enough, Delphi is quite flexible and the managing forms from a DLL is quite easy.

Answer:

The first thing you will need a Handle to the application&#8217;s main window. Assuming that the application is running on top, you can get the window&#8217;s handle using GetActiveWindow, like this:

MainApplicationHandle := GetActiveWindow;

In order to be able to take advantage of Delphi&#8217;s window controlling features, however, you need a window control, not a window handle. You can get a window control uising FindControl (Controls Unit)

fWinControl := FindControl(MainApplicationHandle);

fWinControl is assumed to be of TwinControl type..

I have found it useful to create the Modal (or modeless window) since the begiinning:

MyForm := TMyForm.create(fWinControl);

The three items can be placed confortably in the initialization section of the DLL:

MainApplicationHandle := GetActiveWindow;
fWinControl := FindControl(MainApplicationHandle);
MyForm := TMyForm.create(fWinControl);

Finally, when you need the Form, you just show it, but be carfeul to redraw it if something changed within it:

MyForm.Repaint;
winresult := MyForm.showmodal

(winresult is defined to be of typo longint) You just have to be sure that your form includes wither buttons that produce a modal result (by setting ModalResult to something else than mrNone)
If you&#8217;d rather prefer a modeless window (for example, to display a progress bar) , you can use the following approach:

MyForm.Visible := true;
while {some condition set} do
begin
  {change something in the window}
  MyForm.repaint;
end;
MyForm.Hide;

How select first item in ListView with use key TAB

Problem/Question/Abstract:

When I hand over focus with key TAB to ListView, ListView not select first item. How on it?

Answer:

We have two ListView components. First component with name ListView1 contains two events.


procedure TForm1.ListView1Enter(Sender: TObject);
begin
  HookHandle := SetWindowsHookEx(WH_KEYBOARD, @MsgHook, 0, GetCurrentThreadID);
end;

procedure TForm1.ListView1Exit(Sender: TObject);
begin
  UnHookWindowsHookEx(HookHandle);
end;


Second component with name ListView2 is activate with procedure MsgHook.


function MsgHook(Code: Integer; WParam: WPARAM; LParam: LPARAM): Integer; stdcall;
const
  KeyTAB: Integer = 983041;
begin
  if (Code = HC_ACTION) then
  begin
    if LParam = KeyTAB then
    begin
      frmMain.lsvCCM.SetFocus;
      SendMessage(Form1.ListView2.Handle, WM_KEYDOWN, VK_DOWN, 1);

      Result := -1;
      Exit;
    end;
  end;

  Result := CallNextHookEx(HookHandle, Code, WParam, LParam);
end;

How to identify detail tables linked to a master table

Problem/Question/Abstract:

How can I retrieve the name of the detail tables of some master table? How can I know if a table has a detail table linked? Is there any property or function in the table or query to get the details they have?

Answer:

One way to identify linked detail tables is to scan the form or data module's components array:

for I := 0 to Pred(Component.Count) do
  if Components[I] is TTable then
    if TTable(Components[I]).DataSource <> nil then
      { do whatever }

List of Exceptions

Problem/Question/Abstract:

List of Exceptions

Answer:

Below you find a list of exception that was automatically generated from the C++ Builder 5 include files, using a Python script.

|  Exception
|  |  AxisException
|  |  BarException
|  |  ChartException
|  |  |  PieException
|  |  DBChartException
|  |  EAbort
|  |  EAbstractError
|  |  EAssertionFailed
|  |  EBitsError
|  |  ECommonCalendarError
|  |  |  EDateTimeError
|  |  |  EMonthCalError
|  |  EComponentError
|  |  EConvertError
|  |  EDBEditError
|  |  EDLLLoadError
|  |  EDatabaseError
|  |  |  EDBEngineError
|  |  |  ENoResultSet
|  |  EExternal
|  |  |  EAccessViolation
|  |  |  EControlC
|  |  |  EExternalException
|  |  |  EIntError
|  |  |  |  EDivByZero
|  |  |  |  EIntOverflow
|  |  |  |  ERangeError
|  |  |  EMathError
|  |  |  |  EInvalidArgument
|  |  |  |  EInvalidOp
|  |  |  |  EOverflow
|  |  |  |  EUnderflow
|  |  |  |  EZeroDivide
|  |  |  EPrivilege
|  |  |  EStackOverflow
|  |  EHeapException
|  |  |  EInvalidPointer
|  |  |  EOutOfMemory
|  |  |  |  EOutOfResources
|  |  EIBError
|  |  EInOutError
|  |  EIntfCastError
|  |  EInvalidCast
|  |  EInvalidContainer
|  |  EInvalidGraphic
|  |  EInvalidGraphicOperation
|  |  EInvalidGridOperation
|  |  EInvalidInsert
|  |  EInvalidOperation
|  |  EListError
|  |  EMCIDeviceError
|  |  EMenuError
|  |  EOleCtrlError
|  |  EOleError
|  |  |  EOleException
|  |  |  EOleSysError
|  |  |  |  EOleException
|  |  |  EOleSysError
|  |  |  |  EOleException
|  |  EOleError
|  |  |  EOleException
|  |  |  EOleSysError
|  |  |  |  EOleException
|  |  |  EOleSysError
|  |  |  |  EOleException
|  |  EOutlineError
|  |  EPackageError
|  |  EParserError
|  |  EPrinter
|  |  EPropReadOnly
|  |  EPropWriteOnly
|  |  EPropertyError
|  |  EQRError
|  |  ERegistryException
|  |  EResNotFound
|  |  ESockError
|  |  |  EAbortError
|  |  ESocketError
|  |  EStreamError
|  |  |  EFCreateError
|  |  |  EFOpenError
|  |  |  EFilerError
|  |  |  |  EClassNotFound
|  |  |  |  EInvalidImage
|  |  |  |  EMethodNotFound
|  |  |  |  EReadError
|  |  |  |  EWriteError
|  |  EStringListError
|  |  EThread
|  |  ETreeViewError
|  |  EVariantError
|  |  EWin32Error
|  |  FTPException
|  |  FormExcept
|  |  HTTPException
|  |  LegendException
|  |  NNTPError
|  |  UDPSockError

How to get the physical caret position in a TMemo, TEdit or TRichEdit

Problem/Question/Abstract:

How to get the caret position of a Memo or RichEdit control? I don't mean any character position expressed in row and column, I mean it in pixels!

Answer:

You get the caret position in pixels (client relative) from an edit, memo or richedit control by sending it a EM_POSFROMCHAR message. The message parameters are different for a TRichEdit and TMemo/ TEdit.

{TRichEdit}

var
  pt: TPoint;
begin
  with richedit1 do
  begin
    Perform(messages.EM_POSFROMCHAR, WPARAM(@pt), selstart);
    label1.caption := Format('(%d, %d)', [pt.x, pt.y]);
  end;
end;

{TMemo and TEdit}

var
  r: LongInt;
begin
  with memo1 do
  begin
    r := Perform(messages.EM_POSFROMCHAR, selstart, 0);
    if r >= 0 then
    begin
      label1.caption := IntToStr(HiWord(r));
      label2.caption := IntToStr(LoWord(r));
    end;
  end;
end;

The win32.hlp entries for this message are really messed up, on older versions they only showed the memo variant, on newer (e.g. the one that comes with D5) they show only the richedit variant.

Get FullPath Application of Any Object

Problem/Question/Abstract:

You want get app fullpath of any Object?

Answer:

uses psAPI;

procedure GetAppName(hWindow: THandle; var Buffer: string);
{
hWindow = Handle of the Object that you want know the path.
Buffer = variable that receive the fullpath.
}
var
  dPID: dWord;
  hHandle: THandle;
begin
  GetWindowThreadProcessId(hWindow, @dPID); // Get PID of Object.
  SetLength(Buffer, MAX_PATH); // Set Length of Buffer.
  hHandle := OpenProcess(// Get Handle of Process.
    PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
    true,
    dPID
    );
  if GetModuleFileNameEx(// Check and get App FullPath Name.
    hHandle,
    0,
    PChar(Buffer),
    MAX_PATH
    ) > 0 then
    SetLength(Buffer, StrLen(PChar(Buffer))); // If not reset Length of Buffer.
end;

Converting a group of images from a TImageList into one single bitmap

Problem/Question/Abstract:

I have a program that adds images to a TImageList at runtime. What I would like to do is save the images to a file so that it another program can load in the images to its TImageList.

Answer:

The best way to load a TImageList from a resource is to pack all images into one bitmap and load them all in one go. For this you need the bitmap, of course.

So, create a new project, drop a TImageList on the form and add the icons to it at design-time, as usual. Add a handler for the forms OnCreate event and do it like in the little program ImageListConverter below.

The result is a 'strip' bitmap with all images in the list, here saved as 'c:\temp\images.bmp'.

Open this bitmap in MSPaint and save it again under the same name as a 256 or 16 color bitmap, it will usually have a higher color depth since the VCL creates bitmaps with the color depth of your current video mode by default. The 'transparent' color for this bitmap is clOlive, since that is what we filled the bitmap with before painting the images on it transparently.

The next step is to add this bitmap to a resource file and add the resource to your project. You can do that with the image editor as usual or create a RC file and add it to your project group (requires D5). The RC file would contain a line like

IMAGES1 BITMAP c:\temp\images.bmp

You can now load this resource into your projects imagelist with

ImageList2.ResInstLoad(HInstance, rtBitmap, 'IMAGES1', clOlive);

Note that the width and height setting of the imagelist has to be the same as the one you saved the images from, otherwise the bitmap will not be partitioned correctly.


program ImageListConverter;

procedure ImageList2Bitmap(anImageList: TImageList; const sBMPFile: string);
var
  Bmp: TBitmap;
  i: Integer;
begin
  Bmp := TBitmap.Create;

  try
    Bmp.Width := anImageList.Width * ImageList1.Count;
    Bmp.Height := anImageList.Height;

    with Bmp.Canvas do
    begin
      Brush.Color := clOlive;
      Brush.Style := bsSolid;
      FillRect(ClipRect);
    end;
    for i := 0 to anImageList.Count - 1 do
      anImageList.Draw(Bmp.Canvas, i * anImageList.Width, 0, i);
    Bmp.SaveToFile(sBMPFile);
  finally
    Bmp.Free
  end;
end;

begin
  ImageList2Bitmap(myImageList1, 'c:\temp\images.bmp');
end.

Checking if a Windows feature exists - Hide your app in the Task List

Problem/Question/Abstract:

Some Windows API functions may or may not be present in your Windows version, but detecting the Windows version is not the best way to know if a function is present since it may yield a false negative if the user updated a DLL and the update includes the new function...

Answer:

To check if an API function exists, we have to load the DLL library where it is supposed to reside (calling the API LoadLibrary) and then we have to get the address of the function (calling the API GetProcAddress) which is finally used to call it. If GetProcAddress returns Nil, then the function isn't present, and if it returns a value other than Nil, then the function is present, buy we have to take into account that it isn't necessarily implemented (it may be just a placeholder, and if we call it, we will get the error code ERROR_CALL_NOT_IMPLEMENTED).

In the following example we implement a function called RegisterAsService which tries to call the API RegisterServiceProcess to register/unregister our application as a service. The function returns True if successful.

function RegisterAsService(Active: boolean): boolean;
const
  RSP_SIMPLE_SERVICE = 1;
  RSP_UNREGISTER_SERVICE = 0;
type
  TRegisterServiceProcessFunction =
    function(dwProcessID, dwType: Integer): Integer; stdcall;
var
  module: HMODULE;
  RegServProc: TRegisterServiceProcessFunction;
begin
  Result := False;
  module := LoadLibrary('KERNEL32.DLL');
  if module <> 0 then
  try
    RegServProc := GetProcAddress(module, 'RegisterServiceProcess');
    if Assigned(RegServProc) then
      if Active then
        Result := RegServProc(0, RSP_SIMPLE_SERVICE) = 1
      else
        Result := RegServProc(0, RSP_UNREGISTER_SERVICE) = 1;
  finally
    FreeLibrary(module);
  end;
end;

Notice that registering our application as a service has the side-effect of hiding our application in the Task List (in Windows Task Manager).

Sample calls:

procedure TForm1.FormCreate(Sender: TObject);
begin
  RegisterAsService(true);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RegisterAsService(false);
end;

I guess this works only for win 9X-Me is there any way a similar move may be made under win NT/2000?

I believe for Windows NT/2000, the application must be designed to be a Windows NT/2000 service...

Perhaps you can try running your EXE with SRVANY.EXE, which runs any application as a service. Of course apps run this way won't be able to take advantage of the special operating system features available to services, but for the sake of hiding your app in the Task List, maybe it's enough, I don't know...

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

How to add all paper bins of an active printer to a TListBox

Problem/Question/Abstract:

How is it possible to add all paperbins from the active printer in a listbox (like in the PrinterSetupDialog)?

Answer:

uses
  WinSpool;

procedure GetBinnames(sl: TStrings);
type
  TBinName = array[0..23] of Char;
  TBinNameArray = array[1..High(Integer) div Sizeof(TBinName)] of TBinName;
  PBinnameArray = ^TBinNameArray;
  TBinArray = array[1..High(Integer) div Sizeof(Word)] of Word;
  PBinArray = ^TBinArray;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numBinNames, numBins, temp: Integer;
  pBinNames: PBinnameArray;
  pBins: PBinArray;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numBinNames := WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, nil, nil);
  numBins := WinSpool.DeviceCapabilities(Device, Port, DC_BINS, nil, nil);
  if numBins <> numBinNames then
  begin
    raise Exception.Create('DeviceCapabilities reports different number of bins and ' + 'bin names!');
  end;
  if numBinNames > 0 then
  begin
    pBins := nil;
    GetMem(pBinNames, numBinNames * Sizeof(TBinname));
    GetMem(pBins, numBins * Sizeof(Word));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, Pchar(pBinNames), nil);
      WinSpool.DeviceCapabilities(Device, Port, DC_BINS, Pchar(pBins), nil);
      sl.clear;
      for i := 1 to numBinNames do
      begin
        temp := pBins^[i];
        sl.addObject(pBinNames^[i], TObject(temp));
      end;
    finally
      FreeMem(pBinNames);
      if pBins <> nil then
        FreeMem(pBins);
    end;
  end;
end;

Called like this:

GetBinnames(listbox1.items);

How to define a custom event

Problem/Question/Abstract:

Does anyone have a good example for creating a custom event? I want a TDataModule subclass to fire a custom event, and then a TForm subclass to detect this event and perform some action.

Answer:

First you define the event and create an event property on the datamodule to refer to this event:

TCustomEvent = procedure(Sender: TObject; Var1: integer; Var2: string) of object;

TMyDataModule = class(TDataModule)
private
  { Private declarations }
  FCustomEvent: TCustomEvent;
public
  { Public declarations }
  property CustomEvent: TCustomEvent read FCustomEvent write FCustomEvent;
end;

Next, in some event handler on the form (like the OnCreate) you create a method that matches the event definition and then you programmatically assign it to the datamodule's event property:

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure CustomEvent(Sender: TObject; Var1: Integer; Var2: string);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.CustomEvent(Sender: TObject; Var1: Integer; Var2: string);
begin
  ShowMessage('Hello');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MyDataModule.CustomEvent := CustomEvent;
end;

end.

Comment out large amount of source code

Problem/Question/Abstract:

How to comment out large amount of source code

Answer:

You can use { } or (* *) or // [Delphi 2.x+] to comment out code in Delphi. But, if you have a large amount of code that you want to comment out, none of the above operators may help, depending on whether you have already used those operators in your code. Here's a definitive way to comment out code:

{$IFDEF False}

// your commented code goes here

{$ENDIF}

How to XOR a font on a bitmap canvas

Problem/Question/Abstract:

How to XOR a font on a bitmap canvas

Answer:

Write the text to a (temporary) bitmap and copyrect that to the image:

procedure XORText(sheet: TCanvas; x, y: Integer; text: string);
var
  bmp: TBitmap;
  r1, r2: TRect;
begin
  bmp := TBitmap.create;
  try
    with sheet do
    begin
      bmp.Width := textWidth(text);
      bmp.height := textheight(text);
      r1 := rect(0, 0, bmp.Width, bmp.Height);
      r2 := Rect(x, y, x + bmp.Width, y + bmp.Height);
      bmp.canvas.font.assign(font);
      bmp.canvas.brush.color := clBlack;
      bmp.Canvas.fillrect(r1);
      bmp.canvas.brush.style := bsClear;
      bmp.canvas.textout(0, 0, text);
      copymode := cmSrcInvert;
      copyrect(r2, bmp.canvas, r1);
    end;
  finally
    bmp.free;
  end;
end;

Migration InterBase 5.5 to 6.0

Problem/Question/Abstract:

A certain stored procedure caused me to get this error message:

ISC ERROR CODE: 335544321

ISC ERROR MESSAGE:
arithmetic exception, numeric overflow, or string truncation

Answer:

I found that a variable of type char(18) was assigned to another variable of type char(10). Since the data was never (?) longer than 8 characters, this worked fine up to version 5.5. Seems that IB 6.0 handles strings different. It is likely that a delcaration as VARCHAR instead of CHAR would help also. (See part 1 below)

Another necessary change was a type cast where IB 5.5 did an implicit conversion.


// part 1
declare variable v1 char(10);
declare variable v2 char(18);
..
v1 = v2; // generates the error in IB 6.0

// part 2
declare variable vchardate char(18);
declare variable vdatedate date;

vchardate = '1996-Jan-15';
vdatedate = vchardate; // generates error in IB 6.0

vdatedate = cast(vchardate as DATE);