Get only file name

Problem/Question/Abstract:

How to get only file name (without extension) ?  Example: If i have: c:\test\other\anyfile.doc  and i want get only "anyfile".

Answer:

Solve 1:

function FileName(Value: string): string;
begin
  Result := ExtractFileName(Value);
  if ExtractFileExt(Value) <> '' then
    Result := Copy(ExtractFileName(Value), 1,
      Pos(ExtractFileExt(Value), ExtractFileName(Value)) - 1);
end;


Solve 2:

function FileName(Value: string): string;
begin
  Result := ChangeFileExt(ExtractFileName(Value), '');
end;

Using alternative formats with TDateTimePicker

Problem/Question/Abstract:

Here is a working example of how to use alternative date formats in the TDateTimePicker component for Delphi 5.

Answer:

The problem for me with the TDateTimePicker component, is that it would not only allow dates based on the Windows settings for ShortDate and LongDate, but it also left gaps in between the separators for dates like ' 2/ 3/01'. This made it look terrible.  

I did some research into the problem, and found many "solutions" that did not seem to work all the time.  So far, I haven't had any problems with this one, and although I tested it in Delphi 5, it should work in some previous versions.

Simply enter the following line of code into the OnActivate Event for each TDateTimePicker on your form.  This will manually set the format, and it should remain in place until the form is destroyed.

DateTimePicker1.Perform(DTM_SETFORMAT, 0, DWORD(PCHAR('MM/dd/yyyy')));

The above example assumes that the TDateTimePicker is named DateTimePicker1, and you can vary the format by changing the format string ('MM/dd/yyyy').

I am not sure what format's are available, and it seems a bit quirky.  I had tried to use 'mm/dd/yyyy', and I wound up with a month of '52'!!!  The above string forces two digit months and days, and four-digit years.

Changing folder in Open/Save dialogs

Problem/Question/Abstract:

It is possible to specify initial folder in Open/Save dialogs. However sometimes it is necessary to change current folder, for example, in responce to change of filter.

Answer:

Windows doesn't offer a way to change current dialog. However there is a very handy approach to this problem - imitate user actions. Below is the sample code of how the folder is changed when filter is changed.

procedure SaveDialogTypeChange is a handler for OnTypeChange event.
Depending on the type different folders are selected. This piece of code saves the value of file name edit box, puts a new folder name there, then imitates click of OK button and then restores contents of the edit box.
Add Dlgs to "uses" clause of your unit.

procedure TMainForm.SaveDialogTypeChange(Sender: TObject);
var
  S, S1: string;
  EditHandle: THandle;
  startp,
    endp: DWORD;
begin
  s := '';
  if SaveDialog.FilterIndex = 2 then
  begin
    s := 'c:\program files';
  end
  else if SaveDialog.FilterIndex = 3 then
  begin
    s := 'd:\program files';
  end;
  if s <> '' then
  begin
    EditHandle := GetDlgItem(GetParent(SaveDialog.Handle), edt1);
    if EditHandle <> 0 then
    begin
      SetLength(S1, GetWindowTextLength(EditHandle) + 1);
      GetWindowText(EditHandle, PChar(S1), Length(S1));
      SetLength(S1, StrLen(PChar(S1)));
      SendMessage(EditHandle, EM_GETSEL, Integer(@StartP), Integer(@EndP));
      SetWindowText(EditHandle, PChar(S));
      SendMessage(GetParent(SaveDialog.Handle), WM_COMMAND, 1,
        GetDlgItem(GetParent(SaveDialog.Handle), IDOK));
      if Length(S1) > 0 then
        if S1[Length(S1)] = #10 then
          Delete(S1, Length(S1), 1);
      SetWindowText(EditHandle, PChar(S1));
      SendMessage(EditHandle, EM_SETSEL, StartP, EndP);
    end;
  end;
end;

How do I create a QReport group band at runtime?

Problem/Question/Abstract:

How do I create a group band at runtime?

Answer:

You can call the band's create constructor and set it's properties.

with TQRGroup.Create(Self) do
begin
  Parent := QuickRep1;
  Master := Parent;
  Expression := 'CustNo';
end;

with TQRDBText.Create(Self) do
begin
  Parent := QRGroup1;
  Dataset := QuickRep1.Dataset;
  DataField := 'CustNo';
end

Draw an antialiased line

Problem/Question/Abstract:

How to draw an antialiased line

Answer:

Here's a procedure that uses a modified version of Gupta-Sproull anti-aliasing:

procedure DrawLine(Canvas: TCanvas; x1, y1, x2, y2: integer);

  procedure DrawPixel(x, y: integer; Distance: double);
  var
    Alpha: integer;
  begin
    Alpha := 255 - Trunc(255 * Sqr(1 - Distance * 2 / 3));
    Canvas.Pixels[x, y] := Alpha or (Alpha shl 8) or (Alpha shl 16);
  end;

var
  i, deltax, deltay, numpixels, d, dinc1, dinc2, x, xinc1, xinc2, y, yinc1, yinc2:
    Integer;
  du: Integer;
  twovdu: Integer;
  invD: Double;
  invD2du: Double;
  vincx, vincy: Integer;
begin
  {Calculate deltax and deltay for initialisation}
  deltax := abs(x2 - x1);
  deltay := abs(y2 - y1);
  {Initialize all vars based on which is the independent variable}
  if deltax >= deltay then
  begin
    {x is independent variable}
    numpixels := deltax + 1;
    d := (2 * deltay) - deltax;
    dinc1 := deltay shl 1;
    dinc2 := (deltay - deltax) shl 1;
    xinc1 := 1;
    xinc2 := 1;
    yinc1 := 0;
    yinc2 := 1;
    du := deltax;
    vincx := 0;
    vincy := 1;
  end
  else
  begin
    {y is independent variable}
    numpixels := deltay + 1;
    d := (2 * deltax) - deltay;
    dinc1 := deltax shl 1;
    dinc2 := (deltax - deltay) shl 1;
    xinc1 := 0;
    xinc2 := 1;
    yinc1 := 1;
    yinc2 := 1;
    du := deltay;
    vincx := 1;
    vincy := 0;
  end;
  twovdu := 0;
  invD := 1 / (2 * sqrt(deltax * deltax + deltay * deltay));
  invD2du := 2 * (du * invD);
  {Make sure x and y move in the right directions}
  if x1 > x2 then
  begin
    xinc1 := -xinc1;
    xinc2 := -xinc2;
    vincx := -vincx;
  end;
  if y1 > y2 then
  begin
    yinc1 := -yinc1;
    yinc2 := -yinc2;
    vincy := -vincy;
  end;
  {Start drawing at [x1, y1]}
  x := x1;
  y := y1;
  {Draw the pixels}
  for i := 1 to numpixels do
  begin
    DrawPixel(x, y, twovdu * invD);
    DrawPixel(x + vincx, y + vincy, invD2du - twovdu * invD);
    DrawPixel(x - vincx, y - vincy, invD2du + twovdu * invD);
    if d < 0 then
    begin
      twovdu := d + du;
      d := d + dinc1;
      x := x + xinc1;
      y := y + yinc1;
    end
    else
    begin
      twovdu := d - du;
      d := d + dinc2;
      x := x + xinc2;
      y := y + yinc2;
    end;
  end;
