How to loop through the keys in the registry

Problem/Question/Abstract:

I am making a program for editing the registry. It will basically be the same as regedit, but with some added features. What I want to know is how should I go about reading the registry into my TreeView and ListView components and how do I specify which icons to use in the tree view? I know you can load files into a list view using the FindFirst, FindNext and FindClose, but how do you loop through the keys in the registry?

Answer:

Enumerating registry keys:


procedure TForm1.Button1Click(Sender: TObject);
var
  indent: Integer;

  procedure EnumAllKeys(hkey: THandle);
  var
    l: TStringList;
    n: Integer;
  begin
    Inc(indent, 2);
    with TRegistry.Create do
    try
      RootKey := hkey;
      OpenKey(EmptyStr, false);
      l := TStringLIst.Create;
      try
        GetKeynames(l);
        CloseKey;
        for n := 0 to l.Count - 1 do
        begin
          memo1.lines.add(StringOfChar(' ', indent) + l[n]);
          if OpenKey(l[n], false) then
          begin
            EnumAllKeys(CurrentKey);
            CloseKey;
          end;
        end;
      finally
        l.Free
      end;
    finally
      Free;
    end;
    Dec(indent, 2);
  end;
begin
  memo1.Clear;
  memo1.lines.add('Keys under HKEY_CURRENT_USER');
  indent := 0;
  EnumAllKEys(HKEY_CURRENT_USER);
end;

Application help file set properly

Problem/Question/Abstract:

Delphi provides a dialog box to set the application help file. Click Project -> Options and select the Application tab. If you click [Browse] to locate the help file of your application, Delphi sets the help file name including the full path. When you deploy the application, the help file is probably not found because the installation path on your user's computer is not the same.

Answer:

You must specify the help file name without a path or with a relative path. If the help is located in the same directory as the application exe, simply omit the path. If it is located in a sub-directory, specify a relative path. For instance, enter

./help/myhelpfile.hlp

in the dialog box, if there is a sub-directory called "help" below your application's installation folder.

Problem solved? Not completely. This solution works as long as the current directory of your application is the default directory of your application (one where the exe file is installed). This is typically the case, but the current directory may change while your application is running. A call to SetCurrentDir(newdirname) for instance, changes that.

But Windows provides a solution for this. You can enter the path to your help file in the Windows registry. If you do, specify only the help file name in Delphi, no path at all. Then modify the registry key

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\Help

and enter a new key for your help file which specifies the path to it.

A third way (and my preferred one) to specify the application help file is to code it manually. It's a single code line you add to the Create event of your main form and you don't have to worry about current directories or registry entries:

procedure TMainForm.FormCreate(Sender: TObject);
begin
  Application.HelpFile :=
    ExtractFileDir(Application.Exename) +
    '\help\HilfeDatei.hlp';
end;

How to display an HTML document

Problem/Question/Abstract:

I need to display the contents of a HTML document from a Delphi4 program. Can I somehow execute a 'doubleclick' of the HTML file (automatically activating the default browser)?

Answer:

Yes, that's what ShellExecute or ShellExecuteEx allow you to do:

function showHtml(sDocName: string): boolean;
begin
  result := (32 < shellExecute(0, 'open', pChar(sDocName), nil, nil, sw_minimize));
end;

Kernel32.dll Interactive Applications

Problem/Question/Abstract:

This article will teach you how to be interactive with Windows&reg; operating system DLL's, this also helps you building smaller windows applications .

Answer:

Well, here are the commands !!
to try any of them just run it from windows, and in Delphi as you know just
winexec(Pchar('ABCD'),sw_Show);
where 'ABCD' is one of the following lines of commands .
OR
example:
shellExecute( handle, 'open', 'rundll32', 'shell32.dll,Control_RunDLL', '', SW_SHOWNORMAL );
to open control pane, for example on windows_NT !!


"rundll32 shell32,Control_RunDLL" - Run The Control Panel

"rundll32 shell32,OpenAs_RunDLL" - Open The 'Open With...' Window

"rundll32 shell32,ShellAboutA Info-Box" - Open 'About Window Window'

"rundll32 shell32,Control_RunDLL desk.cpl" - Open Display Properties

"rundll32 user,cascadechildwindows" - Cascade All Windows

"rundll32 user,tilechildwindows" - Minimize All Child-Windows

"rundll32 user,repaintscreen" - Refresh Desktop

"rundll32 shell,shellexecute Explorer" - Re-Start Windows Explorer

"rundll32 keyboard,disable" - Lock The Keyboard

"rundll32 mouse,disable" - Disable Mouse

"rundll32 user,swapmousebutton" - Swap Mouse Buttons

"rundll32 user,setcursorpos" - Set Cursor Position To (0,0)

"rundll32 user,wnetconnectdialog" - Show 'Map Network Drive' Window

"rundll32 user,wnetdisconnectdialog" - Show 'Disconnect Network Disk' Window

"rundll32 user,disableoemlayer" - Display The BSOD Window note '''(BSOD) = Blue Screen Of Death '''

"rundll32 diskcopy,DiskCopyRunDll" - Show Copy Disk Window

"rundll32 rnaui.dll,RnaWizard" - Run 'Internet Connection Wizard', If run with "/1" - silent mode

"rundll32 shell32,SHFormatDrive" - Run 'Format Disk (A)' Window

"rundll32 shell32,SHExitWindowsEx -1" - Cold Restart Of Windows Explorer

"rundll32 shell32,SHExitWindowsEx 1" - Shut Down Computer

"rundll32 shell32,SHExitWindowsEx 0" - Logoff Current User

"rundll32 shell32,SHExitWindowsEx 2" Windows9x Quick Reboot

