Make a TActionMainMenuBar on a secondary form work correctly

Problem/Question/Abstract:

On my main form, I have a TActionMainMenuBar with an ActionManager. On my subform, which is placed on the main form, I have a TActionToolbar with a second Actionmanager. Both works fine, but when then second form is active, only the (distinct) shortcuts of the main form are working, the ones of the client form are not.

Answer:

Solve 1:

In order to use a TActionMainMenuBar component on a second form, use the following code in the second form. This overcomes the problem where pressing "ALT" causes the first forms menu bar to appear.

procedure TForm2.WMSysCommand(var Message: TWMSysCommand);
begin
if (Message.CmdType = SC_KEYMENU) then
begin
Message.Result := SendMessage(ActionMainMenuBar.Handle, Message.Msg,
Message.CmdType, Message.Key);
if (Message.Result = 0) then
inherited;
end
else
inherited;
end;


Solve 2:

Try this code in you application's main form (duplicate it for CMActionUpdate):

{ ... }

procedure CMActionExecute(var Message: TMessage); message CM_ACTIONEXECUTE;
{ ... }

procedure TForm1.CMActionexecute(var Message: TMessage);
var
bPerformed: Boolean;
i: Integer;
Form: TCustomForm;
begin
bPerformed := False;
for i := 0 to Pred(Application.ComponentCount) do
begin
if Application.Components[i] is TCustomForm then
begin
Form := TCustomForm(Application.Components[i]);
if Form.Active then
begin
Message.Result := Form.Perform(Message.Msg, 0, Message.LParam);
{Check the result.}
bPerformed := Message.RESULT = S_OK;
if bPerformed then
begin
exit;
end;
end;
end;
end;
if not bPerformed then
begin
{If we havent sent the message anywhere then  perform the usual}
inherited;
end;
end;

Write a non-visible component that allows only one instance of itself at design time

Problem/Question/Abstract:

How to write a non-visible component that allows only one instance of itself at design time

Answer:

Adapted singleton class from Borland Comunity. My prototype allows for inheritance, such as:

{ ... }
type
  {TApplication}
  TApplication = class(TSingleton)
  protected
    procedure InitializeInstance; override;
    procedure FinalizeInstance; override;
  end;

  {TScreen}
  TScreen = class(TSingleton)
  protected
    procedure InitializeInstance; override;
    procedure FinalizeInstance; override;
  end;

All internal members (data/objects) will be created/ destroyed in InitializeInstance/ FinalizeInstance

{ ... }
var
  A1, A2: TApplication;
  S1, S2: TScreen;
begin
  A1 := TApplication.Create;
  A2 := TApplication.Create;
  S1 := TScreen.Create;
  S2 := TScreen.Create;
  { ... }
  {Note, my code: A1 = A2 and S1 = S2 and A1 <> S1}
  A1.Free;
  A2.Free;
  S2.Free;
  S1.Free;
end;

To optimize the code I would suggest using this approach for  creation of objects inheriting from TSingleton:

unit singleton;

interface

uses
  Classes;

type
  {you can inherit from TSingleton and create different singleton objects}
  TSingleton = class
  private
    FRef: Integer;
  protected
    procedure InitializeInstance; virtual;
    procedure FinalizeInstance; virtual;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;

implementation

var
  Singletons: TStringList = nil;

procedure TSingleton.FreeInstance;
var
  Index: Integer;
  Instance: TSingleton;
begin
  Singletons.Find(ClassName, Index);
  Instance := TSingleton(Singletons.Objects[Index]);
  Dec(Instance.FRef);
  if Instance.FRef = 0 then
  begin
    Singletons.Delete(Index);
    Instance.FinalizeInstance;
    {at this point, Instance = Self. We want to call TObject.FreeInstance}
    inherited FreeInstance;
  end;
end;

procedure TSingleton.FinalizeInstance;
begin
end;

procedure TSingleton.InitializeInstance;
begin
end;

class function TSingleton.NewInstance: TObject;
var
  Index: Integer;
begin
  if Singletons = nil then
  begin
    Singletons := TStringList.Create;
    Singletons.Sorted := true;
    Singletons.Duplicates := dupError;
  end;
  if not Singletons.Find(ClassName, Index) then
  begin
    Result := inherited NewInstance;
    TSingleton(Result).FRef := 1;
    TSingleton(Result).InitializeInstance;
    Singletons.AddObject(ClassName, Result);
  end
  else
  begin
    Result := Singletons.Objects[Index];
    Inc(TSingleton(Result).FRef);
  end;
end;

procedure CleanupSingletons;
var
  i: integer;
begin
  if Singletons <> nil then
  begin
    for i := 0 to Pred(Singletons.Count) do
      if Assigned(Singletons.Objects[i]) then
        Singletons.Objects[i].Free;
    Singletons.Free;
  end;
end;

initialization

finalization
  CleanupSingletons;

end.

Version Info for DLL project

Problem/Question/Abstract:

I noticed that the options on the 'Version Info' tab of the 'Project
Options' dialog are all grayed out for a DLL project. Why is that?
Is there a different way of including version info in a DLL?
I would like to include version information in my DLL because it makes upgrade
installations simpler for our customers.

Answer:

I feel that something else is broken in your installation. Make sure you check the box at the
top left of that tab which says 'Include version information in project'.

Also make sure that you have a resource file in your project file (*.dpr).
The line for this looks like this:

{$R *.res}

If you removed this line by accident, no version information will be generated or even linked into your DLL.

Using two Data Controls to display Data Source and Table data

Problem/Question/Abstract:

How can I use two different data controls to display data from a single data source and table?For instance, I'd like to use a DBGrid as a navigating tool as follows:

Clients table with standard name, phone number etc.
One DBText for each edit-able field
DBGrid contains just the name of the client
Click on a record in the DBGrid and the DBTexts are updated according to the record clicked.

At the moment, I'm using two data sources because I don't want phone numbers, etc. to show up in the DBGrid. However, because they're separate data sources, when I click on the DBGrid the DBTexts are not updated. Is there any way I can do this? The clients table is going to be hundreds of entries long, and paging through them is a pain. Also, editing them all in a grid would result in a grid about 25 columns wide :-( and this is also a pain.

Answer:

The Delphi 1.0 Method

If you're using Delphi 1.0, you can't do it with native Data Control components. They just don't have the capability. However, you can simulate the behavior of TDBGrid with a TListBox (this is just one of number of ways to approach this problem). At program startup, you would load the values from your Client Name field into the TListBox by doing the following (assuming you have a TTable and TListBox embedded on your form):

Table1.Open;
with Table1 do {Load the list box}
  while not EOF do
  begin
    ListBox1.Items.Add(FieldByName('Client Name').AsString);
    Next;
  end;
ListBox1.ItemIndex := 0; {Select the first item in the list}

What you have to do next is trap the OnClick event of your TListBox so that whenever a user moves to or clicks on a new item, the value of that item is used to search the TTable and synchronize the values of your TDBEdit components. Assuming that you have your table keyed with the Client Name, you can do the following in the OnClick event;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  with Table1 do
    FindKey([ListBox1.Items[ListBox1.ItemIndex]]);
end;

You could quit here, but your work isn't quite done yet. You will have to be able to handle deletes and inserts to the table, and with those actions you need to update the list as well. I won't go into real specifics here for brevity's sake, but I'll give you an idea of what you have to do below:

Handling Inserts

In this situation you'll probably be better off using another form that has only TEdits that correspond to the fields in your table that you want to update, and OK and Cancel buttons on it. When the user clicks OK, you'll do a Form1.Table1.Insert; to insert a new record into the database and use the TTable.FieldByName method to update the fields.

Once you're done doing that, you have to add the new client name to the list. Since you want to simulate the indexing of your table in your list box, you can't just arbitrarily add an item. You have to load the entire list over again, using the code in the FormCreate method to accomplish this. However, you can get a HUGE performance gain by using the WinAPI function LockWindowUpdate to prevent the form from continuously painting while the list gets loaded. Here's an example of the modified loading code:

LockWindowUpdate(Form1.Handle);
while not EOF do
begin
  ListBox1.Items.Add(FieldByName('Prompt').AsString);
  Next;
end;
LockWindowUpdate(0);