end;

Count the number of words in a string

Problem/Question/Abstract:

How to count the number of words in a string

Answer:

{ ... }
type
TCharSet = TSysCharSet;
{ ... }

function WordCount(const S: string; const WordDelims: TCharSet): Integer;
var
SLen, I: Cardinal;
begin
Result := 0;
I := 1;
SLen := Length(S);
while I <= SLen do
begin
while (I <= SLen) and (S[I] in WordDelims) do
Inc(I);
if I <= SLen then
Inc(Result);
while (I <= SLen) and not (S[I] in WordDelims) do
Inc(I);
end;
end;

Use the following statement to call the function:

WordCount(Edit1.Text, [' ', ','])

Zooming effect when minimizing windows

Problem/Question/Abstract:

In win95 or NT4, there's a 'zooming effect' when an application is minimized
to the taskbar or restored from the taskbar.
However, this zooming effect does not seem to be presented in Delphi applications.

Answer:

Yes, the reason for this is simple: if you click the minimize button of the
main form in a Delphi app, the main form is not minimized but hidden. In its
place the zero-size Application window is minimized. Having the animation
in place here gives some rather weird visiual effects so the VCl designers
decided to disable it.

You can switch the effect on or off with the following piece of code, which works for Win95 and for NT 4:

procedure TForm1.SwitchEffect(Sender: TObject);
var
  Inf: TAnimationInfo;
begin
  Inf.cbSize := sizeof(Inf);
  // 1 = switch it on,
  // 0 = switch if off
  Inf.iMinAnimate := 1;
  SystemparametersInfo(SPI_SETANIMATION, 0, @Inf, SPIF_SENDWININICHANGE);
end;

How to copy a running program to a given folder

Problem/Question/Abstract:

How to copy a running program to a given folder

Answer:

copyfile(PCHAR(filename), PCHAR('c:\temp\' + extractfilename(filename)), true);

How to load data from a table into a TListBox

Problem/Question/Abstract:

How can I create a generic procedure that will load data from a table into a TListBox?

Answer:

Actually, this tip pertains to any control that has a property such as an Items property of type TStrings or is a descendant of TStrings. For example, the following controls have properties of type TStrings: TComboBox, TMemo, TQuery (SQL Property), TDBRadioGroup, TDirectoryListBox, TDriveComboBox, TFileListBox, TFilterComboBox, TListBox, TRadioGroup.

I should say that TStrings is actually an abstract class, and though you will see the help file list properties such as Items as TStrings, they're actually descendants of TStrings. More commonly, you will see something like the TStringList being used almost interchangeably (at least in concept) with TStrings. Essentially, a TStrings object is a list of strings, with array-like properties. The advantage of a TStrings object over an array is that you don't have to worry about allocating and deallocating memory to add and subtract items (which is why they're ideal when working with a loose collection of strings).

To load data from a column in a table into something like a TListBox is easy. All it takes is stepping through the table, picking out the values you want and adding them to the TStrings object - all in one line of code.

{Loads a list using values from a specific field from an open table}

procedure DBLoadList(srcTbl: TTable; srcFld: string; const lst: TStrings);
{srcTbl: Source Table, srcFld: Source Field, lst: Target List}
begin
  with srcTbl do
    if (RecordCount > 0) then
    begin
      {Don't bother if there are no records}
      lst.Clear;
      while not EOF do
      begin
        lst.Add(FieldByName(srcFld).AsString);
        next;
      end;
    end;
end;

The code above assumes you have an open TTable whose values you can access. The real workhorse of the procedure is the while loop which steps through the table and grabs the value from the specified field and assigns it to a new entry into the TStrings object.

Operations such as the one above can be done any of those objects because the properties descend from a common ancestor.

How to pass multidimensional arrays as parameters to a function or procedure

Problem/Question/Abstract:

How to pass multidimensional arrays as parameters to a function or procedure

Answer:

Passing an array to a procedure or function is straight forward and behaves as expected. However, passing a multi-dimensional array to a function or procedure is not handled in the same way. Consider MyArray to be defined as:


var
  MyArray: array[1..3, 1..5] of double;


And you want to pass it to a procedure called DoSomeThing() defined as:


procedure DoSomeThing(MyArray: array of double);
begin
  showmessage(floattostr(MyArray[1, 1]));
end;


One might think a simple statement like DoSomeThing(MyArray); would do the trick. Unfortunately, this is not the case. The statement DoSomeThing(MyArray); will not compile. The compiler sees the two data structures involved as different types - so it will not allow the statement. The DoSomeThing() procedure is expecting an array of doubles, but the example is passing a multi-dimensional array.

Delphi handles multi-dimensional arrays as user defined type, so there is no syntax to tell a procedure that its parameter(s) are multi-dimensional arrays - without declaring a type. Creating a type, and using this type as the parameter is the correct method to pass a multi-dimensional array. We could just pass a pointer to the array, but inside the function, we need to typecast that pointer. What type to cast it as is the next issue. You would have to have the type defined, or declared identically in 2 places. This method just doesn't make sense.

By defining a type, we can change the process to this:


type
  TMyArray = array[1..3, 1..5] of double;

var
  MyArray: TMyArray;

procedure DoSomeThing(MyArray: TMyArray);
begin
  showmessage(floattostr(MyArray[1, 1]));
end;


Now the actual call looks as we expected:


DoSomeThing(MyArray);


If you want to use the method of passing a pointer, your function might look like this:


type
  PMyArray = ^TMyArray;
  TMyArray = array[1..3, 1..5] of double;

var
  MyArray: TMyArray;

procedure DoSomeThing(MyArray: PMyArray);
begin
  showmessage(floattostr((MyArray[2, 3])));
end;


Note, under 32 bit version Delphi, you do not need to dereference the MyArray variable inside DoSomeThing(). Under older versions you might have to refer to MyArray as MyArray^.

If you want to pass just a generic pointer, you may not be able to use it directly. You can declare a local variable, and use it. Again, you may need to cast the local variable for older versions of PASCAL. Of course this method does offer more flexibility in data usage.


procedure DoSomeThing(MyArray: pointer);
var
  t: ^TMyArray;
begin
  t := MyArray;
  ShowMessage(FloatToStr(t[2, 3]));
end;


Regardless, both calls that use a pointer method, will look something like:


MyArray[2, 3] := 5.6;
DoSomeThing(@MyArray);

How to detect which item of an open TComboBox dropdown list the mouse is over

Problem/Question/Abstract:

How would I display a hint over items in a ComboBox dropdown if the item text of the highlighted item is wider than the dropdown? I also want to be able to do the same thing in a ListBox. For a ComboBox I don't know how to proceed. There is no ItemAtPos method for a ComboBox. My first thought was no problem, I'll look at the source for TListBox.ItemAtPos and create a TComboBox.ItemAtPos method. However, I ran into a wall. TListBox.ItemAtPos uses the LB_GetItemRect message to do its magic. There is no corresponding CB_GetItemRect message for a ComboBox. Does anyone out there have any ideas on how to proceed?

Answer:

procedure TForm1.appIdle(sender: TObject; var done: Boolean);
var
  pt: TPoint;
  wnd: HWND;
  buf: array[0..128] of Char;
  i: Integer;
begin
  GetCursorPos(pt);
  wnd := WindowFromPoint(pt);
  buf[0] := #0;
  if wnd <> 0 then
  begin
    GetClassName(wnd, buf, sizeof(buf));
    if StrIComp(buf, 'ComboLBox') = 0 then
    begin
      Windows.ScreenToClient(wnd, pt);
      i := SendMessage(wnd, LB_ITEMFROMPOINT, 0, lparam(PointToSmallpoint(pt)));
      if i >= 0 then
      begin
        SendMessage(wnd, LB_GETTEXT, i, integer(@buf));
        statusbar1.simpletext := buf;
        Exit;
      end;
    end;
  end;
  statusbar1.simpletext := '';
end;

As to showing a custom hint, there is a CM_HINTSHOW message that is send to a control before a hint is popped up. It comes with a pointer to a record that allows you to customize the hints position and the hint text. The thing is undocumented, like all the internal VCL messages, so you need to use the VCL source to figure out how it is used. Or search for examples in the newsgroups archives. When the mouse moves to the next item you call Application.Cancelhint to remove the old hint and wait for the new one to reappear. Application has a number of hint-related properties you can tweak to make the hint appear fast.

Automatically capitalize the first letter of every word when typing in the field of a TStringGrid

Problem/Question/Abstract:

How to automatically capitalize the first letter of every word when typing in the field of a TStringGrid

Answer:

Solve 1:

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
var
  s: string;
  c: Byte;
begin
  with StringGrid1 do
    s := Cells[Col, Row];
  if Length(s) = 0 then
  begin
    if Key in ['a'..'z'] then
    begin
      c := Ord(Key) - 32;
      Key := Chr(c);
    end;
    exit;
  end;
  if s[Length(s)] = ' ' then
    if Key in ['a'..'z'] then
    begin
      c := Ord(Key) - 32;
      Key := Chr(c);
    end;
end;


Answer 2:

In an onKeyPress event, do this:

if length(field.text) = 0 then
  key := upCase(key);

How to retrieve row information in a TDBGrid

Problem/Question/Abstract:

I would like to have a message displayed which shows the actual row in a DBGRid; i.e. "row 32 of 144". How can I achieve this?

Answer:

You could query the BDE with two calls to get the number of records and the cursor position like below:

function GetNumRecords(T: TTable): LongInt;
function GetRecordNumber(DataSet: TDataSet): Longint;

function TMainForm.GetNumRecords(T: TTable): LongInt;
var
  Count: LongInt;
begin
  Check(DbiGetRecordCount(T.Handle, Count));
  Result := Count;
end;

function TMainForm.GetRecordNumber(DataSet: TDataSet): Longint;
var
  CursorProps: CurProps;
  RecordProps: RecProps;
begin
  with DataSet do
  begin
    Check(DbiGetCursorProps(Handle, CursorProps));
    UpdateCursorPos;
    Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
    Result := RecordProps.iSeqNum;
  end;
end;

How to deactivate and reactivate [CTRL] + [ALT] + [DEL] or [ALT] + [TAB] key combinations

Problem/Question/Abstract:

How to deactivate and reactivate [CTRL] + [ALT] + [DEL] or [ALT] + [TAB] key combinations

Answer:

Solve 1:

unit Unit1;

interface

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

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

var
  Form1: TForm1;

const
  RSP_SIMPLE_SERVICE = 1;
  RSP_UNREGISTER_SERVICE = 0;

type
  TRegisterServiceProcess = function(dwProcessID, dwType: DWORD): DWORD; stdcall;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  Hndl: THandle;
begin
  Hndl := LoadLibrary('KERNEL32.DLL');
  @RegisterServiceProcess := GetProcAddress(Hndl, 'RegisterServiceProcess');
  if @RegisterServiceProcess < > nil then
    {check for function, if its there load it}
    RegisterServiceProcess(GetCurrentProcessID, RSP_SIMPLE_SERVICE);
  FreeLibrary(Hndl);
end;

end.


Solve 2:

On Windows 95/ 98/ ME you can disallow CTRL + ALT + DEL in a straight forward manner:


procedure DisableCtrlAltDel;
var
  Dummy: Integer;
begin
  Dummy := 0;
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @Dummy, 0)
end;

procedure EnableCtrlAltDel;
var
  Dummy: Integer;
begin
  Dummy := 0;
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @Dummy, 0)
end;


In fact, the above code snippets will disable Ctrl+Esc too. To disable ALT + TAB, you can use:


procedure DisableAltTab;
var
  Dummy: Integer;
begin
  Dummy := 0;
  SystemParametersInfo(SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
end;

procedure EnableAltTab;
var
  Dummy: Integer;
begin
  Dummy := 0;
  SystemParametersInfo(SPI_SETFASTTASKSWITCH, 0, @Dummy, 0);
end;


All this is still for Windows 95/ 98/ ME. On NT based systems (Windows NT/ 2000), you can get rid of Alt+Tab and Ctrl+Esc in normal manner (different from the above snippets). But to disable Ctrl+Alt+Del, you need to perform key-remapping and that is a bit tricky. Doing key-remapping can render a system useless if not done properly. You need to do a reinstall in such a case.

Cracking XOR Encryption

Problem/Question/Abstract:

Well, there seems to be a trend to post xor encryption routines... so here a simple example of how to break the encryption...

Answer:

Drop a button and edit box on the form, text in the edit box has to be at least 8 chars. if you're using to actualy break an encrypted string, just fill buffer [0..7] with encrypted data and fill [0..7] with the plaintext you assume is encrypted (pretty easy, you username of something of the sort).

I'd like to thank Cheng Wei for pointing out my rediculously slow calls to Edit1.text[i]. i've rethought the algorithm out, and it now tests keys as 2 longwords. as a result of this fix, it now scans 100,000,000 keys in 15seconds on my duron 600! WAAAHOOOOO! Thanks allot Cheng!

Please don't go on ranting about how most ppl don't know how to break xor encryption so it's good enough. it's simply negligence. if someting is worth encrypting then do it properly or don't bother.

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j: longword;
  thistime, lasttime: longword;
  buffer: array[0..7] of byte;
  b: array[0..1] of longword absolute buffer[0];
  plaintext: array[0..7] of byte;
  p: array[0..1] of longword absolute plaintext[0];
  key: array[0..7] of byte;
  k: array[0..1] of longword absolute key[0];
begin
  lasttime := gettickcount;
  randomize;
  if length(edit1.text) < 8 then
    exit;
  for i := 0 to 7 do
  begin
    plaintext[i] := byte(edit1.text[i + 1]);
    buffer[i] := plaintext[i] xor random(256); //encrypt
  end;
  i := 0;
  repeat
    for j := 0 to 1000000 do //loop is unrolled by compiler
    begin
      randseed := i;
      key[0] := random(256);
      key[1] := random(256);
      key[2] := random(256);
      key[3] := random(256);
      key[4] := random(256);
      key[5] := random(256);
      key[6] := random(256);
      key[7] := random(256);
      if b[0] xor k[0] = p[0] then //test key in blocks of 4
        if b[1] xor k[1] = p[1] then
        begin
          thistime := gettickcount;
          caption := 'The key is: ' + inttostr(i) + ' (' + inttostr((thistime -
            lasttime) div 1000) + 'sec)';
          Exit;
        end;
      inc(i, 1);
    end;
    caption := inttostr(i);
    application.processmessages;
  until i > longword(MaxInt);
end;

I'll be posting an article on writting a complete cryptosystem soon enough. i need to read into the legalities first because of canadian encryption laws.

How to perform a Locate on multiple fields

Problem/Question/Abstract:

Is it possible to locate a record in a TTable with matching two fields? For example for name='Peter' and age=25

Answer:

if mytable.locate('name; age', VarArrayOf([Variant(YourName),
  Variant(YourAge)]), [lopartialKey]) then
  { ... }

Detect when a TPopupMenu is closed

Problem/Question/Abstract:

Is it possible to know when a popup menu closes? I really need to differentiate between when a user selects an item or when the menu disappears because the user clicks somewhere else and it loses focus. Is there some message sent to the app window once TrackPopupMenu() returns?

Answer:

Solve 1:

There are messages that are send to the window specified as the menus owner in the call to TrackPopupMenu. If you are using Delphi 5, add the following unit to your project and your form will get the three custom messages defined in the units interface:

unit ExPopupList;

interface

uses Controls;

const
  CM_MENUCLOSED = CM_BASE - 1;
  CM_ENTERMENULOOP = CM_BASE - 2;
  CM_EXITMENULOOP = CM_BASE - 3;

implementation

uses Messages, Forms, Menus;

type
  TExPopupList = class(TPopupList)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

  { TExPopupList }

procedure TExPopupList.WndProc(var Message: TMessage);

  procedure Send(msg: Integer);
  begin
    if Assigned(Screen.Activeform) then
      Screen.ActiveForm.Perform(msg, Message.wparam, Message.lparam);
  end;

begin
  case message.Msg of
    WM_ENTERMENULOOP:
      Send(CM_ENTERMENULOOP);
    WM_EXITMENULOOP:
      Send(CM_EXITMENULOOP);
    WM_MENUSELECT:
      with TWMMenuSelect(Message) do
        if (Menuflag = $FFFF) and (Menu = 0) then
          Send(CM_MENUCLOSED);
  end;
  inherited;
end;

initialization
  Popuplist.Free;
  PopupList := TExPopupList.Create;
  {Note: will be freed by Finalization section of Menus unit}

end.


Solve 2

The TPopupMenu.Popup method (which is used to display such a menu even when presented "automatically" by the VCL) has it's own message pump whilst being displayed. i.e. the Popup procedure only returns to the caller when the menu has been dismissed.

I used this feature to implement a minor extension to TPopupMenu that not only raises an event when the menu has been dismissed, but also peeks in the relevant message queue for the presence of a WM_COMMAND message - i.e. was the menu dismissed because an item was selected or because the menu was cancelled with no item selected. This can then be reflected in the event.

{ ... }
type
  TIXPopupMenuEvent = procedure(Sender: TObject; Cancelled: Boolean) of object;

  TIXPopupMenu = class(TPopupMenu)
  private
    eOnDismissed: TIXPopupMenuEvent;
  public
    procedure Popup(X, Y: Integer); override;
  published
    property OnDismissed: TIXPopupMenuEvent read eOnDismissed write eOnDismissed;
  end;

implementation

{TIXPopupMenu}

procedure TIXPopupMenu.Popup(X, Y: Integer);
var
  msg: tagMSG;
begin
  inherited;
  if Assigned(OnDismissed) then
    OnDismissed(Self, PeekMessage(msg, PopupList.Window, WM_COMMAND,
      WM_COMMAND, PM_NOREMOVE) = FALSE);
end;

How to correctly maximize a window

Problem/Question/Abstract:

I have some forms with the property WindowState set to wsMaximized. The problem is that some forms are hiding the taskbar. I can't find the problem since some others forms are working fine.

Answer:

Solve 1:

If I'm right, the only way to get correctly maximized windows (regarding the taskbar and other "taskbar like" windows) is using API functions:


var
  x: pointer;
  r: TRect;
begin
  x := Addr(r);
  SystemParametersInfo(SPI_GETWORKAREA, 0, x, 0);
  Left := 0;
  Width := r.Right;
  Top := 0;
  Height := r.Bottom;
  { ... }


Solve 2:

This seems to be a particular problem when you do it in the forms OnCreate event. To fix it add a handler for the WM_GETMINMAXINFO message:


private
{ Private declarations }

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

  procedure TForm1.wmGetMinMaxInfo(var msg: TWMGetMinMaxInfo);
  var
    r: TRect;
  begin
    SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
    with msg.MinMaxInfo^ do
    begin
      ptMaxSize := r.BottomRight;
      ptMaxPosition := r.TopLeft;
    end;
  end;


If your form is set to Position := poDesigned and WindowState := wsMaximized, then don't set any value for Constraints. Otherwise the form won't maximize correctly at runtime, if the Windows taskbar is resized.

Delete a shortcut link

Problem/Question/Abstract:

How to delete a shortcut link

Answer:

procedure DeleteShortcut(const
  User {See scUserKey... codes},
  Where {See scWhereKey... codes},
  Name {Name for the shortcut link, w/o ".lnk"}: string);
var
  s: string;
begin
  s := GetEnvVar(scWinDirKey);
  if User <> '' then
    s := s + '\Profiles\' + User
  else if OprSysPlatform = osWinNT then
    raise Exception.CreateFmt('Must have user name to delete shortcut (%s) for NT',
      [Name]);
  if Where = '' then
    raise Exception.CreateFmt('Where must be specified to delete shortcut (%s)',
      [Name]);
  if not DirectoryExists(s) then
    raise Exception.Create('User profile does not exist for ' + User);
  s := s + '\' + Where;
  DeleteFile(s + '\' + Name + '.lnk');
end;

How to activate and deactivate a screensaver

Problem/Question/Abstract:

I have written an application which sits in the system tray. At a particular time of the day my application will pop up and I need it to stop a Windows screensaver if one is running. It also needs to disable the screensaver while the program is on screen so the screensaver does not run. When the application has finished what it has been doing, it will pop down to the system tray again and then it needs to enable the screensaver and run it. How?

Answer:

For this small example you need a form with a timer and a button:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    ListBox1: TListBox;
    Button1: TButton;
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    FLastScreenSaver: string;
  public
    {Public Declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function ExeNameFromWndHandle(hWnd: THandle): string;
var
  ProcessID: Integer;
  Process: TProcessEntry32;
  Snap: THandle;
  s: string;
begin
  try
    GetWindowThreadProcessId(hWnd, @ProcessID);
    Snap := CreateToolHelp32SnapShot(TH32CS_SNAPALL, 0);
    Process.dwSize := sizeof(TProcessEntry32);
    Process32First(Snap, Process);
    repeat
      if Process.th32ProcessID = ProcessID then
      begin
        if length(string(Process.szExeFile)) > 0 then
          s := Process.szExeFile
        else
          s := '';
        break;
      end;
    until
      not Process32Next(Snap, Process);
  except
    s := '';
  end;
  Result := s;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  hWnd: THandle;
  s: string;
begin
  hWnd := GetForegroundWindow;
  s := ExeNameFromWndHandle(hWnd);
  if LowerCase(ExtractFileExt(s)) = '.scr' then
  begin
    FLastScreenSaver := s;
    {As a mouse movement terminates a screensaver we generate one. Some screensavers
    only quit when the user clicks, so perhaps you should generate a click instead of
                a mouse movement }
    {Don't delete double lines else it will not work}
    mouse_event(MOUSEEVENTF_MOVE, 8, 8, 0, GetMessageExtraInfo);
    mouse_event(MOUSEEVENTF_MOVE, 8, 8, 0, GetMessageExtraInfo);
    mouse_event(MOUSEEVENTF_MOVE, -8, -8, 0, GetMessageExtraInfo);
    mouse_event(MOUSEEVENTF_MOVE, -8, -8, 0, GetMessageExtraInfo);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  {Click on the Button to reactivate the screensaver}
  ShellExecute(0, 'open', PChar(FLastScreenSaver), '/s', '', SW_SHOWNORMAL);
  FLastScreenSaver := '';
  Timer1.Enabled := False;
  {It is important that the timer is deactivated else the screensaver will be
  immediatley deactivated after you restarted it.
        So adapt the Timer enabling to your needs.}
end;

end.

Creating a persistent BDE alias

Problem/Question/Abstract:

How to creat a persistent BDE alias

Answer:

There has been a number of occasions where I needed to create persistent BDE aliases. The point is that the DB API isn't very discussed and is unkown to most Delphi developers. Despite that fact, the Dbi calls are very powerful and useful functions.

The function below, CreateAlias, encapsulates the DbiAddAlias call, with some error checking and BDE initialization and finalization procedures.

uses Windows, SysUtils, DbiProcs, DbiErrs, DBTables;

const
  CRLF = #13 + #10;
  ERR_ALIASDRIVERNOTFOUND = 'Specified driver doesn''t exist.';
  ERR_ALIASALREADYEXISTS = 'The Alias (%s) already exists.' + CRLF +
    'Would you like to reconfigure it?';
  ERR_ALIASINVALIDPARAM = 'Invalid Alias name.';
  ERR_ALIASCLOSEBDE = 'Error closing the BDE.' + CRLF +
    'Please close all applications and restart Windows';
  ERR_ALIASOPENBDE = 'Error initializing BDE. Cannot create Alias.';

procedure CreateAlias(sAlias, sPath, sDriver: string;
  PersistentAlias: Boolean);
var
  dbEnv: DbiEnv;
  dbRes: DbiResult;
  Resp: word;
begin
  { Sets the BDE environment }
  with dbEnv do
  begin
    StrPCopy(szWorkDir, sPath);
    StrPCopy(szIniFile, '');
    bForceLocalInit := True;
    StrPCopy(szLang, '');
    StrPCopy(szClientName, 'dbClientName');
  end;
  { Initalizes BDE with the environment dbEnv }
  if DbiInit(@dbEnv) <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASOPENBDE);
  { Adds the specified Alias }
  if sDriver = 'STANDARD' then
    dbRes := DbiAddAlias(nil, pchar(sAlias), nil,
      pchar('PATH:' + sPath), PersistentAlias)
  else
    dbRes := DbiAddAlias(nil, pchar(sAlias), pchar(sDriver),
      pchar('PATH:' + sPath), PersistentAlias);
  case dbRes of
    DbiERR_INVALIDPARAM:
      raise Exception.Create(ERR_ALIASINVALIDPARAM);
    DbiERR_NAMENOTUNIQUE:
      begin
        resp := MessageBox(0, pchar(Format(ERR_ALIASALREADYEXISTS, [sAlias])),
          'CreateAlias', MB_ICONSTOP + MB_YESNO);
        if Resp = ID_YES then
        begin
          Check(DbiDeleteAlias(nil, pchar(sAlias)));
          CreateAlias(sAlias, sPath, sDriver, PersistentAlias);
        end;
      end;
    DbiERR_UNKNOWNDRIVER:
      raise Exception.Create(ERR_ALIASDRIVERNOTFOUND);
  end;
  if DbiExit <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASCLOSEBDE);
end; {CreateAlias}

The parameters for this function are:

sAlias: Name of the new alias to be created

sPath: Full path of the directory to which the alias should point. With little adjustments, this function can be used to create any kind of aliases, and, instead of passing the path info in this argument, pass all the parameters needed by the driver to create the alias.

sDriver: Name of an existing BDE driver, such as PARADOX, DBASE, STANDARD

PersistentAlias: Determines whether the new alias will be for future use (persistent) or just for the actual session.

Example of usage:

CreateAlias('DBTEST', 'c:\progra~1\borland\delphi~1\projects\cd3\data', 'PARADOX',
  true);

How to change the mouse speed

Problem/Question/Abstract:

How to change the mouse speed

Answer:

Solve 1:

The mouse speed is changed in seven steps. Adjust the values in mspeed, if you like.


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  check: array[0..2] of Integer;

const
  mspeed: array[0..6, 0..2] of Integer = ((0, 0, 0), (10, 0, 1), (7, 0, 1), (4, 0, 1), (4, 10, 2), (4, 7, 2), (4, 4, 2));
  tempo: Integer = -1;

procedure step;
begin
  inc(tempo);
  if tempo > 6 then
    tempo := 0;
  systemparametersinfo(SPI_SETMOUSE, 1, @mspeed[tempo], 0);
  form1.label1.caption := 'Step: ' + inttostr(tempo + 1);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  systemparametersinfo(SPI_GETMOUSE, 0, @check, 0);
  step;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  systemparametersinfo(SPI_SETMOUSE, 1, @check, 0);
end;

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

end.


Solve 2:

Use SystemParameters info as shown below.


type
  TMouseTresholdSpeed = array[0..2] of Cardinal;

function GetMouseTresholdSpeed: TMouseTresholdSpeed;
{ Retrieves the two mouse threshold values and the mouse speed }
begin
  SystemParametersInfo(SPI_GETMOUSE, 0, @Result, 0);
end;

procedure SetMouseTresholdSpeed(Value: TMouseTresholdSpeed);
{ Sets the two mouse threshold values and the mouse speed }
begin
  SystemParametersInfo(SPI_SETMOUSE, 0, @Value, 0);
end;

Display the full text search tab of a help file

Problem/Question/Abstract:

You know how to display the table of contents of a help file, but how can you switch directly to the full text search tab?

Answer:

Solve 1:

You can use the Winhelp macro "Find()". Here is an example:

procedure TForm1.ShowFulltextsearch;
var
  command: array[0..255] of Char;
begin
  command := 'FIND()';

  {Ensure that the Application.HelpFile is displayed}
  application.helpcommand(HELP_FORCEFILE, 0);

  {Open the finder window and switch to the search tab}
  application.helpcommand(HELP_COMMAND, Longint(@command));
end;


Solve 2:

procedure ShowHelpTab;
const
  Tab = 15;
  Find = -1;
  Index = -2;
  Contents = -3;
begin
  Application.HelpCommand(Tab, Find);
end;

How to trap the system error when a user tries to access a floppy drive with no disk in it

Problem/Question/Abstract:

How can I trap the system error that results from a user trying to access a floppy drive that has no disk in it. I want to show my own error message etc., rather than the system one.

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  ErrorMode: word;
begin
  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if DiskSize(1) = -1 then
      ShowMessage('No disk in drive A')
    else
    begin
      { Your code }
    end;
  finally
    SetErrorMode(ErrorMode);
  end;
end;

Custom sort a TCheckListBox

Problem/Question/Abstract:

I created a component TMyCheckListBox which inherited from TCheckListBox, and I want to sort the list of items in numeric not alphabetic order. Although I set the Sorted property to True, I cannot sort it in the way I want. I need to have a numeric sort with the Sorted property set to True.

Answer:

The Sorted property calls the built-in capability of the underlying windows control to sort itself alphabetically. In case you need to perform a custom sorting, just turn the Sorted property off, and do the sorting by using TStringList CustomSort method. Below is the sequence of possible steps

Assign listbox's items to the string list. Perform custom sorting by calling the CustomSort method. You should pass a function that compares two strings in the string list as parameter (see example below for details). Move items back to the listbox. Here's an example. It resorts the list's content in custom order:

{This function sorts items in the list}

function CompareStrings(List: TStringList; Index1, Index2: Integer): Integer;
var
  XInt1, XInt2: integer;
begin
  try
    XInt1 := strToInt(List[Index1]);
    XInt2 := strToInt(List[Index2]);
  except
    XInt1 := 0;
    XInt2 := 0;
  end;
  Result: = XInt1 - XInt2;
end;

procedure TForm1.SpeedButton5Click(Sender: TObject);
var
  XList: TStringList;
begin
  XList := TStringList.Create;
  CheckListBox1.Items.BeginUpdate;
  try
    XList.Assign(CheckListBox1.Items);
    XList.CustomSort(CompareStrings);
    CheckListBox1.Items.Assign(XList);
  finally
    XList.Free;
    CheckListBox1.Items.EndUpdate;
  end;
end;

Reading the IIS Meta Base

Problem/Question/Abstract:

In this article I am going to show you how to how to access to IIS Meta Base (in read-only mode). You can simply take this further to use the techniques shown here for administrative purposes. The IIS Meta Base is used to install web, ftp and gopher sites on your MS Windows server. This feature may be interesting for your installer applications.
You need MS Windows 2000 with IIS or MS Windows NT 4 SP 6a with IIS installed.

Answer:

IN THE BEGINNING

Many of you develop, just as I do, Internet server applications. After weeks of planning and testing your applications you are ready to deploy it. Now you have to write a detailed explaination of how to install and administrate your application. At this point this article will give you a little head start. Windows has the Registry, which is a great tool for administrating many aspects of the computer, however, not all aspects are administratable through the Registry.

The IIS has to be administrated through the IIS Metabase. In your {system32}\inetsrv\iisadmin folder there are many ASP examples on how to access the IIS Metabase, however, these are not easily taken to Delphi. Starting with the GetObject function, that does not exist in Delphi, going to enumarations and so on.

VB SCRIPTS GetObject

Scanning through the ASP files in the IISAdmin folder you will hit the GetObject function quite a few times. The GetObject will return the interface to an object already loaded into the computers memory. The object is named by a string similar to 'IIS://localhost'. GetObject will allow you to get access to objects running on other computers, too. In one of the D3K articles I have found a method that will compromise for this VB Script function. I have named the function VBGetObject, because as a function with this name already exists in Delphi.

function VBGetObject(const Name: string): IDispatch;
var
  BindContext: IBindCtx;
  Moniker: IMoniker;
  Eaten: Integer;
begin
  OleCheck(CreateBindCtx(0, BindContext));
  OleCheck(MkParseDisplayName(
    BindContext, PWideChar(WideString(Name)), Eaten, Moniker
    ));
  OleCheck(Moniker.BindToObject(BindContext, nil, IDispatch, Result));
end;

ENUMERATIONS (COLLECTIONS) IN DELPHI

VBScript has the nice construct for each ... in ..., a simple and fast way to access all objects (items) in an list ("array") of those. There is no similar construct in Delphi to use, well you want need it anyway, we'll work around it. :)

Usually all enumerations have a count property and an items property as well, however Micrsoft decided to NOT implement these in these ADSI classes properly. Therefore, we cannot us them in an for I := 0 to Pred(Count) do type of construction. We rather have to access the enumeration object and simulate the for...each loop ourselves.

procedure DoEnum(Cont: IADsContainer[...]);
var
  I: Cardinal;
  Enum: IEnumVariant;
  rgvar: OleVariant;
  [...]
begin
  try
    // get a hold on the variant collection
    Enum := Cont._NewEnum as IEnumVariant;
    Enum.Reset;
    Enum.Next(1, rgvar, I);
    // enumerate the variant collection
    while I > 0 do
    begin
      [...]
        Enum.Next(1, rgvar, I);
    end;
  except
  end;
end;

The function above is taken from the source below with a few parts omitted to show the basic idea of enumerations. First we get the Enumeration object and cast it as IEnumVariant, the default VB Script enumeration type. Next, we reset the enumeration, just in case and then we get the first item for the enumeration. We loop through the enumeration until no item is returned anymore. That's all.

CREATING THE APPLICATION

Start Delphi and create a new application (in case another is still open). The following code will assume a few component names, please add them accordingly:

your main form: NAME=frmMain

TTreeView: NAME=trvMBStructure ALIGN=alLeft

TListView: NAME=lstMBItems ALIGN=alClient VIEWSTYLE=vsReport, add three Columns to the list CAPTIONS=(Property,Type,Value)

TStatusBar: NAME=sttInfo SIMPLEPANEL=True


Save the Unit1 as uMainForm.pas.

Next go to the menu "Project|Import Type Library...". (NOTE: This step may not work on Delphi 6 properly - sorry, you will have to wait for the first service pack. :( ) Click the "Add.." button and select the "activeds.tlb" from your "Winnt\System32" directory. Select a unit directory and click the "Create Unit" button. The file "ActiveDs_TLB.pas" will be created.

Next paste the code from below and run your application. I hope the comments will give you all information you need.

THE CODE

unit uMainForm;

interface

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

type
  TADsContainer = class
  private
    FIntf: IADsContainer;
    FPath: string;
    FProperties: TStringList;
    function GetADsClass: IADsClass;
    procedure LoadProperties;
  protected
  public
    constructor Create(aIntf: IADsContainer);
    destructor Destroy; override;

    property Path: string read FPath;
    property Intf: IADsContainer read FIntf;
    property ADsClass: IADsClass read GetADsClass;
    property Properties: TStringList read FProperties;
  end;

  TfrmMain = class(TForm)
    trvMBStructure: TTreeView;
    splDummy: TSplitter;
    lstMBItems: TListView;
    sttInfo: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure trvMBStructureChange(Sender: TObject; Node: TTreeNode);
  private
    FADsContainer: TObjectList;
    procedure EnumIISMetaBase;
    procedure ShowItemInfo(ADsContainer: TADsContainer);
  public
  end;

var
  frmMain: TfrmMain;

implementation

uses
  ActiveX, ComObj;

{$R *.DFM}

// simulates VB Scripts GetObject - a method to get an instance to an already
// loaded object in memory

function VBGetObject(const Name: string): IDispatch;
var
  BindContext: IBindCtx;
  Moniker: IMoniker;
  Eaten: Integer;
begin
  OleCheck(CreateBindCtx(0, BindContext));
  OleCheck(MkParseDisplayName(
    BindContext, PWideChar(WideString(Name)), Eaten, Moniker
    ));
  OleCheck(Moniker.BindToObject(BindContext, nil, IDispatch, Result));
end;

{ TADsContainer }

constructor TADsContainer.Create(aIntf: IADsContainer);
begin
  inherited Create;
  FIntf := aIntf;
  FProperties := TStringList.Create;
  FPath := IADsSyntaxDisp(FIntf).ADsPath;
  LoadProperties;
end;

destructor TADsContainer.Destroy;
begin
  FreeAndNil(FProperties);
  FIntf := nil;
  inherited Destroy;
end;

function TADsContainer.GetADsClass: IADsClass;
begin
  Result := VBGetObject(IADsODisp(FIntf).Schema) as IADsClass;
end;

procedure TADsContainer.LoadProperties;
var
  I: Integer;
  Props: OleVariant;
begin
  // iis objects can have mandatory and optional properties
  // the must be loaded seperately
  // the IADS objects will return a safe-array if there are more than one
  // properties, a OleString will be returned if there is just one property
  FProperties.Clear;
  // load mandatory properties
  Props := ADsClass.MandatoryProperties;
  if VarType(Props) and varArray = varArray then
    for I := VarArrayLowBound(Props, 1) to VarArrayHighBound(Props, 1)
      do
      FProperties.Add(Props[I])
  else
    FProperties.Add(Props);
  // load optional properties
  Props := ADsClass.OptionalProperties;
  if VarType(Props) and varArray = varArray then
    for I := VarArrayLowBound(Props, 1) to VarArrayHighBound(Props, 1)
      do
      FProperties.Add(Props[I])
  else
    FProperties.Add(Props);
end;

{ TfrmMain }

procedure TfrmMain.EnumIISMetaBase;
  procedure DoEnum(Cont: IADsContainer; Parent: TTreeNode; Path: string);
  var
    I: Cardinal;
    Enum: IEnumVariant;
    rgvar: OleVariant;
    Node: TTreeNode;
    ADsContainer: TADsContainer;
  begin
    try
      // get a hold on the variant collection
      Enum := Cont._NewEnum as IEnumVariant;
      Enum.Reset;
      Enum.Next(1, rgvar, I);
      // enumerate the variant collection
      while I > 0 do
      begin
        // create a tree node for every item in the collection
        Node := trvMBStructure.Items.AddChild(Parent, rgvar.Name);
        ADsContainer := TADsContainer.Create(IDispatch(rgvar) as IADsContainer);
        FADsContainer.Add(ADsContainer);
        Node.Data := ADsContainer;
        // enumerate sub-items
        DoEnum(ADsContainer.Intf, Node, ADsContainer.Path);
        Enum.Next(1, rgvar, I);
      end;
    except
    end;
  end;
var
  Root: string;
begin
  trvMBStructure.Items.BeginUpdate;
  try
    // clear previous
    trvMBStructure.Items.Clear;
    FADsContainer.Clear;
    // you could enumerate other objects, like LDAP, too
    Root := 'IIS://LocalHost';
    DoEnum(VBGetObject(Root) as IADsContainer, nil, Root);
  finally
    trvMBStructure.Items.EndUpdate;
  end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FADsContainer := TObjectList.Create;
  // load the iis meta base
  EnumIISMetaBase;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FADsContainer);
end;

procedure TfrmMain.ShowItemInfo(ADsContainer: TADsContainer);
var
  I: Integer;
  PropName: string;
  LI: TListItem;
begin
  lstMBItems.Items.BeginUpdate;
  try
    lstMBItems.Items.Clear;
    if ADsContainer <> nil then
    begin
      // show current iis path
      sttInfo.SimpleText := ADsContainer.Path;
      // iterate all properties, skip the first ('')
      for I := 1 to Pred(ADsContainer.Properties.Count) do
      begin
        LI := lstMBItems.Items.Add;
        // get the property name
        PropName := ADsContainer.Properties.Strings[I];
        // load property name
        LI.Caption := PropName;
        // get property type
        LI.SubItems.Add('0x' + IntToHex(VarType(
          IADsDisp(ADsContainer.Intf).Get(PropName)
          ), 8));
        // get property value
        case VarType(IADsDisp(ADsContainer.Intf).Get(PropName)) of
          varEmpty:
            LI.SubItems.Add('(value is empty)');
          varNull:
            LI.SubItems.Add('(value is null)');
          varSmallint, varInteger, varSingle, varDouble, varCurrency,
            varDate, varOleStr, varBoolean:
            LI.SubItems.Add(IADsDisp(ADsContainer.Intf).Get(PropName));
        else
          LI.SubItems.Add('(data type not handled)');
        end;
      end;
    end
    else
    begin
      sttInfo.SimpleText := '';
    end;
  finally
    lstMBItems.Items.EndUpdate;
  end;
end;

procedure TfrmMain.trvMBStructureChange(Sender: TObject; Node: TTreeNode);
begin
  if Node = nil then
    ShowItemInfo(nil)
  else
    ShowItemInfo(TADsContainer(Node.Data));
end;

end.

How to make the Enter key act as the Tab key while inside a TDBGrid

Problem/Question/Abstract:

How to make the Enter key act as the Tab key while inside a TDBGrid

Answer:

This code also includes the processing of the [Enter] key for the entire application - including fields, etc. The grid part is handled in the ELSE portion of the code. The provided code does not mimic the behavior of the key stepping down to the next record when it reaches the last column in the grid - it moves back to the first column.

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
{This is the event handler for the form's OnKeyPress event!}
{You should also set the Form's KeyPreview property to True}
begin
  if Key = #13 then { if it's an Enter key }
    if not (ActiveControl is TDBGrid) then { if not on a TDBGrid }
    begin
      Key := #0; { eat Enter key }
      Perform(WM_NEXTDLGCTL, 0, 0); { move to next control }
    end
    else if (ActiveControl is TDBGrid) then { if it is a TDBGrid }
      with TDBGrid(ActiveControl) do
        if selectedindex < (fieldcount - 1) then { increment the field }
          selectedindex := selectedindex + 1
        else
          selectedindex := 0;
end;

Creating a system wide shortcut or hotkey

Problem/Question/Abstract:

How to create and handle a system wide shortcut or hotkey (one that is handled beyond the application)

Answer:

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

  Copyright &copy; by Jim McKeeth
  Licensed under LGPL
  ( http://www.gnu.org/licenses/licenses.html#LGPL )


  Demo of creating a system wide hotkey
  or shortcut

This was written in Delphi 7,
but should work in most other versions
(but obviously not Kylix)

  You need a form with
  1) a THotKey named HotKey1
  2) a TCheckBox named CheckBox1

  To demo
  1) Change the hotkey in the value
  2) Check the box
  3) Minimize the application
  4) Press the hot key
  5) Be impressed

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