"rundll32 krnl386.exe,exitkernel" - Force Windows 9x To Exit (no confirmation)

"rundll rnaui.dll,RnaDial "MyConnect" - Run 'Net Connection' Dialog

"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - Choose & Print Test Page Of Current Printer

"rundll32 user,setcaretblinktime" - Set New Cursor Rate Speed

"rundll32 user, setdoubleclicktime" - Set New DblClick Speed (Rate)

"rundll32 sysdm.cpl,InstallDevice_Rundll" - Search For non PnP Devices .


hope you enjoy it !!
Ruslan.
====================

Check for an existing worksheet in Excel

Problem/Question/Abstract:

How can I check if a work sheet (e.g. 'first') is existing in an Excel file?

Answer:

In late binding:

{ ... }
WB := Excel.Workbooks[1];
for Idx := 1 to WB.Worksheets.Count do
  if WB.Worksheets[Idx].Name = 'first' then
    Showmessage('Found the worksheet');
{ ... }

Write a stack class for Interfaces

Problem/Question/Abstract:

How to work with a stack of interfaces? Should I use TObjectStack or simply TStack?

Answer:

Using a storage class that uses elements typed as pointer or TObject is very risky with interfaces, since hard typecasts are needed, and they mess up the reference counting. So it is better to write your own stack class for interfaces, perhaps based on an internal TInterfaceList as storage mechanism. Something like this (untested!):

{ ... }
type
  TInterfaceStack = class
  private
    FList: TInterfacelist;
    FCurrent: IInterface;
    function GetTop: IInterface;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Push(aIntf: IInterface);
    procedure Pop;
    function IsEmpty: boolean;
    property Top: IInterface read GetTop;
  end;

  { TInterfaceStack }

constructor TInterfaceStack.Create;
begin
  inherited;
  FList := TInterfacelist.Create;
  FList.Capacity := 32;
end;

destructor TInterfaceStack.Destroy;
begin
  FList.Free;
  inherited;
end;

function TInterfaceStack.GetTop: IInterface;
begin
  Result := FCurrent;
end;

function TInterfaceStack.IsEmpty: boolean;
begin
  Result := not Assigned(FCurrent);
end;

procedure TInterfaceStack.Pop;
begin
  if Flist.Count > 0 then
  begin
    FCurrent := FList[FList.count - 1];
    FList.Delete(Flist.Count - 1);
  end
  else
    FCurrent := nil;
end;

procedure TInterfaceStack.Push(aIntf: IInterface);
begin
  if not IsEmpty then
    FList.Add(FCurrent);
  FCurrent := aIntf;
end;

Determine your local IP using Winsock

Problem/Question/Abstract:

Determine your local IP using Winsock

Answer:

The code below uses the WinSock unit to lookup your local IP number. Simply call the function LocalIP - it will return your IP as a string.

In a LAN, it will return your local IP number, e.g. 192.168.100.25, not your external IP number.


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function LocalIP: string;
type
  TArrayPInAddr = array[0..10] of PInAddr;
  PArrayPInAddr = ^TArrayPInAddr;
var
  phe: PHostEnt;
  pptr: PArrayPInAddr;
  Buffer: array[0..63] of char;
  i: integer;
  GInitData: TWSADATA;
begin
  WSAStartup($101, GInitData);
  result := '';
  GetHostName(Buffer, sizeof(Buffer));
  phe := GetHostByName(Buffer);
  if phe = nil then
  begin
    exit
  end;
  pptr := PArrayPInAddr(phe^.h_addr_list);
  i := 0;
  while pptr^[i] <> nil do
  begin
    result := StrPas(inet_ntoa(pptr^[i]^));
    Inc(i);
  end;
  WSACleanup;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ShowMessage('Your computer''s IP address is: ' + LocalIP);
end;

end.

How to save and restore the position of TCoolBar bands

Problem/Question/Abstract:

I can save the TToolbar positions but I never succeed in restoring their positions. I put them in either in TControlBar or TCoolBar. How do I position them correctly?

Answer:

Saving:

{Coolbar}
for i := 0 to Coolbar.Bands.Count - 1 do
  with Coolbar.Bands[i] do
    seOptions['Band' + IntToStr(ID)] := Format('%d,%d,%d,%d', [Integer(Break),
      Width, Index, Integer(Control.Visible)]);


Loading:

{Coolbar}
for i := 0 to Coolbar.Bands.Count - 1 do
  with Coolbar.Bands[i] do
  begin
    BandInfo := seOptions['Band' + IntToStr(ID)];
    if BandInfo <> '' then
    try
      Break := Boolean(StrToInt(CutFirst(BandInfo)));
      Width := StrToInt(CutFirst(BandInfo));
      Index := StrToInt(CutFirst(BandInfo));
      Control.Visible := Boolean(StrToInt(CutFirst(BandInfo))); {this line untested}
    except;
    end;
  end;

seOptions is a settings object and can store values 'by name'. BandInfo is a string. CutFirst returns the first value from a comma separated list string and removes it from the string.

Get and Set volume (soundcard)

Problem/Question/Abstract:

How do I get the soundcard's volume? How to set it ?

Answer:

procedure GetVolume(var volL, volR: Word);
var
  hWO: HWAVEOUT;
  waveF: TWAVEFORMATEX;
  vol: DWORD;
begin
  volL := 0;
  volR := 0;
  // init TWAVEFORMATEX
  FillChar(waveF, SizeOf(waveF), 0);
  // open WaveMapper = std output of playsound
  waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
  // get volume
  waveOutGetVolume(hWO, @vol);
  volL := vol and $FFFF;
  volR := vol shr 16;
  waveOutClose(hWO);