Now the list will load, and the user won't even see the update happening. I'll leave it up to you to write the code to get to the newly added item.

Handling a Delete

Handling a delete is a simpler matter because it doesn't involve another form. All you do is call the TTable.Delete method to delete the current record. After that, reload the list box using the technique described above.

The Delphi 2.0 Method

Fortunately, with the arrival of Delphi 2.0, all the stuff we had to do above is a wash -- for the simple reason that the TDBGrid has more features. The one in particular that is relevant to this topic is the Columns Editor. With the TDBGrid's Columns Editor, you can specify which columns to display in the grid and how to display them. Now you don't have to rely on adding TTable TFields to the form, which severly limited what kinds of objects you could use to access the other field values if you changed the display properties. Now, you can drop a grid on your form, attach it to your table, and pick which column you want to display. Then you can drop other Data Controls such as TDBEdits and such and point them at the same table.They share the same data source, so any change such as movement or editing within the TDBGrid will be immediately reflected in the other Data Controls.

Use a TProgressbar within a TListbox

Problem/Question/Abstract:

How to use a TProgressbar within a TListbox

Answer:

It is possible, but you have to tie the TProgressBar to the listbox at runtime, the listbox will not accept a component dropped on it as child. Create a new project, drop a TButton, TListbox, TProgressbar, TTimer on it. Set the timers Interval to 100, its Enabled property to false. Attach handlers to the Timers OnTimer and buttons onClick event, complete as below:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    ProgressBar1: TProgressBar;
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  progressbar1.StepIt;
  if progressbar1.Position >= progressbar1.Max then
    timer1.enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
  if timer1.Enabled then
    exit;
  listbox1.clear;
  for i := 1 to 20 do
    listbox1.Items.add(Format('Item %d', [i]));
  progressbar1.Position := progressbar1.Min;
  if progressbar1.Parent <> listbox1 then
  begin
    progressbar1.Parent := listbox1;
    progressbar1.BoundsRect := listbox1.ItemRect(2);
  end;
  timer1.enabled := true;
end;

end.

Build and run, click the button.

Handling previous instances of an application

Problem/Question/Abstract:

I was surprised to find that I didn't have an article covering this topic - I wrote a couple of 'em for inquiry.com a couple of years ago. Oh well... they're in another place and time... In any case, what I'll give you here are two techniques for handling previous instances of your applications.

Answer:

Oh! Were that only the phrase I used when I was single! Alas, like most, it unfortunately wasn't. But at least I could apply that phrase in my professional life; of course, in a totally different way. Okay, enough of the play on words.

There are many applications that lend themselves to having more than one copy running at any time. But in my experience, most of the applications I build only lend themselves to a single instance. For instance, it isn't practical to run more than one instance of a data-entry application; especially when it updates local data. In cases such as this, I limit the execution of another instance of a program by executing some simple code.

What I'm going to show you is two different functions that do exactly the same thing. The only difference between the two is that the first function can only be run in Win32, and the other function can run in either Win16 or Win32. Here's the code:

// ===================================================
// Called by your project file, prevents a 2nd
// instance of the program from executing and
// instead activates the already executing instance.
// Returns TRUE if a previous instance of the
// program is already running. Win32 ONLY
// ===================================================

function IsPrevInst: Boolean;
var
  semName,
    appClass: PChar;
  hSem: THandle;
  hWndMe: HWnd;
  appTitle: array[0..MAX_PATH] of Char;
begin
  // Init
  Result := FALSE;
  GetMem(semName, 15);
  GetMem(appClass, 15);
  StrPCopy(semName, 'SemaphoreName');
  StrPCopy(appClass, 'TApplication');
  StrPCopy(appTitle, ExtractFileName(Application.Title));

  // Create a Semaphore in memory.  If this is the
  // first instance, then hSem's value should be 0.
  hSem := CreateSemaphore(nil, 0, 1, semName);

  // Check to see if the semaphore exists
  if (hSem <> 0) and (GetLastError() =
    ERROR_ALREADY_EXISTS) then
  begin
    CloseHandle(hSem);

    // Get the current window's handle then change
    // its title so we can look for the other instance
    hWndMe := FindWindow(appClass, appTitle);
    SetWindowText(hWndMe, 'ZZZZZZZ');

    // Search for other instance of this window then bring
    // it to the top of the Z-order stack.  We find it by
    // matching the Application Class and
    // Application Title.
    hWndMe := FindWindow(appClass, appTitle);
    if (hWndMe <> 0) then
    begin
      BringWindowToTop(hWndMe);
      ShowWindow(hWndMe, SW_SHOWNORMAL);
    end;

    Result := TRUE;
  end;

  // Destroy PChars
  FreeMem(semName, 15);
  FreeMem(appClass, 15);
end;

//This is a different twist on the previous example.
//It uses a mutex (MUTually EXclusive) instead of a sema-
//phore.

procedure CheckPrevInstEx(MainFormClassName,
  MainFormCaption: string);
var
  PrevWnd: HWnd;
  Mutex: THandle;
begin
{$IFDEF Win32}
  Mutex := CreateMutex(nil, False, 'InstanceMutex');
  if WaitForSingleObject(Mutex, 10000) = WAIT_TIMEOUT then
    Application.Terminate;
{$ELSE}
  if HPrevInst = 0 then
    Application.Terminate;
{$ENDIF}

  PrevWnd := FindWindow(PChar(MainFormClassName),
    PChar(MainFormCaption));
  if PrevWnd <> 0 then
    PrevWnd := GetWindow(PrevWnd, GW_OWNER);
  if PrevWnd <> 0 then
  begin
    if IsIconic(PrevWnd) then
      ShowWindow(PrevWnd, SW_SHOWNORMAL)
    else
{$IFDEF Win32}
      SetForegroundWindow(PrevWnd);
{$ELSE}
      BringWindowToTop(PrevWnd);
{$ENDIF}
    Application.Terminate;
  end;
  ReleaseMutex(Mutex);
  CloseHandle(Mutex);
end;

To use the functions above, you can either embed them in the project file, or better yet, place them in a globally accessible library for use in all your applications that need them. Here's some example code for implementing them:

//This example uses the IsPrevInst function
program RxProto;

uses
  Forms,
  Main in 'Main.pas' {MainForm},
  Proc in 'Proc.pas',
  //This is my global library
  UTIL32 in '..\Lib\UTIL\Util32.pas',
  LoopPnThr in '..\Packages\LoopPnThr.pas';

{$R *.RES}

begin
  if not IsPrevInst then
  begin
    Application.Initialize;
    Application.CreateForm(TMainForm, MainForm);
    Application.Run;
  end
  else
    Application.Terminate;
end.
//Here's the other way...
program RxProto;

uses
  Forms,
  Main in 'Main.pas' {MainForm},
  Proc in 'Proc.pas',
  UTIL32 in '..\Lib\UTIL\Util32.pas',
  LoopPnThr in '..\Packages\LoopPnThr.pas';

{$R *.RES}

begin
  CheckPrevInstEx('TApplication', 'My Application');
  //This code won't do anything if CheckPrevInstEx doesn't
  //pass muster
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.

As you can see, pretty simple stuff. Have fun with it!

How to combine two icons

Problem/Question/Abstract:

I want to combine 2 icons like Windows does with the links (the small arrow). Can anyone tell me how that works?

Answer:

function CombineIcons(FrontIcon, BackIcon: HIcon): HIcon;
var
  WinDC: HDC;
  FrontInfo: TIconInfo;
  FrontDC: HDC;
  FrontSv: HBITMAP;
  BackInfo: TIconInfo;
  BackDC: HDC;
  BackSv: HBITMAP;
  BmpObj: tagBitmap;
