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.