end;

procedure SetVolume(const volL, volR: Word);
var
  hWO: HWAVEOUT;
  waveF: TWAVEFORMATEX;
  vol: DWORD;
begin
  // init TWAVEFORMATEX
  FillChar(waveF, SizeOf(waveF), 0);
  // open WaveMapper = std output of playsound
  waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
  vol := volL + volR shl 16;
  // set volume
  waveOutSetVolume(hWO, vol);
  waveOutClose(hWO);
end;

How to store a procedure or function in a variable

Problem/Question/Abstract:

Is there some way I can store a procedure or function in a variable so I can call the procedure with the variable? I'm thinking of something similar to where you can declare a variable of a certain object type, then assign different objects of that type to the variable. If it can be done with procedures, how would it be assigned and what would the syntax be to call the procedure?

Answer:

Yes, you can declare a procedural type for functions with the same parameter list and function type. Briefly it looks something like this:


{ ... }
type
  TMathFunc = function(A, B: double): double; {defines signature of function}
  { ... }
var
  mathfunc: TMathFunc;
  answer: double;
  { ... }

{Now if you define two functions}

function Adder(A, B: double): double;
begin
  result := A + B;
end;

function Multiplier(A, B: double): double;
begin
  result := A * B;
end;

begin
  {You can do this}
  mathfunc := Adder;
  answer := mathfunc(5, 9);
  mathfunc := Multiplier;
  answer := mathfunc(5, 9);
end;

How to validate 24 hour time using a DBEdit field

Problem/Question/Abstract:

I want to have the user to enter a valid 24 hour time into a string field using hours and minutes only. How do I set up a validation to make sure the user does not enter something like 25:00 or 23:60 ?

Answer:

In order to prevent invalid entry character by character, you can use an OnKeyPress event handler and the following as an example:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if not ValidEditTime(Edit1, Key) then
    Key := #0;
end;

function ValidEditTime(ed: TCustomEdit; sfx: char): boolean;
var
  pfx: string;

  function CheckVal(const s: string; lim1, lim2: integer): boolean;
  var
    v: integer;
  begin
    v := StrToIntDef(s + sfx, lim2);
    if Length(s) = 0 then
      Result := (v < lim1)
    else
      Result := (v < lim2);
  end;

var
  p: integer;