begin
  WinDC := GetDC(0);
  GetIconInfo(FrontIcon, FrontInfo);
  FrontDC := CreateCompatibleDC(WinDC);
  FrontSv := SelectObject(FrontDC, FrontInfo.hbmMask);
  GetIconInfo(BackIcon, BackInfo);
  BackDC := CreateCompatibleDC(WinDC);
  BackSv := SelectObject(BackDC, BackInfo.hbmMask);
  GetObject(FrontInfo.hbmMask, SizeOf(BmpObj), @BmpObj);
  BitBlt(BackDC, 0, 0, BmpObj.bmWidth, BmpObj.bmHeight, FrontDC, 0, 0, SRCAND);
  SelectObject(BackDC, BackInfo.hbmColor);
  DrawIconEx(BackDC, 0, 0, FrontIcon, 0, 0, 0, 0, DI_NORMAL);
  Result := CreateIconIndirect(BackInfo);
  SelectObject(FrontDC, FrontSv);
  DeleteDC(FrontDC);
  SelectObject(BackDC, BackSv);
  DeleteDC(BackDC);
  ReleaseDC(0, WinDC);
  DeleteObject(FrontInfo.hbmColor);
  DeleteObject(FrontInfo.hbmMask);
  DeleteObject(BackInfo.hbmColor);
  DeleteObject(BackInfo.hbmMask);
end;



Remember: The icon created with this function must be destroyed with DestroyIcon() function when finished using it.

Copy, inherit or use?

Problem/Question/Abstract:

The three ways to use forms in the the Objects Repository

Answer:

COPY, INHERIT OR USE?

Code reusability saves us time and effort, increasing our productivity. Object-oriented programming has something to do with that, and in the case of Delphi we can reuse forms and even entire projects. For example if we have a form with a table, a dbgrid, a navigator and several buttons, we can save it like a model in the Object Repository to reuse it in several parts of our application or other applications. The same for a standard form of the type "Save, Don't save, Cancel". To add a form to the repository you have to right-click it and select "Add to Repository..." in the context menu. To save a project in the repository choose "Add to Repository..." from the Project menu.

To use a form of the repository in our application, in the File menu we chose New and in the New Items dialog we click the Forms tab to see the forms available in the repository. Then we select the form we want, the method of use (Copy, Inherit, or Use) and click the OK button. The dferences between these hree methods of use are described briefly here:

COPY

Creates a form that is copy of the form that is in repository. The changes you make to the copy won't affect the form in the repository (nor other projects that use it), and changes made to the form in the repository won't affect forms previously copied from it. This option is used when the form in the repository is just a base to work, with a very low level of standardization. Full-adaptation is possible.

INHERIT

It creates a form that derives from the form in the repository. Changes made to this derived form (inherited) won't affect the form in the repository, but the inverse is not true. This option is used when the form in the repository is well standardized but it is desired to allow some adaptation. It's the most powerful way to use a form.

USE

It adds the form of the repository to your project. It's not a copy, but the form of the repository itself, and thus any modification that you make to it will apply to other projects that USE or INHERIT it. This option is used when the form of the repository is a standard and is defined in itself (it doesn't require particular adaptations for each case/application).

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

The power of accessors

Problem/Question/Abstract:

Making properties in your objects and using the accesors to do something.

Answer:

Property accessors are great.  They give you the power to do stuff like initialize an object or produce data that are dependent on the object's other properties.

You can make properties by declaring them in your interface section and then pressing Ctrl+Shift+'c'  it wil make a private variable called Fsomeproperty and a set methode called SetSomeProperty.

In this example i made an object that has a property that holds an other object and on the Read of this property i'll check whether it's not nil so i can create it on runtime.

You can also check if a value is within it's bounds on the Property's Set Accessor

type
  TMySubObject = class

  end;

  TMyObject = class
  private
    fMySubObject: TMySubObject;
    FASecondNum: Integer;
    FAFirstnum: Integer;
    function getMySubObject: TMySubObject;
    function GetTotaalOfFirstAndSecondNum: integer;
    procedure SetFirstnum(const Value: Integer);
  public

    property MySubObject: TMySubObject read getMySubObject;
    property AFirstnum: Integer read FAFirstnum write SetFirstnum;
    property ASecondNum: Integer read FASecondNum write FAFirstnum;
    property TotaalOfFirstAndSecondNum: integer read
      GetTotaalOfFirstAndSecondNum;
  end;

implementation

{$R *.DFM}

{ TMyObject }

function TMyObject.getMySubObject: TMySubObject;
begin
  // i check here to see if its assigned
  if not Assigned(fMySubObject) then
    fMySubObject := TMySubObject.Create;
  Result := fMySubObject;
end;

function TMyObject.GetTotaalOfFirstAndSecondNum: integer;
begin
  Result := FAFirstnum + FASecondNum;
end;

procedure TMyObject.SetFirstnum(const Value: Integer);
begin
  // here on the set u can check bounds :) .
  if (Value > 0) and (Value < 1000) then
    FAFirstnum := Value
  else
    raise Exception.Create('Number out of bounds');
end;

Restricting TMemo length

Problem/Question/Abstract:

I was wondering if it were possible to restrict the number of lines in a TMemo.
For example my TMemo shall not allow to show more than 7 lines of text at once.

Answer:

Handle the OnChange event with the code below.

  
procedure TForm1.Memo1Change(Sender: TObject);
begin
  if Memo1.Lines.Count > 7 then
  begin
    MessageBeep($FFFFFFFF);
    Memo1.Lines.Delete(7);
  end;
end;

EventLog change notification in real-time

Problem/Question/Abstract:

I needed a way to be notified in real-time when someone acceded my computer inside an intranet. After doing some research, the solution would pass by using the Security event log that is used when you activate any audit option.

Answer:

In the Control Panel\Administrative Tools\Local Security Police\Local Polices\Audit Police I could audit various account events; in my case I was specially looking for 'Audit account logon events' and 'Audit logon events'.
After setting up these to audit success events, I could confirm that 'Security event log' really logs these attempts. But, how could I be notified by the system when a new event was added to the event log?

The timer - newbies solution

The first solution would be to use a timer that would check the event log count every second, and if the count was different from the last one the log has changed.

To test this we need to create a new project. Declare in the private part of the form the following:

private
{ Private declarations }
FLastCount: Integer; // last event log count
FLog: THandle; // handle to the opened log

Because to work with the log we need to open it first, we do that in the Button1.Click;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FLog := OpenEventLog(nil, PChar('Security'));
  Timer1.Enabled := True;
end;

And now we only need to check the event log count

procedure TForm1.Timer1Timer(Sender: TObject);
var
  lCount: Cardinal;

begin
  if GetNumberOfEventLogRecords(FLog, lCount) and (lCount <> FLastCount) and (lCount >
    0) then
  begin
    FLastCount := lCount;
    ListBox1.Items.Add('Changed at ' + DateTimeToStr(Now()));
  end;
end;

If we are pragmatic we know that this solution works in spite of the fact that there is a little problem. We know that if this were the best solution, I wouldn't be here writing this article ;)

Event object - professional solution

In the Win32 API under the event log group we can find a function that can help us detecting when the event log changes.
The NotifyChangeEventLog function lets an application receive notification when an event is written to the event log file specified by the hEventLog parameter.
When the event is written to the event log file, the function causes the event object specified by the hEvent parameter to become signaled.

Great, this is exactly what we want. But, what is an event object?
An event object is a object that can be created to signal operations between different system processes. The event object is under the same category has Mutex, Process and Semaphores.

To create an event object we use the CreateEvent function, which creates a named or unnamed event object.

The code to test this new option is:

private
{ Private declarations }
FLog: THandle; // handle to the opened log
FEvent: THandle; // handle to the event object

procedure WaitForChange;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FLog := OpenEventLog(nil, PChar('Security'));
  FEvent := CreateEvent(nil, True, False, nil); // create unnamed object
  NotifyChangeEventLog(FLog, FEvent); // start the event log change notification

  WaitForChange;
end;

The way we have to check if a existent event object is signaled or not is by using the WaitForSingleObject function. This function returns when one of the following occurs:
the specified object is in the signaled state.
the time-out interval elapses.

Because, we don't know when the log changes we will not use a time-out interval, so the only way of this function returns is when the event object is in the signaled state.

So, we will need a way of having a loop, which will be constantly calling WaitForSingleObject when it returns. This is the job for the recursive WaitForChange method.

procedure TForm1.WaitForChange;
var
  lResult: Cardinal;