unit SystemHotKeyUnit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, StdCtrls, ComCtrls, Dialogs,
  // Menus need to be added for calls in the code
  Menus;

type
  TForm1 = class(TForm)
    HotKey1: THotKey;
    CheckBox1: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  protected
    // Handle the global hot key messages when they are sent to the window
    procedure HotyKeyMsg(var msg: TMessage); message WM_HOTKEY;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  myAtom: integer;

function ShiftState2Modifier(const Shift: TShiftState): Word;
begin
  Result := 0;
  if ssShift in Shift then
    Result := Result or MOD_SHIFT;
  if ssAlt in Shift then
    Result := Result or MOD_ALT;
  if ssCtrl in Shift then
    Result := Result or MOD_CONTROL;
end;

function GetShortCutKey(ShortCut: TShortCut): Word;
var
  shift: TShiftState;
begin
  ShortCutToKey(ShortCut, Result, shift); // call in Menus!
end;

function GetShortCutModifier(ShortCut: TShortCut): Word;
var
  key: Word;
  shift: TShiftState;
begin
  ShortCutToKey(ShortCut, key, shift); // call in Menus!
  Result := ShiftState2Modifier(shift);
end;

function RegisterHotShortCut(const h: THandle; const Atom: integer; const ShortCut:
  TShortCut): Boolean;