begin
  Result := not (sfx in ['0'..'9', ':']);
  if (not Result) or (sfx <> #8) then
  begin
    pfx := ed.Text;
    if ed.SelLength > 0 then
      Delete(pfx, ed.SelStart + 1, ed.SelLength);
    p := Pos(':', pfx + sfx);
    if p = 0 then
      Result := CheckVal(pfx, 3, 24)
    else
    begin
      Result := (p = 3);
      if Result then
      begin
        Result := (p > Length(pfx));
        if not Result then
          Result := CheckVal(Copy(pfx, p + 1, Length(pfx) - p), 6, 60)
      end;
    end;
  end;
end;

Although the above is quite sophisticated, you will probably need an OnValidate routine as well in order to handle pasting into the control.

Determine the maximum free disk space

Problem/Question/Abstract:

I need a function to get the local disk with the maximum free space.

Answer:

uses
  Windows;

{ ... }
var
  lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes:
    PLargeInteger;
begin
  New(lpFreeBytesAvailableToCaller);
  New(lpTotalNumberOfBytes);
  New(lpTotalNumberOfFreeBytes);
  try
    GetDiskFreeSpaceEx('C:', lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes,
      lpTotalNumberOfFreeBytes);
  finally
    Dispose(lpFreeBytesAvailableToCaller);
    Dispose(lpTotalNumberOfBytes);
    Dispose(lpTotalNumberOfFreeBytes);
  end;
end;

Place a business logic in server side

Problem/Question/Abstract:

How to store a business objects in database tables?

Answer:

The devlopment of large projects is hard work. Especially when our clients are remote/mobil users.Also in our life exists the task which are not stay on one place and which algorithm changes in time. In these situations we must to develop the multi-tier application and store the business logic in server-app level. But for some tasks this way is very expensive. So I prefers the some "2 1/2"-tier level when part of business logic we can store in database. I'll try to describe this my opinion.

On server database I have a few own "system" tables with descriptions of project:

CLASS table is a list of all available user queries with short description, select/update/insert/delete statements
DESCRIPTION table stores the descriptions of fields for each record in CLASS
A few additional tables with security (user, groups, privileges, access modes etc) PS: I do not describe them, as for the basic description they are not so important

In application I have a main datamodule, which contains the one TDatabase component (linked to my BDE alias or ADO connection). Also I have a some TDataModule component which are the parent for each other. On this component I dropped the TQuery (linked to main TDatabase), and TUpdateSQL and TDataSource, which are linked to TQuery.

Also in this parent datamodule I included the some additional properties and procedures/functions:

to get a descriptions from server by class name
to fill a update/delete/insert properties of TUpdateSQL
to change a filter (via where clause), a data order (via order by) etc (any clause in sql - I use a some macros in own sqls)
post/cancel changes in server database, refresh data
to get the new ID (for autoincremental fields)
to read a user privileges
to open class
to get a "lookup" class. I not use a delphi lookup fields. Instead it I store in class descriptions for some fields the additional info (which class I must open for edit/view of data, which fields are linked in "lookup" class etc and more)
and more additional features

Each datamodule are successor of this parent DM with "personal" extension in business logic. For example, in the class for details of orders I defined the specific calculations (some subtotals and sums) or procedures (check of outputing qnt). The full logic I included in these DMs only (in visual forms
I use a calls only!).

Also I have a basic visual TForm with grid, navigator, filter panel etc.
This form have a "linked" DataModule. Also this form known how:

to fill the info from DM (a columns list for dbgrid (from description in DM), form caption and more)
to call a form for edit/append of record (those form not uses the any DB-components!!)
to generate report (I use a SMReport)
to export data (I use a SMExport)
to find a record by some criteria
to select a records (the some forms I use for selecting of some recors) PS: for example, in orders mode my users can select a records from product class and append the wished
to open a "lookup" class. PS: for example, in grid with customer list my users can open a class of customer types (instead standard delphi lookup field) or "drill" in orders list for this customer
to setup the visualization of data (fonts, colors, order etc, filter, sort and grouping)
and more additional features

All the rest forms inherits from this parent and are different one from other in needed possibilities only. For example, if my users want to calculate a sum of some order for specific product type only, of course, I add a calc function in linked DM and drop a button on form for calling of this function in DM

PS: in visual forms (when I need to calc or to do a something) I call the "assigned" method in "assigned" DM.

Also I have a two list - opened DMs and created forms. So if I need open a "lookup" class, I search it in list of DM and create only if I not found. And with forms I work similar.

Using this schema I can devide the project from my "2 1/2"-tier level on multi-tier in few simple operations (because the all business logic I store in database on db-server and mine DM-classes. The visual forms not contains the logic - only visualization).

PS: this technology I uses in tens projects (current and finished), in small app and in big projects. I described the customers-orders-products schema for availability of understanding only. Of course, sometimes (more often in the beginning of development of small app) the perspective of the extension of functionality up to large client-server
system (and especially multi-tier) is not visible and it's possible to go on easy way - drop on form the ttables (or even to allocate them in separate datamodule), linked it with grids, use a master-detail link and lookup fields etc
But when you decide to expand possibilities of the app and transfer it from local DB (Paradox/DBase/Access etc) on normal DB server and maybe use a 3-tier you will understand, that is necessary to change the approach to DB programming for rise of productivity, easy support and extension of project.

Of course, it's my opinion only, but I have come to such technology by many cuts and tries during 10 years on different DBs and tools of development. Though I still do not have also thirty years I have a  large number of successful developments in other departs and if I can to someone reduce this long way, it will be well.

I do not apply for indisputable true and I know many weak places in the described technology, but they not impasses - it is simply not up to the end are realized (and it's good:))) I'll read criticism of other with pleasure too.

How to indent the focus rectangle in an owner-drawn TListBox

Problem/Question/Abstract:

I have a TListBox with style lbOwnerDrawVariable. I want to draw some text indented 10 pixels from the left (this is no problem). However, I also want it so the highlighting color and focus rectangle are indented as well (so the 10 pixel margin is completely blank, no matter what items are selected). I can't seem to do this ... the focus rectangle always seems to extend all the way to the left. How do I get around this?

Answer:

The problem is that the control as coded draws the focus rectangle after your owner drawing code has completed. To override that you have to make a new control descending from TListbox (or TCustomlistbox) and give it a handler for the CN_DRAWITEM message. Here you need to duplicate what the TCustomlistbox.CNDrawItem method does:

procedure TMyListBox.CNDrawItem(var Message: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  with Message.DrawItemStruct^ do
  begin
    State := TOwnerDrawState(LongRec(itemState).Lo);
    Canvas.Handle := hDC;
    Canvas.Font := Font;
    Canvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      Canvas.Brush.Color := clHighlight;
      Canvas.Font.Color := clHighlightText
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State)
    else
      Canvas.FillRect(rcItem);
    if odFocused in State then
    begin
      Inc(rcItem.left, 10); {this is the change}
      DrawFocusRect(hDC, rcItem);
    end;
    Canvas.Handle := 0;
  end;
end;

How to put data from a TStringGrid into an Excel spreadsheet

Problem/Question/Abstract:

How to put data from a TStringGrid into an Excel spreadsheet

Answer:

procedure TTradingForm.Button1Click(Sender: TObject);
var
  i, j: Integer;
  r, c: Integer;
  v: OleVariant;
  sRange: string;
  WorkBook: _Workbook;
  WorkSheet: _Worksheet;

  function ColToStr(ilCol: integer): string;
  var
    FirstLetter: integer;
    lastLetter: integer;
  begin
    result := '';
    firstLetter := (ilCol - 1) div 26 - 1;
    lastLetter := (ilCol - 1) mod 26;
    if firstLetter >= 0 then
      result := chr(ord('A') + firstletter);
    result := result + chr(ord('A') + lastLetter);
  end;

begin
  v := VarArrayCreate([0, Grid.RowCount - 1, 0, Grid.ColCount - 1], varVariant);
  for i := 0 to Grid.RowCount - 1 do
  begin
    for j := 0 to Grid.ColCount - 1 do
      if i = 0 then
        v[i, j] := Grid.Columns[j].Caption
      else
        v[i, j] := Grid.Cells[j, i];
  end;
  Screen.Cursor := crHourglass;
  try
    Excel.Connect;
    Excel.Visible[GetUserDefaultLCID] := False;
    WorkBook := Excel.Workbooks.Add(EmptyParam, GetUserDefaultLCID);
    WorkBook.Activate(GetUserDefaultLCID);
    Worksheet := Excel.ActiveWorkbook.Worksheets.Add(EmptyParam, EmptyParam, 2,
      xlWBATWorksheet, GetUserDefaultLCID) as _Worksheet;
    Excel.XLSelectWorksheet(1);
    r := VarArrayHighBound(v, 2) + 1;
    c := VarArrayHighBound(v, 1) + 1;
    sRange := 'A1..' + ColToStr(r) + IntToStr(c);
    Excel.XLSetRangeValue(sRange, v);
  finally
    Excel.Visible[GetUserDefaultLCID] := True;
    Excel.Disconnect;
    v := null;
    Screen.Cursor := crDefault;
  end;
end;

Build a TTreeView from a file

Problem/Question/Abstract:

I would like to populate a TTreeView from a simple file with the following structure

Key: Integer (unique)
Name: String (description)
Parent: Integer (key of parent in treeview)

I assume that the key and parent fields are all I need to build the treeview (parent = 0 would be a root node)

Answer:

I would break this down into two steps:

1) Read the file into memory
2) Populate the treeview using a recursive function