begin
  // reset event signal, so the system can signal it again
  ResetEvent(FEvent);
  // wait for event to be signalled
  lResult := WaitForSingleObject(FEvent, INFINITE);
  // check event result
  case lResult of
    WAIT_OBJECT_0:
      begin
        ListBox1.Items.Add('Changed at ' + DateTimeToStr(Now()));
        Application.ProcessMessages;
      end;
  end;

  // wait for change again
  WaitForChange;
end;

As you have noticed, this solution has a big problem. The application stops responding, but why? Well, WaitForSingleObject function checks the current state of the specified object. If the object's state is non signaled, the calling thread enters an efficient wait state. The thread consumes very little processor time while waiting for the object state to become signaled or the time-out interval to elapse.
Unfortunaly the 'efficient wait state' makes the calling thread being as it was sleeping... sleeping as a rock!

If we didn't need to have an available interface, we could end here. But we need to have a working interface, at least to close the application.

The only solution to our case is to have a secondary thread, which will do this wait, and will call an event of the main thread when a change occurs.

The main code for this thread is:

procedure TNotifyChangeEventLog.Execute;
var
  lResult: DWORD;

begin
  while (not Terminated) do
  begin
    // reset event signal, so we can get it again
    ResetEvent(FEventHandle);
    // wait for event to happen
    lResult := WaitForSingleObject(FEventHandle, INFINITE);
    // check event result
    case lResult of
      WAIT_OBJECT_0: Synchronize(DoChange);
    else
      Synchronize(DoChange);
    end;
  end;
end;

The complete project

Because I needed more things than just to know if the event log changed or not, I ended up by creating a component to work with the event log.
This component is not just another event log component, because it incorporates more things than the usual: read event log, change notifications, functions to scroll the event log (First, Last, Eof, Next).

At this moment I've already sent this component to be approved for incorporating the JVCL (JEDI VCL) at http://jvcl.sourceforge.net
Because it steel wasn't approved I included it with this sample.

Final notes

Why all this trouble to use the event object solution if the timer solution was enough? The problem is that the event object solution is safer.

For example, if you wanted to use the RegNotifyChangeKeyValue function that notifies the caller about changes to the attributes or contents of a specified registry key.
What you would do? You're right, it would almost impossible to use a timer, and would be so simple to use an event object.

Add controls to a form at runtime and stream the result to a file

Problem/Question/Abstract:

Is it possible to add controls to a form at runtime, then stream the result to single file, thus preserving all changes for next application run?

Answer:

Yes, with some caveats. You need to register all control classes that are used on the form plus all that the user may add at runtime. Here is a little example:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  formdata = 'formdata.bin';

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TEdit.Create(self) do
  begin
    left := button1.Left + button1.width + 10;
    top := button1.top;
    Name := 'NewEdit';
    parent := self;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(ExtractFilePath(ParamStr(0)) + formdata, fmCreate);
  try
    fs.WriteComponent(self);
  finally
    fs.free
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  filename: string;
  fs: TFileStream;
  i: integer;
begin
  filename := ExtractFilePath(ParamStr(0)) + formdata;
  if fileExists(filename) then
  begin
    for i := ComponentCount - 1 downto 0 do
      Components[i].Free;
    fs := Tfilestream.create(filename, fmOpenRead or fmShareDenyWrite);
    try
      fs.ReadComponent(self);
      button1.enabled := false;
    finally
      fs.free
    end;
  end;
end;

initialization
  RegisterClasses([TButton, TEdit]);
end.

Set the Cursor Speed

Problem/Question/Abstract:

How to set the cursor speed

Answer:

This is an easy one. Just put a simple line in the form create method and all you text input component will receive the message.

Line is:

SetCaretBlinkTime(Speed);

Where speed is an integer

Exemple:

SetCaretBlinkTime(500);

The more the integer, the more time it take to flash.

Be aware that if you don't reset your cursor speed your cursor speed will remain the same for all you windows session. Just execute this line, close you app and come back here. Try to type an url in the adress bar you'll see.

SetCaretBlinkTime(1);

How to trap and process Windows messages before the applications' window procedure is executed (2)

Problem/Question/Abstract:

I wrote code for the OnMessage event handler of Application object to trap all Windows messages sent to my application, but it doesn't seem to fire on all messages. Is there a way to trap all messages sent to my application?

Answer:

There sure is. And the answer to this "problem" is amazingly simple. But before I go into trapping messages at the application level, I should probably discuss some mechanics.

TApplication's "Hidden" Window

It's not a commonly known fact that the default Application object creates a hidden window when your application is started. But you can seen evidence of this by creating a new application saving it, then running it (make sure you don't rename anything - just keep the main form as "Form1" and the project as "Project1). When you run the application, you'll notice that the caption bar for your main form says, "Form1" while the icon displayed on the task bar says "Project1." That icon represents the application's hidden window, and it affects your program in many ways, especially when you're trying to handle messages sent to your application.

Delphi surfaces the OnMessage event for the Application object. The OnMessage event handler is "supposed" to allow you trap every message sent to your application. But there's a problem with this: OnMessage will only fire when there's something in the Application object's message queue. These messages are typically window management messages such as WM_PAINT or messages sent to the application from Windows through PostMessage, Broadcast or SystemMessage . However, messages sent directly to a window using SendMessage bypass the Application object's message queue, so OnMessage doesn't fire for those types of situations.