var
  key: Word;
  Shift: TShiftState;
begin
  UnregisterHotKey(h, Atom); // call in Windows
  ShortCutToKey(ShortCut, key, shift);
  Result := RegisterHotKey(h, Atom, ShiftState2Modifier(Shift), key);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // you need to type cast it as a pChar if you are using a string
  myAtom := GlobalAddAtom(pchar('HotKeyDemo'));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnregisterHotKey(Handle, myAtom);
  GlobalDeleteAtom(myAtom);
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked then
    RegisterHotShortCut(Handle, myAtom, HotKey1.HotKey)
  else
    UnregisterHotKey(Handle, myAtom);
end;

procedure TForm1.HotyKeyMsg(var msg: TMessage);
begin
  if (msg.LParamLo = GetShortCutModifier(HotKey1.HotKey))
    and (msg.LParamHi = GetShortCutKey(HotKey1.HotKey)) then
  begin
    Application.BringToFront;
    Showmessage('Hey, now that is a system wide hot key!')
  end;
end;

end.

How to copy all settings from a MenuItem made at designtime to a MenuItem created at runtime

Problem/Question/Abstract:

I am trying to make it possible for my program to create new MenuItems at runtime. I want to copy the settings from a MenuItem made at designtime to the new MenuItems. All the properties and event handlers.