1) One method of doing this would be by building a TCollection/ TCollectionItem pair of classes. The TCollectionItems just need three fields:

TInputItem = class(TCollectionItem)
private
  fKey: integer;
  fName: string;
  fParent: integer;
public
  property Key: integer read fKey write fKey;
  property Name: string read fName write fName;
  property Parent: integer read fParent write fParent;
end;

Note: using properties is not strictly necessary, but is good style as it allows easier subsequent amendment.

Now we could use a standard TCollection to hold our TInputItems but it is neater to have a descendent of this too:

TInputCollection = class(TCollection)
public
  function AddItem(const AName: string; AKey, AParent: integer): TInputItem;
  property InputItem[index: integer]: TInputItem read GetInputItem; default;
end;

Creating a default property like InputItem above makes coding very tidy. It allows us to do the following:

var
  InputCollection: InputCollection;
  ix: integer;

InputCollection := TInputCollection.Create(TInputItem);
InputCollection.AddItem('First', 1, 0);
InputCollection.AddItem('Second', 2, 0);
InputCollection.AddItem('FirstChild', 3, 1);

for ix := 0 to InputCollection.Count - 1 do
  if InputCollection[ix].Parent = 0 then
    {DoSomething};

The last line, because of the index property being declared default, is the same as:

if InputCollection.InputItem[ix].Parent = 0 then
  {DoSomething;}

Without the property at all, you would code:

if TInputItem(InputCollection.Items[ix]).Parent = 0 thenDoSomething;
{DoSomething;}

In order to support the above, the implementation of the two methods:

function TInputCollection.AddItem(const AName: string; AKey, AParent: integer):
  TInputItem;
begin
  Result := Add as TInputItem;
  Result.Key := AKey;
  Result.Name := AName;
  Result.Parent := AParent;
end;

function TInputCollection.GetInputItem(index: integer): TInputItem;
begin
  Result := Items[ix] as TInputItem;
end;

We can now design an overall structure of a PopulateTree procedure:

procedure PopulateTree(tv: TTreeView);
var
  ic: TInputCollection;
begin
  ic := TInputCollection.Create(TInputItem);
  try
    LoadTreeItems(ic);
    PopulateTreeItems(tv, nil, ic, 0);
  finally
    ic.Free;
  end;
end;

LoadTreeItems can be tested via code similar to:

procedure LoadTreeItems(ic: TInputCollection);
begin
  ic.AddItem('First', 1, 0);
  ic.AddItem('Second', 2, 0);
  ic.AddItem('FirstChild', 3, 1);
end;

before replacing with your own loop through your input file. PopulateTreeItems is passed the treeview, the parent node and the parent id and it is a recursive routine.


2) Having done all the above, this part is now very easy. PopulateTreeItems iterates through the collection looking for items that match the passed parent id. For each item that matches, it adds a treenode and then calls PopulateTreeItems passing itself as the parent:

procedure PopulateTreeItems(tv: TTreeView; pnode: TTreeNode; ic: TInputCollection;
  parent: integer);
var
  node: TTreeNode;
  ix: integer;
begin
  for ix := 0 to ic.Count - 1 do
  begin
    if ic[ix].Parent = parent then
    begin
      node := tv.Items.Add(pnode, ic[ix].Name);
      PopulateTreeItems(tv, node, ic, ic[ix].Key); {recursive call}
    end;
  end;
end;

I apologise in advance if there are problems with the above code. It is completely untested. In practice, I don't do things quite like that, but populate treenodes on demand via the OnExpand event handler.

How to measure the distance between two points

Problem/Question/Abstract:

I need to measure a distance between two points to compute an intensity value. Currently I use

Dx := i - Cur.X;
Dy := j - Cur.Y;
Distance := Round(Sqrt(Dx * Dx + Dy * Dy));

Is there a faster way to compute this? Distance is an integer type so I was hoping to get a reasonably accurate solution as this method seems to produce. Problem is that it slows things down a bit.

Answer:

You can calculate the angle and then make a lookup table for the value to be used to multiply the Y-axis. Try this:


program DCDemo;

{$APPTYPE CONSOLE}

uses
  SysUtils, Math, My_Crt32;

const
  DegToRadFact = Pi / 180;
  RadToDegFact = 180 / Pi;

var
  DistSinArray: array[1..359] of Extended;

function Calcdist(const dX, dY: LongInt): LongInt;
var
  Angle, n: word;
begin
  if (dX <> 0) then
  begin
    if (dY <> 0) then
    begin
      Angle := Round(ArcTan(dY / dX) * RadToDegFact);
      Result := Round(dY / DistSinArray[Angle]);
    end
    else
      Result := dX;
  end
  else
    Result := dY;
end;

var
  dX, dY: LongInt;
begin
  {First time operation}
  for dX := 1 to 359 do
    DistSinArray[dX] := Sin(dX * DegToRadFact);
  Writeln('Geef dX: ');
  readln(dX);
  Writeln('Geef dY: ');
  readln(dY);
  Writeln(FloatToStr(Calcdist(dX, dY)));
  Readln;