Some of you more familiar with handling windows messages might think that a solution to the problem above might be to override the WndProc method for the Application object. Unfortunately, that's not possible because TApplication's WndProc method is not only private, it's also declared as a static method which means it's not overrideable. So it's not only invisible, you can't create a TApplication subclass to override WndProc (not that you'd want either). But that doesn't mean that you can't get to the WndProc method using alternative means.

"Hooking" All Messages

Even though WndProc is all but closed to direct subclassing, TApplication does include a method called HookMainWindow that allows you to insert your own message handler at the top of WndProc to intercept messages sent to your application before they're handled by the Application object. This is convenient for all developers, and solves the problem of trapping any message sent to your application.

HookMainWindow is declared under TApplication as follows:

procedure HookMainWindow(Hook: TWindowHook);

Notice that HookMainWindow takes one parameter, Hook of type TWindowHook. TWindowHook is a method pointer type that's defined like so:

type
  TWindowHook = function(var Message: TMessage): Boolean of object;

Since TWindowHook is a method pointer, you can define your own method as the hook function as long as it follows the nomenclature defined for TWindowHook. Notice that the return value of the function is of type Boolean. This is the equivalent of the "Handled" parameter of OnMessage. If your function handles a particular message, you'd return true. This will be passed back to the Application's WndProc and message processing for that message will be terminated. Otherwise, you'd return False. Here's an example method:

function TForm1.AppHookFunc(var Message: TMessage): Boolean;
begin
  Result := False; //I just do this by default
  if Message.Msg = WM_ < SomethingOrOther > then
  begin
    ...DoSomething...
      Result := True;
  end;
end;

Okay, now that we've set up everything, we need to make the application hook the messages. This can be done in the main form's OnCreate method:

function TForm1.FormCreate(Sender: TObject);
begin
  HookMainWindow(AppHookFunc);
end;

I should mention that you need to clear the hook using, you guessed it, UnHookMainWindow, after you're done using it, and this can be done in the OnDestroy for the main form:

function TForm1.FormDestroy(Sender: TObject);
begin
  UnHookMainWindow(AppHookFunc);
end;

Okay, disgustingly simple. But I feel the best things in life are those that give maximum satisfaction for the least amount of cost (please don't read ANYTHING into that <G>). So, now you've got the tools to create your own message "hooker" (sorry, had to do that at least once). Until next time...

How to attach a popup menu to a TMenuItem at runtime

Problem/Question/Abstract:

How do you attach a popup menu to the TMenuItem of a main menu as a submenu at runtime?

Answer:

This is one way to do it. Note: The PopupMenuItems are added to an existing menu item of the mainmenu mnuWhatEver.

{ ... }
var
  I: integer;
  MenuItem: TMenuItem;
begin
  for I := 0 to PopupMenu1.Items.Count - 1 do
  begin
    with PopupMenu1.Items[I] do
      MenuItem := NewItem(Caption, ShortCut, Checked, Enabled, OnClick, HelpContext,
        Name);
    mnuWhatEver.Add(MenuItem);
  end;
end;

Note: when using NewItem the MenuItem has no owner you'll have to free them yourself when you're done with it.

You could also use:

MenuItem := TMenuItem.Create(Self);

and then copy all the properties yourself.

MenuItem.Captions := PopupMenu1.Items[I].Caption;
MenuItem.OnClick := PopupMenu1.Items[I].OnClick;
{etc.}

How to prevent the use of the listview's popup menu in a TOpenDialog

Problem/Question/Abstract:

Using the TOpenDialog and TSaveDialog components you get the standard Windows dialog boxes including the ability to create/ delete files or folders. Is it possible to block the create/ delete options?

Answer:

Well, few things are really impossible if you try hard enough, but this is at least somewhat difficult. The common dialog API has no facility to do this, the dialogs simply use the same listview class Explorer also uses, so it has all the same functionality. So to block these functions one would have to subclass (the API way) the listview control (to block right mouse clicks and the offending keyboard messages as well as WM_CONTEXTMENU). One could do that in the dialogs OnShow event. The problem is finding the handle of the listview, these Explorer-style dialogs have an utterly weird internal window hierarchy. And the listview in question has not been created yet when the OnShow event fires (go figure). So you have to post a user message to the form from the OnShow event and do the subclassing in that messages handler.

Here is a quick sketch of a modified opendialog class that prevents the use of the listviews popup menu. For some reason it is not possible to trap the DEL key press on the listview level, so if you want to also trap that, and perhaps even the editing of filenames, you will also need to subclass the shellview, which is the parent of the listview, and look for WM_NOTIFY messages from the listview there.

{ ...}
type
  TSafeOpenDialog = class(Dialogs.TOpenDialog)
  private
    FOldListviewProc: Pointer;
    FListviewMethodInstance: Pointer;
    FLIstview: HWND;
    procedure WMApp(var msg: TMessage); message WM_APP;
  protected
    procedure DoShow; override;
    procedure ListviewWndProc(var msg: TMessage);
  public
    destructor Destroy; override;
  end;

destructor TSafeOpenDialog.Destroy;
begin
  inherited;
  if Assigned(FListviewMethodInstance) then
    FreeObjectInstance(FListviewMethodInstance);
end;

procedure TSafeOpenDialog.DoShow;
begin
  inherited;
  PostMessage(handle, WM_APP, 0, 0);
end;

procedure TSafeOpenDialog.ListviewWndProc(var msg: TMessage);
begin
  msg.result := 0;
  case msg.Msg of
    WM_RBUTTONDOWN, WM_RBUTTONUP, WM_CONTEXTMENU:
      Exit;
  end;
  msg.result := CallWindowProc(FOldListviewProc, FLIstview, msg.Msg,
    msg.WParam, msg.LParam);
end;

procedure TSafeOpenDialog.WMApp(var msg: TMEssage);
begin
  FListviewMethodInstance := MakeObjectInstance(ListviewWndProc);
  FListview := FindWindowEx(Windows.GetParent(handle), 0, 'SHELLDLL_DefView', nil);
  if FListview <> 0 then
  begin
    FListview := GetWindow(FListview, GW_CHILD);
    if FListview <> 0 then
      FOldListviewProc := Pointer(SetWindowLong(FListview, GWL_WNDPROC,
        Integer(FListviewMethodInstance)))
    else
      OutputDebugString('Listview not found');
  end
  else
    OutputDebugString('Shell view not found');
end;

Creating shaped forms

Problem/Question/Abstract:

Cool Bitmap shaped forms the easy way

Answer:

Hey! Bored with rectangular windows? HERE'S THE CODE to make any shape you want based on a bitmap picture. How to do it:

1. First, make or choose any background bitmap you want your form to have. Then fill areas you want to go transparent with a distinct color (In this example, it is white).  NOTE: The bitmap's size must be the actual size you want on your form. No stretching in Delphi will work.

2. In Delphi, add a TImage(Image1) component on the form. Choose your bitmap and put the component where you want it. Autosize must be true. Other visual components must be on top of the "visible" part of the picture so that they will be seen.

3. Add the following code (...I mean short code) to your FormCreate procedure. I know I should have made a component for it so that no code would be needed. But just to show you how, I guess this would suffice.

procedure TForm1.FormCreate(Sender: TObject);
const
  // Image Color to be made transparent
  MASKCOLOR = clWhite;

  // Cutting adjustments
  ADJ_TOP = 22; {TitleBar}
  ADJ_BOTTOM = 22; {TitleBar}
  ADJ_LEFT = 3; {Border}
  ADJ_RIGHT = 3; {Border}
var
  ShowRegion, CutRegion: HRgn;
  y, x1, x2: integer;
  PixelColor: TColor;
begin

  ShowRegion := CreateRectRgn(Image1.Left + ADJ_LEFT, Image1.Top + ADJ_TOP,
    Image1.Left + Image1.Width + ADJ_RIGHT, Image1.Top + Image1.Height + ADJ_BOTTOM);

  // Cut the parts whose color is equal to MASKCOLOR by rows
  for y := 0 to Image1.Picture.Bitmap.Height - 1 do
  begin
    x1 := 0; // starting point of cutting
    x2 := 0; // end point of cutting
    repeat
      PixelColor := Image1.Picture.Bitmap.Canvas.Pixels[x2, y];
      // the above will return -1 if x2 reached beyond the image
      if (PixelColor = MaskColor) then
        Inc(x2)
      else
      begin
        //do following if pixel reached beyond image or if color of pixel
                                is not MaskColor
        if x1 <> x2 then
        begin
          // Create the region to be cut. The region will be one line of
                                 pixels/a pixel with color of                  
                                 // MaskColor
          CutRegion := CreateRectRgn(
            X1 + Image1.Left + ADJ_LEFT,
            Y + Image1.Top + ADJ_TOP,
            X2 + Image1.Left + ADJ_RIGHT,
            Y + Image1.Top + ADJ_TOP + 1);

          try
            CombineRgn(ShowRegion, ShowRegion, CutRegion, RGN_DIFF);
            // RGN_DIFF will get the difference of ShowRegion
          finally
            DeleteObject(CutRegion);
          end;
        end;

        Inc(x2);
        x1 := x2;
      end;
    until PixelColor = -1;
  end;

  // Set the window to have the above defined region
  SetWindowRgn(Form1.Handle, ShowRegion, True);

  // NOTE : Do not free close/delete ShowRegion because it will become owned
  // by the operating system

  // You can manually disable the showing of the whole
  //form while dragging, with the following line but
  // just leave it since it is dependent on your
  // windows settings. Some people may want to have their
  // windows show its contents while dragging.

  // SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 0, nil, 0); {Disable drag showing}
  // SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 1, nil, 0); {Enable drag showing}
end;

NOW FOR THE FORM DRAGGING PART

1. Add this line to the private declarations of your Form:

procedure WMNCHitTest(var Msg: TWMNCHitTest); message wm_NCHitTest;

2. In the implementation part. Add the following (assuming your Form name is Form1):

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

Also, add a button to close the form because the title bar cannot be seen. That's all!

How to save and restore font properties in the registry (3)

Problem/Question/Abstract:

What is the best way to store the font for a TDBGrid. I can change it fine with a Font Dialog but how can i store those settings so they take effect the next time the user fires up the program ?

Answer:

Save a font:


function SaveFont(F_Font: TFont): boolean;
var
  FLog: TLogFont;
  Reggy: TRegistry;
begin
  GetObject(F_Font.Handle, SizeOf(FLog), @FLog);
  Reggy := TRegistry.Create;
  try
    Reggy.OpenKey({'\REGKEYNAME'}, true);
    Reggy.WriteBinaryData({'VALUENAME'}, FLog, SizeOf(FLog));
    result := true;
  finally
    Reggy.Free;
  end;
end;


Get a font:


function SetFont(F_Font: TFont): boolean;
var
  FLog: TLogFont;
  Reggy: TRegistry;
  NewFHnd: longint;
begin
  result := false;
  Reggy := TRegistry.Create;
  try
    if Reggy.OpenKey({'\REGKEYNAME'}, false) and
      Reggy.ValueExists({'VALUENAME'}) then
    begin
      Reggy.ReadBinaryData({'VALUENAME'}, FLog, SizeOf(FLog));
      {set Font to the retrieved font}
      NewFHnd := CreateFontIndirect(FLog);
      result := (NewFHnd <> 0);
      if result then
        F_Font.Handle := NewFHnd;
    end;
  finally
    Reggy.Free;
  end;
end;

How to filter a TDateField

Problem/Question/Abstract:

How can I use the table filter for dates?

Answer:

Enclose the date literals in quotation marks:

Table1.Filter := 'DateFld = ' + QuotedStr('01/12/2000');

How to automatically set the font color according to the background color

Problem/Question/Abstract:

How can I make the font color dependent from the background color? I want to make the color selection between white and black dependent from the background color.

Answer:

This seems to work pretty well, at least on a non-palette video mode:

function InverseColor(color: TColor): TColor;
var
  rgb_: TColorref;
  function Inv(b: Byte): Byte;
  begin
    if b > 128 then
      result := 0
    else
      result := 255;
  end;
begin
  rgb_ := ColorToRgb(color);
  rgb_ := RGB(Inv(GetRValue(rgb_)), Inv(GetGValue(rgb_)), Inv(GetBValue(rgb_)));
  Result := rgb_;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with colordialog do
  begin
    color := label1.color;
    if execute then
    begin
      label1.color := color;
      label1.font.color := InverseColor(color);
    end;
  end;
end;

How to get the font family when the user selects a font

Problem/Question/Abstract:

Windows organizes fonts by family and categorizes families with five family names. A sixth name ("Dontcare") allows an application to use the default font. These family names correspond to constants found in the WINGDI.H file: FF_DECORATIVE, FF_DONTCARE, FF_MODERN, FF_ROMAN, FF_SCRIPT, and FF_SWISS. An application uses these constants when it creates a font, selects a font, or retrieves information about a font. Fonts within a family are distinguished by size (10 point, 24 point, and so on) and style (regular, italic, and so on). However, it doesn't say how I can get that setting for any given font. Is there a way to use GetObject to do this?

Answer:

The following table describes the font-family names:

Font-family name: Description
Decorative: Specifies a novelty font. An example is Old English.
Dontcare: Specifies a generic family name. This name is used when information about a font does not exist or does not matter.
Modern: Specifies a monospace font with or without serifs. Monospace fonts are usually modern; examples include Pica, Elite, and Courier New.
Roman: Specifies a proportional font with serifs. An example is Times New Roman.
Script: Specifies a font that is designed to look like handwriting; examples include Script and Cursive.
Swiss: Specifies a proportional font without serifs. An example is Arial.

Here's a sample method, using the form's font:

procedure TForm1.Button1Click(Sender: TObject);
var
  LogFont: TLogFont;
  BytesReturned: integer;
  s: string;
begin
  BytesReturned := GetObject(Font.Handle, sizeof(LogFont), @LogFont);
  if BytesReturned = 0 then
  begin
    caption := 'Failed';
    exit;
  end;
  case LogFont.lfPitchAndFamily and $F0 of
    FF_DONTCARE: s := 'Don''t care, or don''t know.';
    FF_ROMAN: s := 'Variable stroke width, serifed.';
    FF_SWISS: s := 'Variable stroke width, sans-serifed.';
    FF_MODERN: s := 'Constant stroke width, serifed or sans-serifed.';
    FF_SCRIPT: s := 'Script; Cursive, etc.';
    FF_DECORATIVE: s := 'Decorative: Old English, etc.';
  end;
  caption := s;
end;

How to calculate the current week

Problem/Question/Abstract:

How to calculate the current week

Answer:

Solve 1:

There are 2 other functions included which are required for our function. One checks for a leap year, the other returns the number of days in a month (checking the leap year) and the third is the one you want, the week of the year.


function kcIsLeapYear(nYear: Integer): Boolean;
begin
  Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod 400 = 0));