Answer:

procedure CopyMenuRaw(const Source, MenuTest: TMenuItem);
begin
  MenuTest.Caption := Source.Caption;
  MenuTest.Checked := Source.Checked;
  MenuTest.Default := Source.Default;
  MenuTest.Enabled := Source.Enabled;
  MenuTest.GroupIndex := Source.GroupIndex;
  MenuTest.HelpContext := Source.HelpContext;
  MenuTest.Hint := Source.Hint;
  MenuTest.ImageIndex := Source.ImageIndex;
  MenuTest.Name := Source.Name;
  MenuTest.RadioItem := Source.RadioItem;
  MenuTest.Tag := Source.Tag;
  MenuTest.Visible := Source.Visible;
  MenuTest.OnClick := Source.OnClick;
  MenuTest.OnDrawItem := Source.OnDrawItem;
  MenuTest.OnMeasureItem := Source.OnMeasureItem;
end;

procedure CopyMenuItem(var Source, MenuTest: TMenuItem);
begin
  MenuTest := TMenuItem.Create(nil);
  CopyMenuRaw(Source, MenuTest);
end;

Used like this:

CopyMenuItem(WholeScreen1, MenuTest);

Where WholeScreen1 is an existing TMenuItem and MenuTest is TMenuItem that is defined in
your Var section.