end.

TClientDataSet: Temporary vs. permanent indices

Problem/Question/Abstract:

TClientDataSet: Temporary vs. permanent indices

Answer:

On TClientDataSets, that are not connected to a provider but loaded as local text files, ('thin client in brief-case mode'), you cannot use TQuerys. You may use the Filter property to select data and use an index to sort.

This sample code shows how to create a temporary index (not saved by SaveToFile())
and how to create a permanent index (saved by SaveToFile()):

with ClientDataSet1 do
begin
  Close;
  // Define the fields
  FieldDefs.Clear;
  FieldDefs.Add('Project', ftInteger, 0, True);
  FieldDefs.Add('Number', ftInteger, 0, False);
  // [..]
  // Define the PERMANENT index - it is saved with SaveToFile()
  IndexDefs.Clear;
  IndexDefs.Add('IProject', 'Project', [ixPrimary, ixUnique]);
  // Create the dataset
  CreateDataSet;
  Open;
  // the following temporary index is not saved
  // with data when using SaveToFile()
  AddIndex('TempIndex', 'Number;Project', [ixPrimary, ixUnique]);
end { with ClientDataSet1 }

Create an array of TEdit components on a TFrame

Problem/Question/Abstract:

Is it possible to have an array of components (for example TEdit) in a frame? If so, must I create them at runtime?

Answer:

You can create the components at design time, as usual. But you have to set up the array with the component references at run-time. This is quite painless if you use the default naming for the components the IDE produces, or something equivalent, with a running number at the names end:

{ ... }
private
Edits: array[1..10] of TEdit;
public

constructor Create(aOwner: TComponent); override;
{ ...  }

constructor TFrameX.Create(aOwner: TComponent);
var
  i: Integer;
  edt: TComponent;
begin
  inherited;
  for i := Low(Edits) to High(Edits) do
  begin
    edt := FindComponent('edit' + IntToStr(i));
    Assert(Assigned(edt), 'Edit' + IntToStr(i) + ' not found!');
    Edits[i] := edt as TEdit;
  end;
end;

Installer problem: '-115 error'

Problem/Question/Abstract:

I have reinstalled my system (NT 4.0 WS), but now when trying to install my Delphi 5 Professional I get this message:

**************
Setup has detected a -115 error while attempting to copy files.

This can be caused by a file being un use while trying to install.

Component: Program Files\Main program files\debugger
File: C:\Program Files\Common Files\Borland Shared\Debugger\bordbk50.dll\bordbk50.dll
Error: -115
**************

Answer:

Open a command-prompt. Change to the 'C:\Program Files\Common Files\Borland Shared\Debugger' directory and type the following command:

regsvr32 bordbk50.dll

How to create custom graphic hints

Problem/Question/Abstract:

How can I create my own hint windows, even with bitmaps and so on?

Answer:

You just have to add the following code to your project (it's just an example). You don't need to change something else in your project.  Maybe the code will run in earlier versions of Borland Delphi too, but didn't test it.


type
  TGraphicHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  private
    FActivating: Boolean;
  public
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
  protected
    procedure Paint; override;
  published
    property Caption;
  end;

  {...}

constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  //Here you can set custom Font properties:

  with Canvas.Font do
  begin
    Name := 'Arial';
    Style := style + [fsBold];
    Color := clBlack;
  end;
end;

procedure TGraphicHintWindow.Paint;
var
  R: TRect;
  bmp: TBitmap;
  l: TStrings;
begin
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);

  {*******************************************************
   The following Code is an example how to create a custom
   Hint Object. :
   *******************************************************}

  bmp := TBitmap.create;
  bmp.LoadfromFile('D:\hint.bmp');

  with Canvas do
  begin
    Brush.style := bsSolid;
    Brush.color := clsilver;
    Pen.color := clgray;
    Rectangle(0, 0, 18, R.Bottom + 1);
    Draw(2,(R.Bottom div 2) - (bmp.height div 2), bmp);
  end;

  bmp.free;

  Color := clWhite; //Beliebige HintFarbe
  //custom Hint Color

  Canvas.Brush.style := bsClear;
  //Canvas.TextOut(20,(R.Bottom div 2)-(canvas.Textheight(caption) div 2),caption);
  Inc(R.Left, 20);
  l := TStringlist.create;
  l.SetText(PChar(Caption));
  R.top := (R.Bottom div 2) - ((canvas.Textheight(caption) * l.count) div 2);

  DrawText(Canvas.Handle, PChar(Caption), -1, R, 0);

  l.free;
  {********************************************************}
end;

procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  FActivating := True;
  try
    Caption := AHint;
    Inc(Rect.Bottom, 14); //Set the "Height" Property of the Hint

    Rect.Right := Rect.right + 20; //Set the "Width" Property of the Hint
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then
      Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then
      Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
      SWP_SHOWWINDOW or SWP_NOACTIVATE);
    Invalidate;
  finally
    FActivating := False;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HintWindowClass := TGraphicHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

How to iterate over the MDI child array

Problem/Question/Abstract:

How to iterate over the MDI child array

Answer:

The documentation of TForm.MDIChildren[] states that the index of the first-created MDI child is 0. This is incorrect - the index of the most-recently-created MDI child is always 0, and the index of the first-created MDI child is always MDIChildCount - 1. With this in mind, you can use the following code to iterate over the MDI child array from from the first-created to the last:


procedure TForm1.IterateOverMDIChildren;
var
  i: integer;
begin
  for i := MDIChildCount - 1 downto 0 do
  begin
    {do something with MDI child here}
  end;
end;