end;

function kcMonthDays(nMonth, nYear: Integer): Integer;
const
  DaysPerMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result := DaysPerMonth[nMonth];
  if (nMonth = 2) and kcIsLeapYear(nYear) then
    Inc(Result);
end;

function kcWeekOfYear(dDate: TDateTime): Integer;
var
  X, nDayCount: Integer;
  nMonth, nDay, nYear: Word;
begin
  nDayCount := 0;
  DecodeDate(dDate, nYear, nMonth, nDay);
  for X := 1 to (nMonth - 1) do
    nDayCount := nDayCount + kcMonthDays(X, nYear);
  nDayCount := nDayCount + nDay;
  Result := ((nDayCount div 7) + 1);
end;


Solve 2:

function CalendarWeek(ADate: TDateTime): integer;

{Author: Ralph Friedman (ralphfriedman@email.com)

Calculates calendar week assuming:
Monday is the 1st day of the week
The 1st calendar week is the 1st week of the year that contains a Thursday

-1 result indicates error.
Any other negative result indicates week 52 or 53 of the previous year.}

var
  day: word;
  dayOne: word;
  firstOfYear: TDateTime;
  month: word;
  monthOne: word;
  prevDayOne: word;
  year: word;
begin
  Result := -1;
  try
    DecodeDate(ADate, year, month, day);
  except
    Exit;
  end;
  case DayOfWeek(EncodeDate(year, 1, 1)) of
    1: dayOne := 2; {Sunday}
    2: dayOne := 1; {Monday}
    3: dayOne := 31; {Tuesday}
    4: dayOne := 30; {Wednesday}
    5: dayOne := 29; {Thursday}
    6: dayOne := 4; {Friday}
    7: dayOne := 3; {Saturday}
  else
    dayOne := 0;
  end;
  case DayOfWeek(EncodeDate(year - 1, 1, 1)) of
    1: prevDayOne := 2; {Sunday}
    2: prevDayOne := 1; {Monday}
    3: prevDayOne := 31; {Tuesday}
    4: prevDayOne := 30; {Wednesday}
    5: prevDayOne := 29; {Thursday}
    6: prevDayOne := 4; {Friday}
    7: prevDayOne := 3; {Saturday}
  else
    prevDayOne := 0;
  end;
  if (prevDayOne = 0) or (dayOne = 0) then
    Exit;
  if dayOne > 4 then
  begin
    Dec(year);
    monthOne := 12
  end
  else
    monthOne := 1;
  firstOfYear := EncodeDate(year, monthOne, dayOne);
  if (ADate < firstOfYear) then
    if (PrevDayOne > 4) then
      Result := -53
    else
      Result := -52
  else
    Result := (Trunc(ADate - firstOfYear) div 7) + 1;
end;

Duplicate a metafile without the fill color of the original

Problem/Question/Abstract:

I have a TMetafile that is created drawing to a TMetafileCanvas. There are various polygons that are drawn using a solid brush style and a grey fill color (red outline). Some of the time I would like to duplicate the metafile but have no fill color (ie just red outlines). But I want to keep it as a metafile and not have to regenerate the original with no fill. I've been looking into changing the palette color, but the metafile does not seem to have any palette entries. Anyone have any ideas?

Answer:

Solve 1:

function unfilledMetafile(const in_metafile: TMetafile): TMetafile;
var
  metaHeaderSize: DWORD;
  metaHeader: PEnhMetaHeader;
  data: PByteArray;
  metaRec: PEMR;
  brushRec: PEMRCreateBrushIndirect;
  i: cardinal;
  {Debug, copy to clipboard
  MyFormat: Word;
  AData: Cardinal;
  APalette: HPALETTE; }