How to draw a circle pixel by pixel

Problem/Question/Abstract:

How to draw a circle pixel by pixel

Answer:

{ ... }

implementation

{$R *.DFM}

uses
  Math;

procedure DrawCircle(CenterX, CenterY, Radius: Integer; Canvas: TCanvas; Color:
  TColor);

  procedure PlotCircle(x, y, x1, y1: Integer);
  begin
    Canvas.Pixels[x + x1, y + y1] := Color;
    Canvas.Pixels[x - x1, y + y1] := Color;
    Canvas.Pixels[x + x1, y - y1] := Color;
    Canvas.Pixels[x - x1, y - y1] := Color;
    Canvas.Pixels[x + y1, y + x1] := Color;
    Canvas.Pixels[x - y1, y + x1] := Color;
    Canvas.Pixels[x + y1, y - x1] := Color;
    Canvas.Pixels[x - y1, y - x1] := Color;
  end;

var
  x, y, r: Integer;
  x1, y1, p: Integer;
begin
  x := CenterX;
  y := CenterY;
  r := Radius;
  x1 := 0;
  y1 := r;
  p := 3 - 2 * r;
  while (x1 < y1) do
  begin
    plotcircle(x, y, x1, y1);
    if (p < 0) then
      p := p + 4 * x1 + 6
    else
    begin
      p := p + 4 * (x1 - y1) + 10;
      y1 := y1 - 1;
    end;
    x1 := x1 + 1;
  end;
  if (x1 = y1) then
    plotcircle(x, y, x1, y1);
end;

Used like this:

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawCircle(ClientWidth div 2, ClientHeight div 2, Min(ClientWidth div 2,
    ClientHeight div 2), Canvas, clBlack);
  {Add Math to the uses clause for the Min function}
end;