How to hide the seconds in a TDateTimePicker

Problem/Question/Abstract:

I'm using a TDateTimePicker component to edit time values, but I don't need the seconds. Input of hours and minutes would be enough. Setting the time format in the control panel to "hh:mm" does this. But I would like to change any settings in the application to get the result.

Answer:

{ ... }
const
  date_format = 'yyyy MMM dd'; {year, short month, day format}
  L_time_format = 'HH:mm:ss'; {24-hour clock, hours, minutes and seconds}
  S_time_format = 'HH:mm'; {24-hour clock, hours, minutes}
var
  fmt: string;
begin
  fmt := L_time_format; {Was S_time_format}
  SendMessage(DateTimePickerTime.Handle, DTM_SETFORMATA, 0, Integer(fmt));
  fmt := date_format;
  SendMessage(DateTimePickerDate.Handle, DTM_SETFORMATA, 0, Integer(fmt));
end;

How to stop and delete all print jobs through code

Problem/Question/Abstract:

I can stop and delete current printing jobs from the "Printer Manager". Can I do it in my code, too? I want to stop all print jobs and delete them in my program.

Answer:

Try the PurgeJobsOnCurrentPrinter procedure given below. Not tested!

uses
  winspool, printers;

{GetCurrentPrinterHandle:
Retrieves the handle of the current printer and returns an API printer handle for the
current printer. Uses WinSpool.OpenPrinter to get a printer handle. The caller takes
ownership of the handle and must call ClosePrinter on it once the handle is no longer
needed. Failing to do that creates a serious resource leak! Raises EWin32Error if the
OpenPrinter call fails.}

function GetCurrentPrinterHandle: THandle;
const
  Defaults: TPrinterDefaults = (pDatatype: nil; pDevMode: nil; DesiredAccess:
    PRINTER_ACCESS_USE or PRINTER_ACCESS_ADMINISTER);
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, @Defaults) then
    RaiseLastWin32Error;
end;

{Kill all pending jobs on the current printer}

procedure PurgeJobsOnCurrentPrinter;
var
  hPrinter: THandle;
begin
  hPrinter := GetCurrentPrinterHandle;
  try
    if not WinSpool.SetPrinter(hPrinter, 0, nil, PRINTER_CONTROL_PURGE) then
      RaiseLastWin32Error;
  finally
    ClosePrinter(hPrinter);
  end;
end;

Italian tax payer code checksum algorithm

Problem/Question/Abstract:

In Italy tax payer code ("codice fiscale") is a 16 digits string identifying every one. The last char is a checksum to simply check if code is valid. There's a simply and rapid function that returns is it's valid.

Answer:

function IsTaxPayer(code: string): boolean;
const
  tables: array[0..1] of string =
    ('A0B1C2D3E4F5G6H7I8J9KKLLMMNNOOPPQQRRSSTTUUVVWWXXYYZZ',
    'B1A0KKPPLLC2QQD3RRE4VVOOSSF5TTG6UUH7MMI8NNJ9WWZZYYXX');
var
  i, x: integer;
begin
  result := false;
  code := uppercase(trim(code));
  if (length(code) = 16) then
  begin
    i := 0;
    for x := 1 to 15 do
      i := i + (((pos(code[x], tables[x mod 2]) - 1) and ($7FFE)) div 2);
    result := chr(65 + (i mod 26)) = code[length(code)];
  end;
end;

How to determine if an object has a particular property

Problem/Question/Abstract:

How to determine if an object has a particular property

Answer:

The first hasprop will return True if a property of name prop exists, eg. hasprop(MyLabel,'Caption') will return true while hasprop(MyEdit,'Caption') will return false. The second one will set property prop to string value s if it exists and is a string type property.

function hasprop(comp: TComponent; const prop: string): Boolean;
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  result := false;
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred(NumProps) do
    begin
      if comparetext(proplist[i]^.Name, prop) = 0 then
      begin
        result := true;
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