begin
  {Get the header}
  metaHeaderSize := GetEnhMetaFileHeader(in_metafile.Handle, 0, nil);
  if (metaHeaderSize > 0) then
  begin
    GetMem(metaHeader, metaHeaderSize);
    try
      GetEnhMetaFileHeader(in_metafile.Handle, metaHeaderSize, metaHeader);
      GetMem(data, metaHeader^.nBytes);
      ZeroMemory(data, metaHeader^.nBytes);
      try
        GetEnhMetaFileBits(in_metafile.Handle, metaHeader^.nBytes, @(data^[0]));
        {Go through the metafile and update brushes to unfilled}
        i := metaHeaderSize;
        while (i < metaHeader^.nBytes) do
        begin
          {Get record info}
          metaRec := PEMR(@(data^[i]));
          if (metaRec^.itype = EMR_CREATEBRUSHINDIRECT) then
          begin
            brushRec := PEMRCreateBrushIndirect(metaRec);
            brushRec^.lb.lbStyle := BS_HOLLOW;
          end;
          Inc(i, metaRec^.nSize);
        end;
        {Put the data into a new metafile}
        Result := TMetafile.Create();
        Result.Handle := SetEnhMetaFileBits(metaHeader^.nBytes, PChar(data));
      finally
        FreeMem(data, metaHeader^.nBytes);
      end;
    finally
      FreeMem(metaHeader, metaHeaderSize);
    end;
  end
  else
  begin
    raise Exception.Create('Unable to create unfilled metafile');
  end;
  {Debug, copy to clipboard
  Result.SaveToClipboardFormat(MyFormat, AData, APalette);
  ClipBoard.SetAsHandle(MyFormat, AData); }
end;


Solve 2:

The "callback" function:

function EnhMetaFileProc(DC: HDC; {handle to device context}
  lpHTable: PHANDLETABLE; {Pointer to metafile handle table}
  lpEMFR: PENHMETARECORD; {Pointer to metafile record}
  nObj: Integer; {Count of objects}
  aCanvas: TCanvas): Integer; stdcall;
var
  tmpPen, OldPen: HPen;
  tmpBrush, OldBrush: HBrush;
begin
  aCanvas.Pen.Color := clBlack;
  tmpPen := aCanvas.Pen.Handle;
  aCanvas.Brush.Style := bsClear
    tmpBrush := aCanvas.Brush.Handle;
  OldPen := SelectObject(aCanvas.Handle, tmpPen);
  OldBrush := SelectObject(aCanvas.Handle, tmpBrush);
  {Draw the metafile record}
  PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
  SelectObject(aCanvas.Handle, OldPen);
  SelectObject(aCanvas.Handle, OldBrush);
  {Set to zero to stop metafile enumeration}
  Result := 1;
end;

And then, you draw it using EnumEnhMetafile with the callback:

EnumEnhMetaFile(Canvas.Handle, FWMFImage.Handle, @EnhMetaFileProc, Canvas, tmpRect);

Develop a wizard driven style program

Problem/Question/Abstract:

What is the best way to develop a wizard driven style program such as the InstallShield setup programs?

Answer:

Use a TPageControl with each TTabSheet having the property TabVisible set to False. Place Back and Next buttons under the TPageControl and add:

YourPageCtl.SelectNextPage(True);

for the Next button OnClick event, and:

YourPageCtl.SelectNextPage(False);

for the Back button OnClick event.

One caveat. During design-time TabVisible has no effect, and so when you run the program, all of your controls on the TPageControl will shift up by the TabHeight! That's why it's a good workaround to set TabHeight to 1, so that the difference between run-time and design-time is as small as possible.

An even better workaround would be (if you use TabSheets with TabVisible := False) to change the tab style to buttons. Although they are not visible at runtime, they do stop that infuriating extra border.

How to add a menu item to the Windows Taskbar popup menu

Problem/Question/Abstract:

I want to add a menu item to the menu, which pops up when you right-click on the taskbar button for your application. I know how to add item to form system menu, but it doesn't change the popup menu on the taskbar.

Answer:

Solve 1:

unit Unit1;

interface

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

const
  idSysAbout = 100;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  public
    procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  if (Msg.message = WM_SYSCOMMAND) and (Msg.WParam = idSysAbout) then
  begin
    ShowMessage('This is a test');
    Handled := True;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  AppendMenu(GetSystemMenu(Application.Handle, False), MF_SEPARATOR, 0, '');
  AppendMenu(GetSystemMenu(Application.Handle, False), MF_STRING, idSysAbout, 'Test');
  Application.OnMessage := AppMessage;
end;

end.


Solve 2:

The popup menu for a Taskbar button is the Application windows system menu. To add items to it you need to use API functions.

{ ... }
var
  hSysMenu: HMENU;
begin
  hSysMenu := getSystemMenu(Application.handle, false);
  AppendMenu(hSysmenu, MF_STRING, $100, 'My Item');

The item IDs you use ($100 in this example) need to be multiples of 16, in hex notation that means the last digit is 0. Take care not to conflict with the predefined SC_ menu constants for the system menu. All of these have values above 61000.

To get informed when the user selects your new item you need to hande the WM_SYSCOMMAND message send to the Application window. For this you attach a hook to it, using Application.HookMainWindow.

procedure TForm1.FormCreate(Sender: TObject);
var
  hSysMenu: HMENU;
begin
  hSysMenu := getSystemMenu(application.handle, false);
  AppendMenu(hSysmenu, MF_STRING, $100, 'My Item');
  Application.HookMainWindow(AppHook);
end;

function Tform1.AppHook(var Message: TMessage): Boolean;
begin
  if (message.Msg = WM_SYSCOMMAND) and ((message.WParam and $FFF0) = $100) then
  begin
    Result := true;
    ShowMessage('Hi, folks');
  end
  else
    Result := false;
end;

How to print bitmaps

Problem/Question/Abstract:

How to print bitmaps

Answer:

I use this function for printing bitmaps and it has never failed so far. R is the restangle on the printer canvas that the printout must fit in:


procedure StretchPrint(R: TRect; ABitmap: Graphics.TBitmap);
var
  dc: HDC;
  isDcPalDevice: Bool;
  hDibHeader: THandle;
  pDibHeader: pointer;
  hBits: THandle;
  pBits: pointer;
  ppal: PLOGPALETTE;
  pal: hPalette;
  Oldpal: hPalette;
  i: integer;
begin
  pal := 0;
  OldPal := 0;
  {Get the screen dc}
  dc := GetDc(0);
  {Allocate memory for a DIB structure}
  hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
  {get a pointer to the alloced memory}
  pDibHeader := GlobalLock(hDibHeader);
  {fill in the dib structure with info on the way we want the DIB}
  FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize := sizeof(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := ABitmap.width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := ABitmap.height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
  {find out how much memory for the bits}
  GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, nil, TBitmapInfo(pDibHeader^),
    DIB_RGB_COLORS);
  {Alloc memory for the bits}
  hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
  {Get a pointer to the bits}
  pBits := GlobalLock(hBits);
  {Call fn again, but this time give us the bits!}
  GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS);
  {Release the screen dc}
  ReleaseDc(0, dc);
  {Just incase the printer drver is a palette device}
  isDcPalDevice := false;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    {Create palette from dib}
    GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
    isDcPalDevice := true
  end;
  {send the bits to the printer}
  StretchDiBits(Printer.Canvas.Handle, R.Left, R.Top, R.Right - R.Left,
    R.Bottom - R.Top, 0, 0, ABitmap.Width, ABitmap.Height, pBits,
    PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS, SRCCOPY);
  {Just incase you printer drver is a palette device}
  if isDcPalDevice = true then
  begin
    SelectPalette(Printer.Canvas.Handle, oldPal, false);
    DeleteObject(Pal);
  end;
  {Clean up allocated memory}
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);
end;

List of all virtual key values

Problem/Question/Abstract:

List of all virtual key values

Answer:

{Virtual Keys, Standard Set}

  VK_LBUTTON = 1;
  VK_RBUTTON = 2;
  VK_CANCEL = 3;
  VK_MBUTTON = 4;  {Not contiguous with L & RBUTTON }
  VK_BACK = 8;
  VK_TAB = 9;
  VK_CLEAR = 12;
  VK_RETURN = 13;
  VK_SHIFT = $10;
  VK_CONTROL = 17;
  VK_MENU = 18;
  VK_PAUSE = 19;
  VK_CAPITAL = 20;
  VK_ESCAPE = 27;
  VK_SPACE = $20;
  VK_PRIOR = 33;
  VK_NEXT = 34;
  VK_END = 35;
  VK_HOME = 36;
  VK_LEFT = 37;
  VK_UP = 38;
  VK_RIGHT = 39;
  VK_DOWN = 40;
  VK_SELECT = 41;
  VK_PRINT = 42;
  VK_EXECUTE = 43;
  VK_SNAPSHOT = 44;
  VK_INSERT = 45;
  VK_DELETE = 46;
  VK_HELP = 47;
  {VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39)}
  {VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A)}
  VK_LWIN = 91;
  VK_RWIN = 92;
  VK_APPS = 93;
  VK_NUMPAD0 = 96;
  VK_NUMPAD1 = 97;
  VK_NUMPAD2 = 98;
  VK_NUMPAD3 = 99;
  VK_NUMPAD4 = 100;
  VK_NUMPAD5 = 101;
  VK_NUMPAD6 = 102;
  VK_NUMPAD7 = 103;
  VK_NUMPAD8 = 104;
  VK_NUMPAD9 = 105;
  VK_MULTIPLY = 106;
  VK_ADD = 107;
  VK_SEPARATOR = 108;
  VK_SUBTRACT = 109;
  VK_DECIMAL = 110;
  VK_DIVIDE = 111;
  VK_F1 = 112;
  VK_F2 = 113;
  VK_F3 = 114;
  VK_F4 = 115;
  VK_F5 = 116;
  VK_F6 = 117;
  VK_F7 = 118;
  VK_F8 = 119;
  VK_F9 = 120;
  VK_F10 = 121;
  VK_F11 = 122;
  VK_F12 = 123;
  VK_F13 = 124;
  VK_F14 = 125;
  VK_F15 = 126;
  VK_F16 = 127;
  VK_F17 = 128;
  VK_F18 = 129;
  VK_F19 = 130;
  VK_F20 = 131;
  VK_F21 = 132;
  VK_F22 = 133;
  VK_F23 = 134;
  VK_F24 = 135;
  VK_NUMLOCK = 144;
  VK_SCROLL = 145;
  {VK_L & VK_R - left and right Alt, Ctrl and Shift virtual keys. Used only as parameters to
  GetAsyncKeyState() and GetKeyState(). No other API or message will distinguish left and right
  keys in this way.}
  VK_LSHIFT = 160;
  VK_RSHIFT = 161;
  VK_LCONTROL = 162;
  VK_RCONTROL = 163;
  VK_LMENU = 164;
  VK_RMENU = 165;
  VK_PROCESSKEY = 229;
  VK_ATTN = 246;
  VK_CRSEL = 247;
  VK_EXSEL = 248;
  VK_EREOF = 249;
  VK_PLAY = 250;
  VK_ZOOM = 251;
  VK_NONAME = 252;
  VK_PA1 = 253;
  VK_OEM_CLEAR = 254;

FTP-Handling

Problem/Question/Abstract:

If I wish to send files to an FTP server how difficult is it to do?

Answer:

After HTTP, FTP is possibly the most used protocols. It allows files to be transferred to and from FTP servers. The only disadvantage with using FTP is that the username and password are sent unencrypted in plain text. Even Internet Explorer can handle FTP.

The FTP protocol is reasonably easy to implement if you know how to use Winsock, but it has already been done by many people so this is probably one wheel you do NOT need to reinvent. The following list includes source code and they are free. ICS (Francois Piette�s superb library at (http://users.swing.be/francois.piette/indexuk.htm), Winshoes or Indy as it is now known (and soon to be included in Delphi 6 I believe) at http://www.nevrona.com/Indy and MonsterFtp which is on www.torry.ru on the Internet part of the VCL section under FTP.

Of these I tried Monster FTP but found a bug using it within a firewall, but Winshoes version 7 (8 is now being released as Indy) worked fine and the code shown below shows just how simple it is to upload files using the FTP. I haven�t tried ICS or any other kits so apologies if I overlooked any.

For any FTP account you need the following:
Username
Password
Server URL (ftp:// �) or IP Address
And optionally, a folder to change to, after the connection is established.

In the code below, ftpObject is a Winshoes TSimpleFTPObject. FtpUpload is a record or class containing Server (Ip Address or Name), Username, Password, Timeout (in milliseconds) and optionally Directory (to change into).  The file transferred is passed in as FilenametoSend.Just add your own error Procedure to deal with errors.
Procedure Error(Const ErrorString:String);  

Depending on the type of file transferred you may wish to transfer files as binary or as Ascii. The only difference is that Ascii transferred files have Carriage Return/Line Feeds added or stripped (according to direction of flow) if between Unix systems and Windows.

Note this needs to be slotted into a procedure or Method.

try
  FtpObject.Hostname := FtpUpload.Server;
  FtpObject.Username := FtpUpload.Username;
  FtpObject.Password := FtpUpload.Password;
  Ftpobject.ConnectTimeout := Ftpupload.Timeout * 1000;

  if not FTPObject.Connect then
  begin
    Error('failed to connect to server');
    exit;
  end;

except
  on E: Exception do
  begin
    Error(Format('Failed to connect to FTP server %s', [FTPUpload.Server]));
    EXIT;
  end;
end;

{ Change Working Directory }
try
  if FtpUpload.Directory <> '' then
    FtpObject.ChangeRemoteDir(FtpUpload.Directory);
except
  on E: Exception do
  begin
    Error(Format('Failed to switch to FTP folder %s', [FtpUpload.Directory]));
    EXIT;
  end;
end;

//FTPObject.Mode(MODE_BYTE);
FTPObject.Transfertype := ttBinary;
LocalFile := CommonExportFolder + FTPUpload.FileNameToSend;
{ Includes date/time in remote file name to keep name unique on a resend }
RemoteFile := Prefix + FormatDateTime('yyyymmddhhnnss', now) + NameList[i];
try
  FTpObject.PutQualifiedFile(LocalFile, RemoteFile);
except
  Error('Failed Copying File ' + Localfile + ' To ' + Remotefile);
end;

Create a unique GUID (for COM)

Problem/Question/Abstract:

Create a unique GUID (for COM)

Answer:

Do you need to create a GUID in your application?

Very simple in the IDE.. just press Ctrl+Shift+G

How to obtain a list of all published property names and types defined in a component

Problem/Question/Abstract:

How to obtain a list of all published property names and types defined in a component

Answer:

Solve 1:

function GetComponentProperties(Instance: TPersistent; AList: TStrings): Integer;
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  Result := 0;
  Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Instance.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Instance, PropInfo) then
        begin
          {
          case PropInfo^.PropType^.Kind of
            tkInteger:
            tkMethod:
            tkClass:
            ...
          end;
          }
        end;
        Result := AList.Add(PropInfo^.Name);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;


Solve 2:

uses
  TypInfo

procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
  i: integer;
  pInfo: PTypeInfo;
  pType: PTypeData;
  propList: PPropList;
  propCnt: integer;
  tmpStr: string;
begin
  pInfo := AInstance.ClassInfo;
  if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
    raise Exception.Create('Invalid type information');
  pType := GetTypeData(pInfo); {Pointer to TTypeData}
  AList.Add('Class name: ' + pInfo^.Name);
  {If any properties, add them to the list}
  propCnt := pType^.PropCount;
  if propCnt > 0 then
  begin
    AList.Add(EmptyStr);
    tmpStr := IntToStr(propCnt) + ' Propert';
    if propCnt > 1 then
      tmpStr := tmpStr + 'ies'
    else
      tmpStr := tmpStr + 'y';
    AList.Add(tmpStr);
    FillChar(tmpStr[1], Length(tmpStr), '-');
    AList.Add(tmpStr);
    {Get memory for the property list}
    GetMem(propList, sizeOf(PPropInfo) * propCnt);
    try
      {Fill in the property list}
      GetPropInfos(pInfo, propList);
      {Fill in info for each property}
      for i := 0 to propCnt - 1 do
        AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name);
    finally
      FreeMem(propList, sizeOf(PPropInfo) * propCnt);
    end;
  end;
end;

function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
  i: integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

And calling this code by:

ListProperties(TProject(treeview1.items[0].data), memo3.lines);

My tProject is defined as

type
  TProject = class(tComponent)
  private
    FNaam: string;
    procedure SetNaam(const Value: string);
  public
    constructor Create(AOwner: tComponent);
    destructor Destroy;
  published
    property Naam: string read FNaam write SetNaam;
  end;

Also note the output, there seem to be 2 standard properties (Name and Tag) !

Memo3
Class name: TProject

3 Properties
-------------------
Name: TComponentName
Tag: Integer
Naam: String