procedure setcomppropstring(comp: TComponent; const prop, s: string);
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred(NumProps) do
    begin
      if (comparetext(proplist[i]^.Name, prop) = 0) and
        (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then
        begin
          setStrProp(comp, proplist[i], s);
          break;
        end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

Dynamic loading and binding of DLLs

Problem/Question/Abstract:

Dynamic loading and binding of DLLs

Answer:

Sometimes you may need to load a DLL at runtime, for example

if you have a couple of different DLLs to choose between
to have a concept for optional functionality.

This small source code shows how to load the DLL with LoadLibrary and use the returned handle to access (bind) the functions that are contained:

{ function declaration }

type
  � TfncCnx = function(s: string): THandle;

var
  � cnx: TfncCnx;
begin
  { load the DLL and get the function's address }
  � h := LoadLibrary('myDll');
  if h = 0 then
  begin
    ShowMessage('DLL not available');
  end
  else
  begin
    �@cnx := GetProcAddress(h, 'myProc');
    if @cnx = nil then
    begin
      { function not found.. misspelled? }
      ShowMessage('blub');
    end
    else
    begin
      { call the function as usually }
      x := cnx('alpha');
    end;
    { unload the DLL }
    � FreeLibrary(h);
  end;
end;

How to get the text width of a TControl in pixels

Problem/Question/Abstract:

How can I find the length of a string drawn in a particular font? For instance, Edit1 has the text of 'Hello World' in Arial bold, size = 16.

Answer:

Solve 1:

You measure it using the TextWidth method of a canvas into which the font has been copied. You can usually use the forms Canvas for this kind of work since it is not used anywhere else (unless you have a handler for the OnPaint event). The typcial code would be:

canvas.font := edit1.font; {edit1.font has size etc. to measure}
aTextwidth := canvas.TextWidth(someText);

One problem with this approach is that it will fail if you do the measuring at a time the form does not have a window handle yet. I prefer to use a dynamically created canvas for this kind of task:

function CalcMaxWidthOfStrings(aList: TStrings; aFont: TFont): Integer;
var
  max, n, i: Integer;
  canvas: TCanvas;
begin
  Assert(Assigned(aList));
  Assert(Assigned(aFont));
  canvas := TCanvas.Create;
  try
    canvas.Handle := CreateDC('DISPLAY', nil, nil, nil);
    try
      Canvas.Font := aFont;
      max := 0;
      for i := 0 to aList.Count - 1 do
      begin
        n := Canvas.TextWidth(aList[i]);
        if n > max then
          max := n;
      end;
      Result := max;
    finally
      DeleteDC(canvas.Handle);
      canvas.Handle := 0;
    end;
  finally
    canvas.free;
  end;
end;


Solve 2:

function GetTextWidthInPixels(AText: string; AControl: TControl): integer;
var
  propInfo: PPropInfo;
  thisFont: TFont;
begin
  Result := 0;
  propInfo := GetPropInfo(AControl.ClassInfo, 'Font');
  if propInfo <> nil then
  begin
    thisFont := TFont(GetObjectProp(AControl, 'Font'));
    if Assigned(thisFont) then
      with TControlCanvas.Create do
      try
        Control := AControl;
        Font.Assign(thisFont);
        Result := TextWidth(AText);
      finally
        Free;
      end;
  end;
end;

Call with:

twidth := GetTextWidthInPixels(Edit1.Text, Edit1);

Draw to a metafile

Problem/Question/Abstract:

How to draw to a metafile

Answer:

unit Metaform;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    Image1: TImage;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TMetafileCanvas = class(TCanvas)
  private
    FClipboardHandle: THandle;
    FMetafileHandle: HMetafile;
    FRect: TRect;
  protected
    procedure CreateHandle; override;
    function GetMetafileHandle: HMetafile;
  public
    constructor Create;
    destructor Destroy; override;
    property Rect: TRect read FRect write FRect;
    property MetafileHandle: HMetafile read GetMetafileHandle;
  end;

constructor TMetafileCanvas.Create;
begin
  inherited Create;
  FClipboardHandle := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
end;

destructor TMetafileCanvas.Destroy;
begin
  DeleteMetafile(CloseMetafile(Handle));
  if Bool(FClipboardHandle) then
    GlobalFree(FClipboardHandle);
  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  inherited Destroy;
end;

procedure TMetafileCanvas.CreateHandle;
var
  MetafileDC: HDC;
begin
  { Create a metafile DC in memory }
  MetafileDC := CreateMetaFile(nil);
  if Bool(MetafileDC) then
  begin
    { Map the top,left corner of the displayed rectangle to the top,left of the
      device context. Leave a border of 10 logical units around the picture. }
    with FRect do
      SetWindowOrg(MetafileDC, Left - 10, Top - 10);
    { Set the extent of the picture with a border of 10 logical units.}
    with FRect do
      SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
    { Play any valid metafile contents to it. }
    if Bool(FMetafileHandle) then
    begin
      PlayMetafile(MetafileDC, FMetafileHandle);
    end;
  end;
  Handle := MetafileDC;
end;

function TMetafileCanvas.GetMetafileHandle: HMetafile;
var
  MetafilePict: PMetafilePict;
  IC: HDC;
  ExtRect: TRect;
begin
  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  FMetafileHandle := CloseMetafile(Handle);
  Handle := 0;
  { Prepair metafile for clipboard display. }
  MetafilePict := GlobalLock(FClipboardHandle);
  MetafilePict^.mm := mm_AnIsoTropic;
  IC := CreateIC('DISPLAY', nil, nil, nil);
  SetMapMode(IC, mm_HiMetric);
  ExtRect := FRect;
  DPtoLP(IC, ExtRect, 2);
  DeleteDC(IC);
  MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
  MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
  MetafilePict^.HMF := FMetafileHandle;
  GlobalUnlock(FClipboardHandle);
  { I'm giving you this handle, but please do NOT eat it. }
  Result := FClipboardHandle;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  MetafileCanvas: TMetafileCanvas;
begin
  MetafileCanvas := TMetafileCanvas.Create;
  MetafileCanvas.Rect := Rect(0, 0, 500, 500);
  MetafileCanvas.Ellipse(10, 10, 400, 400);
  Image1.Picture.Metafile.LoadFromClipboardFormat(cf_MetafilePict,
    MetafileCanvas.MetafileHandle, 0);
  MetafileCanvas.Free;
end;

end.

Paste files from Windows Explorer into your application

Problem/Question/Abstract:

I would like to be able to go to Windows Explorer, select a series of files, and then allow the user to "Paste" these files into my application. I simply need a list of the file names that were copied to the clipboard. Anyone know how to access this list?

Answer:

You can use OLE Drag & Drop, but since Explorer creates a standard CF_HDROP clipboard block you can also hack it this way:

uses
  clipbrd, shellapi;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  f: THandle;
  buffer: array[0..MAX_PATH] of Char;
  i, numFiles: Integer;
begin
  Clipboard.Open;
  try
    f := Clipboard.GetAsHandle(CF_HDROP);
    if f <> 0 then
    begin
      numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);
      memo1.Clear;
      for i := 0 to numfiles - 1 do
      begin
        buffer[0] := #0;
        DragQueryFile(f, i, buffer, sizeof(buffer));
        memo1.lines.add(buffer);
      end;
    end;
  finally
    Clipboard.close;
  end;
end;