## 2008. december 31., szerda

### Convert 8 or 16 bit color images to 32 bit

Problem/Question/Abstract:

How do I convert a 8 bit color image or a 16 bit color image to 32 bits of color? In my case, I have files with 8bit or 16bit images which I read using scanline. So I have one or two bytes determining the pixel color. What I want to do is still read one or two bytes for each pixel, for either the 8bit or the 16bit, but convert it to 32 bits on display.

I think you mean 8 or 16 bit per pixel, not 8 or 16 per sample. You must divide the 8 bit and the 16 bit. 8 bit is a indexed image (palette image). The pixel value is an index in a color table (palette). You need a pointer to this color table and get the color from this table. 16 bit is an RGB image, the pixel directly contains the color data. Unfortunately, you must determine the pixel mask. On Win9x the data can be 5 bit blue, 6 bit green, 5 bit red or 5 bit blue, 5 bit green, 5 bit red (bit 15 is unused). On WinNT or later the data can be stored in other combinations, but this is unlikely.

From a own project to convert such pixel data:

function DIB555ToBGR(Value: DWord): DWord; assembler;
asm
{blue}
mov   ecx, eax
shl   eax, 3
mov   edx, eax
and   eax, \$0000F8
shr   ecx, 2
and   ecx, \$000007
or    eax, ecx
{green}
shl   edx, 3
mov   ecx, edx
and   edx, \$00F800
or    eax, edx
shr   edx, 5
and   edx, \$000700
or    eax, edx
{red}
shl   ecx, 3
and   ecx, \$F80000
or    eax, ecx
shr   ecx, 5
and   ecx, \$070000
or    eax, ecx
end;

function DIB565ToBGR(Value: DWord): DWord; assembler;
asm
{blue}
mov   ecx, eax
shl   eax, 3
mov   edx, eax
and   eax, \$0000F8
shr   ecx, 2
and   ecx, \$000007
or    eax, ecx
{green}
shl   edx, 2
mov   ecx, edx
and   edx, \$00FC00
or    eax, edx
shr   edx, 6
and   edx, \$000300
or    eax, edx
{red}
shl   ecx, 3
and   ecx, \$F80000
or    eax, ecx
shr   ecx, 5
and   ecx, \$070000
or    eax, ecx
end;

However, I think you should simple use TBitmap.PixelFormat:

PixelFormat := pf32Bit;

This sets the bitmap to 32 Bit.

On the other side, you can directly display the 8 or 16 bit bitmap, the WinAPI convert the bitmap to the correct format.

## 2008. december 30., kedd

### Coloring Cells in a StringGrid / DBGrid

Problem/Question/Abstract:

StringGrids / DBGrids with colored cells looks very nice and you can inform the user about importent data inside the Grid.

Unfortunately you can't use the same method for coloring StringGrids and DBGrids. So first let's have a look to the StringGrid:

1. StringGrid

Use the "OnDrawCell"-event to make your StringGrids colorful! The following Code shows how to give your Grid a red background color. The second column will be colored with green background.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);

const //define your color here. Of course you
//can use default colors too.
clPaleGreen = TColor(\$CCFFCC);
clPaleRed = TColor(\$CCCCFF);

begin

//Does the cell have the focus you have to paint it with other colors
if (gdFocused in State) then
begin
StringGrid1.Canvas.Brush.Color := clBlack;
StringGrid1.Canvas.Font.Color := clWhite;
end
else //Does the cell have NOT the focus you can use
if ACol = 2 //the second Column should be
{//green, the other cells red } then
StringGrid1.Canvas.Brush.color := clPaleGreen
else
StringGrid1.canvas.brush.Color := clPaleRed;

//Now Paint the cells, but only, if the cell isn't the Title- Row/Column
//This of course depends whether you have title-Row/Columns or not.

if (ACol > 0) and (ARow > 0) then
begin
//Painting the Background
StringGrid1.canvas.fillRect(Rect);

//Painting the Text. Here you can improve the code with
// using alignment and so on.
StringGrid1.canvas.TextOut(Rect.Left, Rect.Top, StringGrid1.Cells[ACol, ARow]);
end;
end;

If you want to colorize your cells depending on values in the cells you can replace the 3 lines (if Acol = 2 ......) with something like this

if StringGrid1.Cells[ACol, ARow] = 'highlight it' then
StringGrid1.Canvas.Brush.color := clPalered
else
StringGrid1.canvas.brush.Color := clwhite;

But now lets coloring DBGrids:

2. DBGrid

It's much easier to give color to DBGrids. Here you have to use the "OnDrawColumnCell"-Event. The following example is coloring the Cells of Column "Status" when the value is not "a".
If you want to color the whole line you only have to delete the "If..." statement (see below)

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
const
clPaleGreen = TColor(\$CCFFCC);
clPaleRed = TColor(\$CCCCFF);
begin

if Column.FieldName = 'Status' then //Remove this line, if you want
//to highlight the whole line

if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a' then
if (gdFocused in State) {//does the cell have the focus? } then
dbgrid1.canvas.brush.color := clBlack //focused
else
dbgrid1.canvas.brush.color := clPaleGreen; //not focused

//Now let's paint the cell using a Default-Method:
dbgrid1.DefaultDrawColumnCell(rect, DataCol, Column, State)
end;

## 2008. december 29., hétfő

### How to draw text on the Windows taskbar

Problem/Question/Abstract:

Does anyone know how to write a text on the main taskbar in Win95 using Delphi 3.0?

This modified splash procedure that I use draws text directly on the Start button. Perhaps it helps. I normally use it to draw splash text directly on screen. To do that, use DC:= GetDC(0):

procedure TForm1.Button1Click(Sender: TObject);
var
DC: hDC;
Size: TSize;
Font: hFont;
const
DispText = 'Test';
begin
DC := GetDC(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), \$130));
ShowMessage(IntToStr(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), \$130)));
SetBkMode(DC, TRANSPARENT);
Font := CreateFont(12, 10, 0, 0, 1000, 0, 0, 0, ANSI_CHARSET, OUT_DEVICE_PRECIS,
CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, 'ARIAL');
SelectObject(DC, Font);
SetTextColor(DC, RGB(128, 128, 0));
GetTextExtentPoint(DC, PChar(DispText), Length(DispText), Size);
TextOut(DC, 0, 0, PChar(DispText), Length(DispText));
DeleteObject(Font);
ReleaseDC(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), \$130), DC);
end;

## 2008. december 28., vasárnap

### How to use a TImage as the background for a TDBGrid

Problem/Question/Abstract:

I would like to have a DBGrid on a form that contains a bitmap and have the text in the cells of the grid float on the bitmap. I've tried using SetBKMode but apparently I'm using it incorrectly. Is there a separate canvas for each cell as well as the grid itself?

Place a TImage on a form or create it off-screen and put the following (untested) code in the OnDrawColumnCell event of the grid:

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
w, h: Integer;
begin
with DBGrid1.Canvas do
begin
w := Rect.Right - Rect.Left;
h := Rect.Bottom - Rect.Top;
BitBlt(DBGrid1.Canvas.Handle, Rect.Left, Rect.Top, w, h,
Image1.Picture.Bitmap.Canvas.Handle, Rect.Left, Rect.Top, SRCCOPY);
Brush.Style := bsClear;
TextOut(Rect.left, Rect.Top, Column.Field.AsString);
end;
end;

## 2008. december 27., szombat

### Return identity id from insert_SQL

Problem/Question/Abstract:

How can i obtain the value of the identity column in a table, when inserting a record with a INSERT SQL statement.

Found the following note when surfing several sql-dba website forums:

You can use the SET NOCOUNT statement. SET NOCOUNT ON will prevent SQL Server from telling you how many rows each statement affected. SET NOCOUNT OFF will return SQL Server back to it's default setting. The variable @@ROWCOUNT will always contain the number of rows affected by the previous statement regardless of the setting of NOCOUNT

do use this statement to obtain the value of the inserted id:

whe have a table called TheTable with fields:

Field_ID (identity column)
Field001 (varchar)
Field002 (int)

Set Nocount on
Insert TheTable (Field001, Field002)
VALUES ('ABC', 1)
select IdentityInsert=@@identity
set nocount off

Example usage:

I have an order table with the primary order data, and a related table called orderdetails with the orderdetails per primary order data. The primary order table contains a key, field OrderID, of type identity-column autoincrement start at 0 and increment with 1. The table orderdetails contains the orderId as foreign key.

The visitor wants to checkout the order wich is composed. Now fire the insert sql to insert a record in the primary order table, using the script in this article to obtain the order id. With the obtained order id fire the several sql_inserts into the the order details table.

Tested with sqlserver 7, ado, d5, asp

## 2008. december 26., péntek

### Create a Menu from XML-File

Problem/Question/Abstract:

How can you build up the content of e.g. a TMainMenu from a XML-File?

Perhaps you have a program which also includes an administration part for a database, but only some users should be able to see and use this administration part. Why don't create a XML-File, which contains the menu of the program. When the program starts, it builds its menu from this XML-File. And only the people who should be able to see and use the administration part get the XML-File which contains it, all other users have a file without this part.

This way it's very hard for hackers to get into the administration part.

And when you even encrypt your XML-File, it should nearly unpossible.

But how can we do this?

A special feature of the code below: You only need to specify the Name of the procedure which then
will be attached to a OnClick handler (but all this procedures MUST be public)

function Get_Int(S: string): Integer;
begin
Result := 0;
try
Result := StrToInt(S);
except
end;
end;

var
I: Integer;
Child: IXMLNode;
begin
if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
begin
Node.Caption := Item.Attributes['CAPTION'];
if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
begin
if (Item.ChildNodes.Count - 1 < 0) then
end;
if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
Node.Checked := (Item.Attributes['CHECKED'] = '1');
end
else
Node.Caption := '-';
Node.Visible := (Item.Attributes['VISIBLE'] = '1');
if Parent <> nil then
else

for I := 0 to Item.ChildNodes.Count - 1 do
begin
Child := item.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
end;
end;

var
I: Integer;
Child: IXMLNode;
begin
XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
if not FileExists(XMLDocument.FileName) then
begin
Halt;
end;
XMLDocument.Active := True;

Screen.Cursor := crHourglass;
try
Parent := nil;

for I := 0 to Root.ChildNodes.Count - 1 do
begin
Child := Root.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
end;
finally
Screen.Cursor := crDefault;
end;
end;

This was the first step.
You also need the encapsulation of the XML-File.
( Save the code below as unit and add it to your program.
Created with Delphi6 -> New -> XML Data Binding Wizard )

{***************************************************}
{                                                   }
{ Delphi XML-Datenbindung                           }
{                                                   }
{ Erzeugt am: 27.06.2002 13:25:01                   }
{                                                   }
{***************************************************}

interface

uses xmldom, XMLDoc, XMLIntf;

type

{ Forward-Deklarationen }

IXMLENTRYType = interface;

['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
{ Zugriff auf Eigenschaften }
function Get_ENTRY: IXMLENTRYType;
{ Methoden & Eigenschaften }
end;

{ IXMLENTRYType }

IXMLENTRYType = interface(IXMLNode)
{ Zugriff auf Eigenschaften }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
{ Methoden & Eigenschaften }
property Caption: WideString read Get_CAPTION write Set_CAPTION;
property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
property ID: Integer read Get_ID write Set_ID;
end;

{ Forward-Deklarationen }

TXMLENTRYType = class;

protected
function Get_ENTRY: IXMLENTRYType;
public
procedure AfterConstruction; override;
end;

{ TXMLENTRYType }

TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
protected
{ IXMLENTRYType }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
public
procedure AfterConstruction; override;
end;

{ Globale Funktionen }

implementation

{ Globale Funktionen }

begin
end;

begin
end;

begin
end;

begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;

begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;

{ TXMLENTRYType }

procedure TXMLENTRYType.AfterConstruction;
begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;

function TXMLENTRYType.Get_CAPTION: WideString;
begin
Result := ChildNodes['CAPTION'].Text;
end;

procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
begin
ChildNodes['CAPTION'].NodeValue := Value;
end;

function TXMLENTRYType.Get_VISIBLE: Integer;
begin
Result := ChildNodes['VISIBLE'].NodeValue;
end;

procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
begin
ChildNodes['VISIBLE'].NodeValue := Value;
end;

function TXMLENTRYType.Get_ID: Integer;
begin
Result := ChildNodes['ID'].NodeValue;
end;

procedure TXMLENTRYType.Set_ID(Value: Integer);
begin
ChildNodes['ID'].NodeValue := Value;
end;

function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;

end.

Finally, I'll show you an example for the XML-File.
The Procedure Name is assigned to the ID which then will be called.

<?xml version="1.0" encoding="ISO-8859-1"?>
<ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY>
</ENTRY>

<ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar" SHORTCUT="None" CHECKED="1"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen" SHORTCUT="Strg+O" CHECKED="0"></ENTRY>
</ENTRY>

<ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll" SHORTCUT="F5" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="neue Nachricht hinzuf�gen" VISIBLE="1" ID="NewMarkedNews"         SHORTCUT="Strg+N" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht l�schen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Film hinzuf�gen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierten Film l�schen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>
</ENTRY>

<ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY>
<ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="�ber" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>

There you can the use <ENTRY ...></ENTRY>. When you write another entry before the Entry-Endtag, this will be a submenu item.

The parameters for ENTRY are:

CAPTION - this is the string which is displayed in the Menu. If this string is "Seperator", a Seperator will be insert
VISIBLE - when zero, the MenuItem will be generated but not displayed
ID - this is None for nothing or the Name of the procedure to call when the Item is clicked (BUT BE CAREFUL: THIS PROCEDURE MUST BE PUBLIC!)
SHORTCUT - None for nothing or e.g. Ctrl+X (read the Delphi-Help for 'TextToShortCut' to understand this)
CHECKED - when not zero, the MenuItem will be checked

## 2008. december 25., csütörtök

### How to track a TEdit at an OnExit event

Problem/Question/Abstract:

I'm getting a trouble with an special event inside a OnExit event. I need to know at OnExit of a TEdit Control, when the user clicks a button such as the Cancel button. The user may exit the TEdit just with a correct data or when the Cancel Button was clicked. How can I track this?

Assuming that "BlockExit" is a global variable or field of your form:

procedure TForm1.FormCreate(Sender: TObject);
begin
BlockExit := false;
end;

procedure TForm1.Edit1Exit(Sender: TObject);
begin
BlockExit := (Edit1.Text <> 'OK');
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if BlockExit then
begin
Beep;
Beep;
MessageDlg('Wrong data in Edit1', mtError, [mbOK], -1);
Edit1.SetFocus;
CanClose := false;
end
else
CanClose := true;
end;

procedure TForm1.btnCancelClick(Sender: TObject);
begin
BlockExit := false;
Close;
end;

procedure TForm1.btnOKClick(Sender: TObject);
begin
Close;
end;

## 2008. december 24., szerda

### How to determine the caret position in a TMemo

Problem/Question/Abstract:

How to determine the caret position in a TMemo

You can use the Windows API messages EM_LINEFROMCHAR and EM_LINEINDEX to determine the current line and offset within that line (starting from SelStart).

var
LineNum: longint;
CharsBeforeLine: longint;
begin
LineNum := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
CharsBeforeLine := SendMessage(Memo1.Handle, EM_LINEINDEX, LineNum, 0);
Label1.Caption := ' Line ' + IntToStr(LineNum + 1);
Label2.Caption := ' Position ' + IntToStr((Memo1.SelStart - CharsBeforeLine) + 1);
end;

## 2008. december 23., kedd

### Select first five records from table

Problem/Question/Abstract:

How to select first five records from table

I know that SQL looks like easy thing but sometimes we face some problems, try this solvation.

SELECT TOP 5 Field1, Field2, ....FROM Table1...

## 2008. december 22., hétfő

### Check if Internet Explorer is running and get the source of the page that is displayed

Problem/Question/Abstract:

I need to identify if IE is already running on the machine, and if so, read the source of the HTML being displayed

{ ... }

uses
SHDocVw, MSHtml;

{ ...}
var
ShellWindows: IShellWindows;
Browser: IWebBrowser2;
i: integer;
Doc: IHTMLDocument2;
{ ...}
{ Use ShellWindows to get the active browser window }
ShellWindows := CoShellWindows.Create;
for i := 0 to ShellWindows.Count - 1 do
begin
if Supports(ShellWindows.Item(i), IWebBrowser2, Browser) then
begin
Doc := Browser.Document as IHTMLDocument2;
Memo1.Clear;
{ ...}

## 2008. december 21., vasárnap

### Copy directory structures

Problem/Question/Abstract:

How to copy directory structures

Solve 1:

The most appropriate way would be with the SHFileOperation API call. This is a snippet of a demo I have written for this. You should be able to see the functionality.

procedure TForm1.SHFileOperationCopy(sFrom, sTo, STitle: string);
var
lpFileOp: TSHFILEOPSTRUCT;
op, flag: Integer;
begin
case rgOP.ItemIndex of
0: op := FO_COPY;
1: op := FO_DELETE;
2: op := FO_MOVE;
3: op := FO_RENAME;
end;
flag := 0;
if AllowUndo.Checked then
flag := flag or FOF_ALLOWUNDO;
if ConfirmMouse.checked then
flag := flag or FOF_CONFIRMMOUSE;
if FilesOnly.checked then
flag := flag or FOF_FILESONLY;
if NoConfirm.Checked then
flag := flag or FOF_NOCONFIRMATION;
if NoConfirmMkdir.Checked then
flag := flag or FOF_NOCONFIRMMKDIR;
if RenameColl.Checked then
flag := flag or FOF_RENAMEONCOLLISION;
if Silent.Checked then
flag := flag or FOF_SILENT;
if SimpleProgress.Checked then
flag := flag or FOF_SIMPLEPROGRESS;
with lpFileOp do
begin
Wnd := Form1.Handle;
wFunc := op;
pFrom := pChar(sFrom);
pTo := pChar(sTo);
fFlags := Flag;
hNameMappings := nil;
lpszProgressTitle := pChar(sTitle);
end;
if (SHFileOperation(lpFileOp) <> 0) then
ShowMessage('Error processing request.');
if lpFileOp.fAnyOperationsAborted then
ShowMessage('Operation Aborted');
end;

Solve 2:

Here is desired function - with recursion:

function copyfilesindir(const source, dest, mask: string; subdirs: Boolean): Boolean;
var
ts: TSearchRec;

function filewithpath(const dir, file: string): string;
begin
if (length(dir) > 0) and (copy(dir, length(dir), 1) <> '\') then
result := dir + '\' + file
else
result := dir + file;
end;

begin
result := directoryexists(dest);
if not result then
result := createdir(dest);
if not result then
exit;
if findfirst(filewithpath(source, mask), faanyfile, ts) = 0 then
repeat
if not ((ts.name = '.') or (ts.name = '..')) then
begin
if ts.Attr and fadirectory > 0 then
begin
if subdirs then
result := copyfilesindir(filewithpath(source, ts.name),
end
else
result := copyfile(pchar(filewithpath(source, ts.name)),
pchar(filewithpath(dest, ts.name)), false);
if not result then
break;
end;
until
findnext(ts) <> 0;
findclose(ts);
end;

## 2008. december 20., szombat

### How to convert UNIX time to TDateTime and vice versa

Problem/Question/Abstract:

There is a date/ time format that I'm trying to translate, but I can't find anything that could match. This example is 2000-12-20 around 22:15. Integer: 977347109, Hex: 3A412225. Anyone know how to translate it?

The value is a Unix Time, defined as seconds since 1970-01-01T00:00:00,0Z. Important is the Letter Z, you live in Sweden, in consequence you must add 1 hour for StandardDate and 2 hours for DaylightDate to the date. The infos you can get with GetTimeZoneInformation. But you must determine, which Bias (Standard or Daylight) is valid for the date (in this case -60). You can convert the date value with the function below.

The Date for 977347109 is 2000-12-20T22:18:29+01:00.

const
UnixDateDelta = 25569; { 1970-01-01T00:00:00,0 }
SecPerMin = 60;
SecPerHour = SecPerMin * 60;
SecPerDay = SecPerHour * 24;
MinDayFraction = 1 / (24 * 60);

{Convert Unix time to TDatetime}

function UnixTimeToDateTime(AUnixTime: DWord; ABias: Integer): TDateTime;
begin
Result := UnixDateDelta + (AUnixTime div SecPerDay) { Days }
+ ((AUnixTime mod SecPerDay) / SecPerDay) { Seconds }
- ABias * MinDayFraction { Bias to UTC in minutes };
end;

{Convert Unix time to String with locale settings}

function UnixTimeToStr(AUnixTime: DWord; ABias: Integer): string;
begin
Result := FormatDateTime('ddddd  hh:nn:ss', UnixTimeToDateTime(AUnixTime, ABias));
end;

{Convert TDateTime to Unix time}

function DateTimeToUnixTime(ADateTime: TDateTime; ABias: Integer): DWord;
begin
Result := Trunc((ADateTime - UnixDateDelta) * SecPerDay) + ABias * SecPerMin;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
Label1.Caption := UnixTimeToStr(977347109, -60);
end;

## 2008. december 19., péntek

### Create without worrying of destroy a component

Problem/Question/Abstract:

How can I prevent resources leak.

Make use of Interface characteristic where when the reference goes out of scope it will free itself.

type
IAutoClean = interface
['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']
end;

TAutoClean = class(TInterfacedObject, IAutoClean)
private
FObj: TObject;
public
constructor Create(AObj: TObject);
destructor Destroy; override;
end;

implementation

constructor TAutoClean.Create(AObj: TObject);
begin
FObj := AObj;
end;

destructor TAutoClean.Destroy;
begin
FreeAndNil(FObj);
inherited;
end;

Application....

procedure TForm1.Button1Click(Sender: TObject);
var
a: IAutoClean;
//must declare as local variable, so when this procedure finished, it's out of scope
o: TOpenDialog; //any component
begin
o := TOpenDialog.Create(self);
a := TAutoClean.Create(o);
if o.Execute then
ShowMessage(o.FileName);
end;

## 2008. december 18., csütörtök

### Achieve Record locking with MSSQL 7 or later

Problem/Question/Abstract:

How would you like to be able to determine if a record has been locked in MSSQL Server and not get that annoying 'Record has been changed by another User' when you finally try to post your changes? There is an easy approach (quite easy) but it has to be implemented programatically.

For every record you want to lock to this:
Create a global temporary table that is named after the table on which the record is, together with the Unique Id of the table. For example, if you have a table named customers, with a unique id field called Uid and you want to lock the record with uid=14, create the table using this query:

Create table ##Customers14 (id int null)

When you want to unlock the record just drop that table:

Drop table ##Customers14

Now lets say that another user wants to use the same record. His client program tries to create the same global temporary table, but fails with an exception, because no two global temporary tables can have the same name. Trap the exception in a try-except clause and you are home free.

TIPS.

Use this only for SQLServer 7 and above. SQL 6.5 and below have a terrible way of handling Temprorary tables that gives a lot of overhead.

You can create any kind of collumn in your temporary table, so you can have info like what time the record was locked and by what user.

Never use this approach if there is a chance someone will forget his computer open on a record for hours, and that computer is located lets say 100 miles  from the server!!!

If the connection is lost by lets say an application error, the table is automatically droped by the SQL Server.

If the computer shutsdown by a power failure, the SQL Server waits for about 15 minutes and then drops the temporary table, or if the computer logs on again  the table is droped automatically.

If you don't want to have to handle an exception you can also check for the existance of the Temporary table in the Master database.

## 2008. december 17., szerda

### How to copy multiple files into one

Problem/Question/Abstract:

Remember DOS? We can combine multiple ASCII files to one by using the copy command like: copy file1 + file2 + file3 file4 .That makes file4 to become the sum of file1, file2 and file3. Does the ShFileOperation API supports this feature or is there any other API support this?

Solve 1:

procedure TForm1.Button1Click(Sender: TObject);
var
Stream1, Stream2: TFileStream;
begin
Stream1 := TFileStream.Create('c:\file4', fmCreate or fmShareExclusive);
try
{ first file }
Stream2 := TFileStream.Create('c:\file1', fmOpenRead or fmShareDenyNone);
try
Stream1.CopyFrom(Stream2, Stream2.Size);
finally
Stream2.Free;
end;
{ next file }
Stream2 := TFileStream.Create('c:\file2', fmOpenRead or fmShareDenyNone);
try
Stream1.CopyFrom(Stream2, Stream2.Size);
finally
Stream2.Free;
end;
{ and so on }
finally
Stream1.Free;
end;
end;

Solve 2:

function AppendFiles(Files: TStrings; const DestFile: string): integer;
var
srcFS, destFS: TFileStream;
i: integer;
F: string;
begin
result := 0;
if (Files.Count > 0) and (DestFile <> '') then
begin
destFS := TFileStream.Create(DestFile, fmCreate or fmShareExclusive);
try
i := 0;
while i < Files.Count do
begin
F := Files(i);
Inc(i);
if (CompareText(F, DestFile) <> 0) and (F <> '') then
begin
srcFS := TFileStream.Create(F, fmOpenRead or fmShareDenyWrite);
try
if destFS.CopyFrom(srcFS, 0) = srcFS.Size then
Inc(result);
finally
srcFS.Free;
end;
end
else
begin
{ error }
end;
end;
finally
destFS.Free;
end;
end;
end;

## 2008. december 16., kedd

### Responding to Windows Messages

Problem/Question/Abstract:

It shows how to act on response to windows messages. Further information can be foun in the Online Help seeking  "message handling"

It is as easy as writing a method that complies with

Getting a TMessage Parameter or a specific Message Parameter (such as TWMMouse that makes it easier to get the message's parameters)
Putting the reserved word message followed by the windows message to which you want to react (such as WM_MOUSEMOVE)

Then write your method and VOILA!

Here is the code:

unit messageUnit;

interface

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

type
TForm1 = class(TForm)
private
procedure CatchMouseMove(var winMessage: TWMMouse); message wm_mousemove;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

procedure TForm1.CatchMouseMove(var winMessage: TWMMouse);
{*
WM_MOUSEMOVE
fwKeys = wParam;        // key flags
xPos = LOWORD(lParam);  // horizontal position of cursor
yPos = HIWORD(lParam);  // vertical position of cursor
*}

begin
self.Color := TColor(winmessage.XPos)
end;

{\$R *.DFM}

end.

## 2008. december 15., hétfő

### How to get the virtual series number of an audio CD

Problem/Question/Abstract:

How to get the virtual series number of an audio CD

Windows creates a "Virtual Series Number" for Audio CDs. You can use the following code to get the VSN of an audio CD:

type
TNumbBase = 1..36;

function NumbToStr(Numb: LongInt; Base: TNumbBase): string;
const
NumbDigits = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
begin
Result := EmptyStr;
while Numb > 0 do
begin
Result := NumbDigits[(Numb mod Base) + 1] + Result;
Numb := Numb div Base;
end;
if Result = EmptyStr then
Result := '0';
end;

function GetCDID(Drive: string): string;
var
Serial: DWord;
T: Cardinal;
begin
if GetVolumeInformation(PChar(Drive), nil, 0, @Serial, T, T, nil, 0) then
Result := NumbToStr(Serial, 16)
else
Result := EmptyStr;
end;

Drive should be the name of the root directory of your CD drive. Use it like

ShowMessage(GetCDID('I:\'));

or

ShowMessage(GetCDID('\\Computer2\\CDDrive\'));

Solve 2:

You have to use the API-call GetVolumeInformation. But first, you have to implement it correctly:

function GetVolumeInformation(lpRootPathName: PAnsiChar; lpVolumeNameBuffer: PAnsiChar; nVolumeNameSize: DWORD; var lpVolumeSerialNumber, lpMaximumComponentLength,
lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PAnsiChar; nFileSystemNameSize: DWORD): bool; stdcall; external kernel32 name 'GetVolumeInformationA';

function GetCDId: string;
var
root: string;
VolumeNameBuffer, FileSystemNameBuffer: PChar;
VolumeSerialNumber, FileSystemFlags, MaximumComponentLength: LongInt;

function Int2Hex(number: LongInt): string;
var
i: LongInt;
s: string;
begin
s := '';
i := 0;
while number > 0 do
begin
i := number mod 16;
case i of
0..9: s := IntToStr(i) + s;
10: s := 'A' + s;
11: s := 'B' + s;
12: s := 'C' + s;
13: s := 'D' + s;
14: s := 'E' + s;
15: s := 'F' + s;
end;
number := number - i * 16;
end;
Result := s;
end;

begin
root := 'x:\'; {where X is the drive letter of your CD drive}
VolumeNameBuffer := StrAlloc(256);
FileSystemNameBuffer := StrAlloc(256);
if GetVolumeInformation(PChar(root), VolumeNameBuffer, 255, VolumeSerialNumber,
MaximumComponentLength, FileSystemFlags, FileSystemNameBuffer, 255) then
Result := Int2Hex(VolumeSerialNumber);
else
Result := '';
end;

## 2008. december 14., vasárnap

### How to preserve the default popup menu for a component

Problem/Question/Abstract:

Is there a way to keep the default popup menus for e.g. TMemo, TEdit if there is an explicit popup menu for the parent control?

You have to trap the WM_CONTEXTMENU message on the level of the parent. Assuming the parent is the form you would add a message handler to the form:

{ ... }
private

{ ... }

and implement it like this:

var
wnd: HWND;
ctrl: TWinControl;
begin
if message.XPos > 0 then
begin
wnd := WindowFromPoint(Mouse.CursorPos);
if wnd <> handle then
begin
ctrl := FindControl(wnd);
if Assigned(ctrl) and (ctrl is TCustomEdit) then
Exit;
end;
end
else if ActiveControl is TCustomEdit then
Exit;
inherited;
end;

Doing the same if the parent with the menu is a panel or tabsheet or such is a bit more difficult, you have to subclass it via WindowProc, or make a descendent class to be able to trap the message.

## 2008. december 13., szombat

### Fill In Combo Box (Component)

Problem/Question/Abstract:

In the following article I am going to give you a simple, enhanced combo box, that fills in the text area with possible options from the items list. Simple, but useful.

Note: Delphi 6 does this by default, already

INTRODUCTION

In this article I show you how to enhance an already existing component, easily. Because of the nature of this article you should be familar with Delphi already, however, no deep knowledge is needed.

Developing a component is, thanks to Delphi, a rather simple task. You do not have to start from scratch everytime you want to enhance something, already existing. You can simple create a new class and derive it from the one you want to enhance.

GETTING STARTED

In our case we are going to enhance the TComboBox component, directly. We could choose the TCustomComboBox, however, they have different published properties from one Delphi version to another, therefore that want make much sense.

Delphi makes the simple task of creating a new component even more simple by offering a small wizard. From the Menu File | New... select the Component right from the first tab "New."

A simple wizard will show. Fill in accordingly:

Ancestor Type: TComboBox

Class Name: TFillComboBox

Palette Page: Samples (or any you want, i took "Standard")

Unit File Name: Select a folder and file to save your work

Press OK, we will install it at a later time.

The wizard will create a basic component for you, inlcuding the installation routine shown below.

procedure Register;
begin
RegisterComponents('Standard', [TFillComboBox]);
end;

This routine will be called by Delphi when you select install on your component package including this file. The first parameter of RegisterComponents names the palette page, where the components are installed, the second is an array of the components to be installed.

To our new component we add a new property, called AutomaticFillin. When set to True we will search for a item matching the user input and add the remainder to the text box, otherwise we wont.

Therefore we have to declare one private variable that will save the value of the switch. By puting a property into the published part of the class declaration we allow the Delphi developer to change its value in the Object Inspector.

private
FAutomaticFillin: Boolean;

procedure SetAutomaticFillin(const Value: Boolean);
published
property AutomaticFillin: Boolean
write SetAutomaticFillin
default True;

procedure TFillComboBox.SetAutomaticFillin(const Value: Boolean);
begin
FAutomaticFillin := Value;
end;

THE PROCESSING OF THE USER CHANGES

In order to become notified when the user changes the text field, we have to override the default message handler for the combo box.

protected

procedure ComboWndProc(
var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer
); override;

In our implementation, we check first whether the special handling is turned on. If it is turned on, we will get the current text, the user has typed, and then search for it in the items list. If we have a match, we will replace the text with the matching item and select the part added by our function.

THE CODE

If your have followed the directions from the "GETTING STARTED" section, simply replace the unit code with the following code and save your file.

unit FillComboBox;

interface

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

type
TFillComboBox = class(TComboBox)
private
FAutomaticFillin: Boolean;
procedure SetAutomaticFillin(const Value: Boolean);
protected
procedure ComboWndProc(
var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer
); override;
public
published
constructor Create(AOwner: TComponent); override;
property AutomaticFillin: Boolean
write SetAutomaticFillin
default True;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Standard', [TFillComboBox]);
end;

{ TFillComboBox }

procedure TFillComboBox.ComboWndProc(
var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer
);
var
I: Integer;
CurrentText: string;
begin
inherited ComboWndProc(Message, ComboWnd, ComboProc);
// skip processing, if turned off
if not FAutomaticFillin then
Exit;
// first check whether the backspace key was pressed, we do not fill in
// in such case!
if Message.Msg = WM_CHAR then
begin
// all characters from 32 (Space) through 127 (Upper ANSI) are matched
if TWMChar(Message).CharCode in [\$20..\$7F] then
begin
// fill in the rest of the text
// save the current text, the user has typed
CurrentText := Text;
// get the first string, matching the text partially
I := SendMessage(Handle, CB_FINDSTRING, -1, LongInt(PChar(CurrentText)));
if I >= 0 then
begin
// match found!
// load matching text, I is the position of the matching string
Text := Items.Strings[I];
// select the text beyond the text typed
SelStart := Length(CurrentText);
SelLength := Length(Text) - Length(CurrentText);
end;
end;
end;
end;

constructor TFillComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAutomaticFillin := True;
end;

procedure TFillComboBox.SetAutomaticFillin(const Value: Boolean);
begin
FAutomaticFillin := Value;
end;

end.

INSTALLING THE COMPONENT

The last step is to install the component you have just created. Go to the menu and select Component | Install Component.... Select your FillComboBox.pas in the "Unit file name" field and press "OK."

That's all. Now you can create a new application and use the component whenever you feel like.

## 2008. december 12., péntek

### Simple Animated Bit- and SpeedButtons

Problem/Question/Abstract:

How do I create buttons with animated bitmaps?

One thing that's not well-known (or maybe more accurately, not too obvious) is that the glyphs used for bit buttons are actually multi-framed bitmaps arranged horizontally from left to right. The rule is that you can have up to four frames in the bitmap, with each frame representing a particular button state. What you normally see is the first frame of the bitmap displayed on the button; this glyph represents the "up" state of the button. The other frames represent other states. Here's their layout:

Figure 1 - The arrangement of a multi-framed bitmap�����������������������

Table 1 describes what each bitmap frame represents:

Frame
Button State
Description
1
Up
This frame appears when the button is unselect. If no other frames exist in the bitmap, Delphi uses this image for all other images.
2
Disabled
This frame is typically a dimmed bitmap indicating that the button is disabled and can't be selected.
3
Down
This frame appears when a button is clicked. Frame 1 then reappears when the user releases the mouse button.
4
?
I have absolutely no idea what this particular frame is used for, and the online help doesn't offer any explanations whatsoever.

Table 1 - Description of multi-image bitmap frames and when they're used

So what's the point to all this? Armed with the information I just provided, you can create simple, two-frame animations that will show a different picture based upon the up or down state of a button. Here's sample:

(enlarged view)

The bitmap above shows a bitmap that I use for a product that I created that runs on a CD. Frame one (the leftmost bitmap) is displayed with the button is in its up position. Frame two displayes when the button is disabled, and frame three displays when the button is pressed. Notice in frame three how the logo and CD have "moved" down and to the right, and the shadow disappears. The net effect achieved here is that the logo appears to move down as the button is pressed.

So how do you construct the bitmaps? I've found that the image editor works just great. Just create a new bitmap by selecting File|New|Bitmap from the main menu. When the image properties dialog box appears on the screen, set the dimensions like so:

Give the image a height value first (Borland's standard buttons are 16-pixels high - I like mine to be more than that)
Then, set the width as 3X the height. So for instance, if you set a height of 16 pixels, your corresponding width would be 48 pixels. Pretty simple

Then all you have to do is use your imagination to create your bitmaps. Have fun!

## 2008. december 11., csütörtök

### Disable the IDE splash screen

Problem/Question/Abstract:

Disable the IDE splash screen

Start Delphi with the parameter -ns ('no splash'):

Delphi32.EXE -ns

Also works with C++ Builder.

## 2008. december 10., szerda

### Change the color of a specific subitem in a TListView

Problem/Question/Abstract:

How to change the color of a specific subitem in a TListView.

To change the color of a specific SubItem in a TListView all you have to do is to put some code in the OnCustomDrawSubItems event of the TListView. Your probably thinking of putting the OwnerDraw property of the ListView to True...
don't do this, yes I know normally it should be set to True, but in case of a TListView this is not the case...a bug somewhere in Delphi. Unlike the OnCustomDraw the OnCustomDrawSubItems event is sent no matter the state of the OwnerDraw property.

The OnCustomDrawSubItems is fired prior to drawing the SubItem on the TListView.
To alter the default drawing process at other stages (e.g. after the SubItem is drawn,... .), you must use the OnAdvancedCustomDrawSubItem event.
You can put code here to change the appeance of the SubItems, the ViewStyle of the TListView must be set to vsReport in order for this to function correctly.
Then you can use the canvas of the ListView as a drawing surface.

Let's say you want the font color of a SubItem to turn red whenever it's below is negative then put the following code in the OnCustomDrawSubItems event:

procedure TForm1.ListViewCustomDrawSubItem(
Sender: TCustomListView; Item: TListItem; SubItem: Integer;
State: TCustomDrawState; var DefaultDraw: Boolean);
begin
//Check if the value of the third column is negative,
//if so change it's font color to Red (clRed).
if SubItem = 3 then
try
if StrToInt(Item.SubItems.Strings[SubItem - 1]) < 0 then
Sender.Canvas.Font.Color := clRed;
except
on EConvertError do
next;
end;
end;

Used Parameters:

Sender : Specifies the ListView that owns the SubItems

Item  : Is the current Item being drawn

SubItem: Index of the SubItem of the ListItem (Item) in its SubItems property

State  : Indicates various attributes that affect the way the SubItem is drawn

DefaultDraw: Set it to False to prevent the ListView from adding the SubItem's text after the event handler exits.

Tested with Delphi 6 Professional on Windows 2000 Professional.

## 2008. december 9., kedd

### Create a TTreeView with a three state checkbox

Problem/Question/Abstract:

I tried many combinations of GW_STYLE with TVS_CHECKBOXES or BS_AUTO3STATE and I can't get a three state checkbox. All I have is a plain 2 state box. Any ideas?

Actually, you can have any number of checkbox states you like. The number of the images in the state image list determines the number of the states. By default, the image list has two bitmaps: checked and unchecked. But you are always able to add yours for a third (forth ...) state. The code below shows a TTreeView with checkboxes and a third state. I've tested it on D4 and it seemed to work alright. You can set the third state to the tree node by setting 3 to the StateIndex property in the form's OnCreate event or in any other suitable place:

MyTreeView1.Items[0].StateIndex := 3;

{ ... }
type
TMyTreeView = class(TTreeView)
protected
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure CreateParams(var Params: TCreateParams); override;
public
end;

{ ... }

procedure TMyTreeView.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or TVS_CHECKBOXES;
end;

procedure TMyTreeView.CNNotify(var Message: TWMNotify);
begin
with Message do
if NMHdr^.code = NM_CUSTOMDRAW then
inherited;
end;

var
XImageList: TImageList;
XImage: HIMAGELIST;
XBitMap: TBitMap;
i: integer;
begin
XImage := TreeView_GetImageList(Handle, TVSIL_STATE);
if (XImage <> 0) and (ImageList_GetImageCount(XImage) < 4) then
begin
XImageList := TImageList.Create(Self);
XBitMap := TBitMap.Create;
try
XImageList.ShareImages := true;
XImageList.Handle := XImage;
XBitMap.Width := XImageList.Width;
XBitMap.Height := XImageList.Height;
XImageList.Draw(XBitMap.Canvas, 0, 0, 2, false);
finally
XImageList.Free;
XBitMap.Free;
end;
for i := 0 to Items.Count - 1 do
if Items[i].StateIndex > 0 then
Items[i].StateIndex := Items[i].StateIndex;
end;
end;

## 2008. december 8., hétfő

### How to create a program that deletes itself after running

Problem/Question/Abstract:

I would like to run a program that finishes by deleting itself (similar to the DOS TSR programs). Is this possible?

Solve 1:

One technique is to use a batch file. It works on all versions of Windows. An example:

{ ... }
s := 'SelfDelete.bat';
s := ExtractFilePath(ParamStr(0)) + s;
assign(f, s);
rewrite(f);
writeln(f, ':f');
writeln(f, 'del "' + ParanStr(0));
writeln(f, 'if EXIST "' + ParamStr(0) + '" goto f');
writeln(f, 'del "' + s);
closefile(f);
WinExec(PChar(s), SW_HIDE)

Solve 2:

This simple method uses a Windows Registry entry, which in turn, makes Command.com to do the job for us, whenever the next Windows restart occurs. Add the following code to a procedure of your choice:

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

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

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
APath: array[0..255] of char;
begin
{Command.com does not support long paths, so convert to short}
if GetShortPathName(PChar(ParamStr(0)), APath, SizeOf(APath) - 1) <> 0 then
begin
{Work with TRegistry}
with TRegistry.Create do
try
{Set Root Key}
RootKey := HKEY_LOCAL_MACHINE;
{Open Key, creating key if it does not exist}
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\RunOnce', True) then
begin
{Add our String Value to the Key}
WriteString('MyApp', 'command.com /c del ' + APath);
{Close the Key}
CloseKey;
end;
finally
{Free TRegistry}
free;
end;
end;
end;

This example makes use of ParamStr(0) to meet the expectations that the title of this article has elicited: By pointing to the path + filename of the application that executes this procedure, the program will in fact bring about the removal of itself. Windows NT/2000 Note: Users running programs that utilize this code, must have the right to modify the HKEY_LOCAL_MACHINE section of the Windows Registry.

Solve 3:

Try this (not tested under WinXP, but works under Win95, Win98, WinNT 4.0 and Win2000):

procedure DeleteExeAndDir;
var
hModule: THandle;
szModuleName, szDirName: array[0..MAX_PATH] of Char;
hKrnl32: THandle;
pExitProcess, pDeleteFile, pFreeLibrary, pUnmapViewOfFile, pRemoveDir: pointer;
ExitCode: UINT;
var
r: integer;
begin
hModule := GetModuleHandle(nil);
GetModuleFileName(hModule, szModuleName, sizeof(szModuleName));
StrPCopy(szDirName, ExtractFileDir(szModuleName));
hKrnl32 := 'kernel32');
ExitCode := system.ExitCode;
SetCurrentDirectory(pchar(ExtractFileDir(szDirName)));
if (\$80000000 and GetVersion()) <> 0 then
{Win95, 98, Me}
asm
lea     eax, szModuleName
lea     ecx, szDirName
push    ExitCode
push    0
push    ecx
push    pExitProcess
push    eax
push    pRemoveDir
push    hModule
push    pDeleteFile
push    pFreeLibrary
ret
end
else
begin
for r := 1 to 100 do
begin
CloseHandle(r shl 2);
end;
{CloseHandle(THANDLE(4));}
asm
lea     eax, szModuleName
lea     ecx, szDirName
push    ExitCode
push    0
push    ecx
push    pExitProcess
push    eax
push    pRemoveDir
push    hModule
push    pDeleteFile
push    pUnmapViewOfFile
ret
end
end;
end;

Solve 4:

program delself;

uses
windows;

procedure DeleteSelf;
var
module: HMODULE;
buf: array[0..MAX_PATH - 1] of char;
p: ULONG;
hKrnl32: HMODULE;
pExitProcess, pDeleteFile, pFreeLibrary: pointer;
begin
module := GetModuleHandle(nil);
GetModuleFileName(module, buf, sizeof(buf));
CloseHandle(THandle(4));
p := ULONG(module) + 1;
hKrnl32 := GetModuleHandle('kernel32');
asm
lea eax, buf
push 0
push 0
push eax
push pExitProcess
push p
push pDeleteFile
push pFreeLibrary
ret
end;
end;

begin
DeleteSelf;
end.

## 2008. december 7., vasárnap

### How to connect a TRadioGroup to a TCheckListBox

Problem/Question/Abstract:

I have a form that contains a radio groupbox with 4 items associated with it and a checklistbox with 4 items as well. In this case the radio box dictates which items in a checklistbox can be selected. For example, if the radio groupbox is set to item 3, that means only the first 3 items in the checklistbox can be selected. Therefore, if the user changes the radiobox setting to the second item, only the first 2 selections in the checklistbox are allowed to be marked and the third item that was previously checked should be cleared.

var
I: Integer;
begin
with CheckListBoxSender do
for i := 1 to 3 do { no need to do 0}
checked[i] := false;
end;

## 2008. december 6., szombat

### How to save items of a TComboBox to an ini file

Problem/Question/Abstract:

How to save items of a TComboBox to an ini file

This is one possibility. It will put the items in a seperate section:

procedure TForm1.WriteComboToIni;
var
IniFile: TIniFile;
Cnt: integer;
begin
IniFile := TIniFile.Create('c:\test.ini');
try
with ComboBox1 do
if Items.Count > 0 then
for Cnt := 0 to Items.Count - 1 do
IniFile.WriteString('Section', 'Items' + IntToSTr(Cnt), Items[Cnt]);
finally
IniFile.Free;
end;
end;

## 2008. december 5., péntek

### Outlook Automation - Contactlist

Problem/Question/Abstract:

How use Outlook's Contact list in Applications

This is sample how look and change information in Outlook's Contactlist from external application.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
// constants from MSOUTL8.olb

olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;

olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;

olFolderDeletedItems = 3;
olFolderOutbox = 4;
olFolderSentMail = 5;
olFolderInbox = 6;
olFolderCalendar = 9;
olFolderContacts = 10;
olFolderJournal = 11;
olFolderNotes = 12;

type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
mName: TMemo;
mFamily: TMemo;
mFullName: TMemo;
mCompany: TMemo;
mSaveAs: TMemo;
mBody: TMemo;
btnSave: TButton;
sbContacts: TScrollBar;
btnConnect: TButton;
procedure btnConnectClick(Sender: TObject);
procedure mNameChange(Sender: TObject);
procedure sbContactsChange(Sender: TObject);
procedure btnSaveClick(Sender: TObject);
private
{ Private declarations }
IsDirty: boolean;
public
{ Public declarations }
OlApp, Namespace, ContactFolder: OleVariant;
procedure SaveContact(I: Integer; folder: OleVariant);
end;

var
Form1: TForm1;

implementation
uses ComObj;
{\$R *.DFM}

procedure TForm1.btnConnectClick(Sender: TObject);
begin
OlApp := CreateOleObject('Outlook.Application');
Namespace := OlApp.GetNameSpace('MAPI');
ContactFolder := Namespace.GetDefaultFolder(olFolderContacts);
sbContacts.Max := ContactFolder.Items.Count;
sbContacts.Position := 1;
end;

var
Item: OleVariant;
begin
Caption := 'Rec ' + IntToStr(i) + ' from ' + IntToStr(sbContacts.Max);
Item := folder.Items(I);
mName.Text := Item.FirstName;
mFamily.Text := Item.LastName;
mFullName.Text := Item.FullName;
mCompany.Text := Item.CompanyName;
mSaveAs.Text := Item.FileAs;
mBody.Text := Item.Body;
end;

procedure TForm1.SaveContact(I: Integer; folder: OleVariant);
var
Item: OleVariant;
begin
Item := folder.Items(I);
Item.FirstName := mName.Text;
Item.LastName := mFamily.Text;
Item.FullName := mFullName.Text;
Item.CompanyName := mCompany.Text;
Item.FileAs := mSaveAs.Text;
Item.Body := mBody.Text;
Item.Save;
isDirty := False;
end;

procedure TForm1.mNameChange(Sender: TObject);
begin
IsDirty := True;
end;

procedure TForm1.sbContactsChange(Sender: TObject);
begin
end;

procedure TForm1.btnSaveClick(Sender: TObject);
begin
SaveContact(sbContacts.Position, ContactFolder);
end;

end.

## 2008. december 3., szerda

### How to save the font settings of a control to the registry

Problem/Question/Abstract:

How can I save the font settings of a control to registry? Saving name , size, etc. as string/int doesn't seem the best way ... (as far as I remember , I can't even save all font options this way)

You can create a little component (needs not be installed on the palette) that allows you to stream a fonts properties to a stream. The stream contents could then be saved to a binary key in the registry.

{ ... }
type
TFontWrapper = class(TComponent)
private
FFont: TFont;
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure SetFont(value: TFont);
published
property Font: TFont read FFont write SetFont;
end;

{ TFontWrapper }

constructor TFontWrapper.Create(aOwner: TComponent);
begin
inherited;
FFont := TFont.Create;
end;

destructor TFontWrapper.Destroy;
begin
FFont.Free;
inherited;
end;

procedure TFontWrapper.SetFont(value: TFont);
begin
FFont.Assign(value);
end;

{ ms is a field of the form }

procedure TForm1.Button1Click(Sender: TObject);
var
helper: TFontWrapper;
begin
if not Assigned(ms) then
ms := TMemoryStream.Create
else
ms.Clear;
helper := TFontWrapper.Create(nil);
try
helper.font := label1.font;
ms.WriteComponent(helper);
finally
helper.free;
end;
label1.font.size := label1.font.size + 2;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
helper: TFontWrapper;
begin
if not Assigned(ms) then
Exit;
ms.Position := 0;
helper := TFontWrapper.Create(nil);
try
label1.font := helper.font;
finally
helper.free;
end;
end;

If reg is a TRegistry instance already with key open a

reg.WriteBinaryData(valuename, ms.Memory^, ms.Size);

would save the streamed data to the registry,

ms.size := reg.GetDatasize(valuename);

would read it back. Mind the caret!

## 2008. december 2., kedd

### Application Settings (article 1)

Problem/Question/Abstract:

Managing Application Settings

Introduction

Almost every program we write these days has a set of application settings, commonly called Program Options, that needs to be managed. Typically, the application needs to be able to save and restore these options to the registry and display them to the user for modification. Most developers simply create a unit to hold these option settings as a set of a global variables, or as a properties of a global application settings object.

The problem with this approach is that a lot of tedious code is required in order to save and load these settings. Additional code is then required to display these settings to the end user and allow the user to modify them as required. For example, you've probably written code like this many times before:

begin
cbWordWrap.Checked := Settings.WordWrap;
edFontName.Text := Settings.FontName;
end;

procedure TForm1.SaveSettings;
begin
Settings.WordWrap := cbWordWrap.Checked;
Settings.FontName := edFontName.Text;
end;

The purpose of this article is to demonstrate an alternative way to manage application settings by taking advantage of RTTI, Run Time Type Information. In part 1 of this article, we talk about creating a basic application settings object that will automatically save and load itself to and from the registry. In part 2, we will create an object dataset that enables you to connect this application settings object to data aware controls, thereby eliminating the tedious code above.

RTTI 101

The goal of part 1 is to create an application settings object that can save and load itself to and from the registry automatically. For those of you familiar with RTTI, this part may seem to be quite trivial, however for those of you new to RTTI, the very concept of RTTI can seem somewhat magical. Thus the first thing we should do is briefly cover RTTI, what it is and how it works. This will not be an in depth discussion of RTTI, but will hopefully be sufficient for the purpose of this article. Note that the best discussion of RTTI is in Ray Lischners book, Secrets of Delphi 2.

RTTI is a mechanism provided by Delphi that describes the published properties of an object. It provides a means for third party code to be able to interact with objects even though this code has no intimate knowledge of the objects. The object inspector in Delphi is a great example of RTTI in action. Have you ever wondered how the object inspector is able to display all published properties of any component even though it obviously has no intimate knowledge of the component it is displaying. The answer is RTTI. By using RTTI the object inspector is able to list all of the properties of a component and what the current values of those properties are. By again using RTTI, the object inspector is able to allow an end user, the Delphi developer in this case, to change the values of those properties as desired.

RTTI functionality is encapsulated in the VCL unit TypInfo.pas. This unit is not documented, however you can find it in your VCL/Source directory. Starting with Delphi 5, Borland added a significant number of easy access RTTI methods to TypInfo.pas in an effort to make using RTTI easier.

I have include a small RTTI utility unit called GXRTTI.pas with the code of this article. Let's take a look at one of those routines to get an idea of how we can use RTTI.

function GetPropName(Instance: TPersistent; Index: Integer): string;
var
PropList: PPropList;
PropInfo: PPropInfo;
Data: PTypeData;
begin
Result := '';
Data := GetTypeData(Instance.Classinfo);
GetMem(PropList, Data^.PropCount * Sizeof(PPropInfo));
try
GetPropInfos(Instance.ClassInfo, PropList);
PropInfo := PropList^[Index];
Result := PropInfo^.Name;
finally
FreeMem(PropList, Data^.PropCount * Sizeof(PPropInfo));
end;
end;

The function above returns a property name for a given object at a given index in the list of published properties for that object. For example, Name might be the first property of TListBox. Thus calling GetPropName(ListBox1,0) would return the string "Name".

This function works by first getting the type data for the given instance using the GetTypeData function in TypInfo.pas. Once we have the type data, we can then retrieve a list of properties for this class. Note that you must allocate memory to hold this property list as above. Once we have the list of properties in the PropList pointer, it's easy to retrieve the property name of a given property.

Creating a Base Application Settings Object

Now that we understand a bit more about RTTI, let's take a look at creating our base application settings object. The intent is that we should be able to derive a project specific settings object from the base settings object. For example we might have a base object called TGXAppSettings and for a word processor app we might create a TWordAppSettings class to hold the specific options for this project. The TWordAppSettings object descends from TAppSettings. The point of creating a base class TGXAppSettings is that the base class will contain all of the logic needed to load and save itself to and from the registry, regardless of the properties we add to descendant classes. Thus if we added a published WordWrap property to the TWordAppSettings class, the code in the base TAppSettings class will automatically save and load the new WordWrap property forcing the developer to add any new code.

Thus in a nutshell the purpose of the base object is to provide a mechanism to automatically save and load itself to the registry, regardless of what properties are added in descendant classes. So let's take a look at the type declaration of our TGXAppSettings object.

type
TGXAppSettings = class(TComponent)
private
FRegistryKey: string;
FIgnoreProperty: TStrings;
procedure SetIgnoreProperty(Value: TStrings);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SaveToRegistry; virtual;
procedure Assign(Source: TPersistent); override;
property IgnoreProperty: TStrings read FIgnoreProperty write SetIgnoreProperty;
published
property RegistryKey: string read FRegistryKey write FRegistryKey;
end;

Note that the object descends from TComponent rather then TPersistent as might be expected. I do this because I want to be able to place the project specific setting objects that will descend from TGXAppSettings on the component palette in order to drop them on a form. This feature will be used when I present the object dataset in Part 2.

As we can see above there are actually very few methods in the base TGXAppSettings object. There is a SaveToRegistry method to save the object to the registry and a LoadFromRegistry method to load it from the registry. We have also overriden the assign method in order to write code to enable us to easily copy one settings object to another.

Next two properties have been added, AutoLoad and RegistryKey. AutoLoad specifies where or not the component automatically loads itself from the registry when Delphi has loaded a form the component is sitting on. It also tells the component to save itself back to the registry automatically when it is being destroyed. The property called RegistryKey has been added to enable the developer to specify where to save and load the object in the registry.

The Constructor and Destructor have been overriden to allow us to create the IgnoreProperty stringlist. The IgnoreProperty stringlist is used to instruct the class of which properties to ignore when writing properties out to the registry. Descendant setting classes should not have to utilize this feature as it is primarily intented to prevent the AutoLoad, RegistryKey, Name and Tag properties from being written to the Registry.

Finally, the Loaded method has been overriden to give the component the chance to load itself from the registry if the AutoLoad property is set to true.

The SaveToRegistry method contains the code needed to save the object to the registry. It uses RTTI to automatically save all published properties of the object to the registry. Now you might be think what's the point of saving the published properties since this object doesn't have any published properties. While it is true that this object has no published properties, application setting objects that descend from this base class will have published properties and this method will save those properties auto-magically (to use my favourite term).

Here is the code for SaveToRegistry:

procedure TGXAppSettings.SaveToRegistry;
var
Registry: TRegistry;
Index: Integer;
PropName: string;
MStream: TMemoryStream;
begin
if RegistryKey = '' then
exit;
Registry := TRegistry.Create;
try
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey(RegistryKey, True);
for Index := 0 to GetPropCount(Self) - 1 do
begin
PropName := GetPropName(Self, Index);
if (FIgnoreProperty.Indexof(Propname) >= 0) then
Continue;
case PropType(Self, GetPropName(Self, Index)) of
tkLString, tkWString, tkString: Registry.WriteString(PropName,
GetStrProp(Self, PropName));
tkChar, tkEnumeration, tkInteger: Registry.WriteInteger(PropName,
GetOrdProp(Self, PropName));
tkInt64: Registry.WriteString(PropName, IntToStr(GetInt64Prop(Self,
PropName)));
tkFloat: Registry.WriteString(PropName, FloatToStr(GetFloatProp(Self,
PropName)));
tkClass:
begin
if (TPersistent(GetOrdProp(Self, PropName)) is TStrings) then
begin
MStream := TMemoryStream.Create;
try
TStrings(GetOrdProp(Self, PropName)).SaveToStream(MStream);
Registry.WriteBinaryData(PropName, MStream.Memory^, MStream.Size);
finally
MStream.Free;
end;
end;
end;
end;
end;
finally
Registry.Free;
end;
end;

In the code above, we first open the registry at the desired key. We then iterate through each property of the settings object and write it out to the registry. The function GetPropCount is a utility function in GXRTTI.pas that returns the number of published properties in a given object. As we go through each property, we first get the property name using the GetPropName function in GXRTTI.pas. Finally, dependant on the type of property, we write the property out to the registry using the appropriate registry function. Functions like GetStrProp and GetOrdProp retrieve the value of the given property and are contained in the unit TypeInfo.pas.

For properties based on TStrings, we retrieve a pointer to the TStrings object using GetOrdProp and write it to the registry using WriteBinaryData. A similar technique could be used for TPicture based properties if you wished to add this feature to the class.

The LoadToRegistry method is almost identical, except the reverse functionality is performed. I won't show it here, however you can see it in the downloable code at the end of this article.

Assign method

We override the assign method in order to enable us to copy one application settings object to another. This will let us create a temporary application settings object the user can edit. We need this capability so that if the user hits the cancel button, the changes the user made are thrown away with the temporary application settings object.

The assign method appears as such:

procedure TGXAppSettings.Assign(Source: TPersistent);
begin
if Source is Self.ClassType then
CloneClass(Source, Self)
else
inherited Assign(Source);
end;

This method is deceptively simple, however note the call to CloneClass. This routine is in GXRTTI.pas and it copies all published properties from one class to another by using RTTI.

An Example Project

Now that we have done all of that work, let's create an example to see how this all fits together. I've copied the code from Borland's Richedit demo and added an options dialog to the project in order to see how this works. Our rich edit settings class appears as follows:

type
TRichEditSettings = class(TGXAppSettings)
private
FWordWrap: Boolean;
FFontName: string;
FFontSize: Integer;
public
published
property FontName: string read FFontName write FFontName;
property FontSize: Integer read FFontSize write FFontSize;
property WordWrap: Boolean read FWordWrap write FWordWrap;
end;

As we see above, three properties have been added. These properties are the options for the Richedit application.

Next, I added one method called UpdateSettings. I use this method to apply the options to the actual application. In this example, the application passes the richedit control to the method that it desires to have the application settings applied to. How you apply option settings to the project will vary considerably from project to project and it is entirely up to you to decide on the best way to do this. The UpdateSettings method appears as follows:

begin
Editor.WordWrap := WordWrap;
Editor.DefAttributes.Name := FontName;
Editor.DefAttributes.Size := FontSize;
end;

Now that we have created our TRichEditSettings component, we need to integrate it into the application which as we will see, could not be any easier. The first thing we do is create a project specific package, GXRichEdit.dpk. We add the unit GXProjSt.pas which contains our TRichEditSettings class. We then compile and install the package, thereby adding the TRichEditSettings component to the component palette.

Once we have the TRichEditSettings component on the palette, we simply drop it on the main form. We set the RegistryKey property to where we want to save the settings in the registry. Next we set the FontName, FontSize and WordWrap properties to the desired default values. Here are the property values as set in the example code.

The beauty of this approach is that it leverages RAD development techniques to minimize the hassle of dealing with application settings. If at some point in the future, you need to add a new setting, simply define a new property in TRichEditSettings and recompile the package. You can then use the object inspector to set the default value of the new setting.

This concludes Part 1 of how to manage application settings, in Part 2 we will see how we can connect the RichEditSettings component to an object dataset to enable the user to quickly and easily change application settings.

Limitations

The code I have presented above has a few limitations that you should be aware of before applying it in your own projects. The major limitation is that class properties other then TStrings is not currently supported. Adding support for TPicture is relatively easy but TFont is more difficult primarly due to the limitations of the object dataset presented in Part 2.

Code

## 2008. december 1., hétfő

### Show the buffer contents of the GetLogicalDriveStrings function in a TMemo

Problem/Question/Abstract:

How to show the buffer contents of the GetLogicalDriveStrings function in a TMemo

procedure GetLogicalDrives(aList: TStrings);
var
buff: PChar;
size, i, j: DWORD;
begin
{first we get the number of bytes required}
j := GetLogicalDriveStrings(0, PChar(@j));
size := j;
Getmem(buff, size);
try
j := GetLogicalDriveStrings(size, buff);
for i := 0 to j - 1 do
if (buff[i] = #0) then
buff[i] := #13;
aList.text := buff;
finally
Freemem(buff, size);
end;
end;

## 2008. november 30., vasárnap

### How to hide the scrollbars of a MDI child form

Problem/Question/Abstract:

With Delphi 5, how can I hide the scrollbars on a MDI Form? I tried to set the properties AutoScroll, HorzScrollBar.Visible, VertScrollBar.visible to false but it had no effect.

This has no effect since the scrollbars do not belong to the MDI frame window itself, they belong to the client window, which is not a Delphi form. Which means one has to attack the problem on the API level. Since this question has come up so frequently in recent days I have modified a sample based on the stock MDI project to include this feature. The salient parts are quoted below.

Open the main forms unit in the IDE. If you don't have a handler for the OnCreate event, add one. In the handler you do this:

if ClientHandle <> 0 then
begin
if GetWindowLong(ClientHandle, GWL_USERDATA) <> 0 then
Exit; {cannot subclass client window, userdata already in use}
SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong(ClientHandle,
GWL_WNDPROC, integer(@ClientWindowProc)));
end;

Add a new standalone function to the unit, it has to go above the FormCreate method since it is referenced in the statement above:

function ClientWindowProc(wnd: HWND; msg: Cardinal; wparam, lparam: Integer): Integer;
stdcall;
var
f: Pointer;
begin
f := Pointer(GetWindowLong(wnd, GWL_USERDATA));
case msg of
WM_NCCALCSIZE:
begin
if (GetWindowLong(wnd, GWL_STYLE) and (WS_HSCROLL or WS_VSCROLL)) <> 0 then
SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE)
and not (WS_HSCROLL or WS_VSCROLL));
end;
end;
Result := CallWindowProc(f, wnd, msg, wparam, lparam);
end;

I clipped this code from a larger project, so let's hope I did not create errors in the process. What this code does is to subclass the client window the API way. It stores the old window function into the GWL_USERDATA field of the window structure since it is needed in the replacement window function, all messages need to be passed on to the old window function. There is only one message of interest in this case (the use of a Case results from the larger project, which handles more than this message): WM_NCCALCSIZE. The window gets this message when Windows tries to hide or show the scrollbars, among other cases. And it arrives *before* there is any painting of the scrollbar. So we can check if the window is going to sprout scrollbars and simply remove the scrollbar styles again.

For the purists: there is no need to undo the subclassing before the form is destroyed since the client window is destroyed before the form object.

## 2008. november 29., szombat

### Simulate a mouse click on our form (control)

Problem/Question/Abstract:

Simulate a mouse click on our form (control)

This is easily done by position the mouse cursor onto the form using SetCursorPos, then using mouse_event to fake a mouse click.

// click in upper-left corner, 50 pixels inward
SetCursorPos(Form1.Left + 50, Form1.Top + 50);
� mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
� mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);

## 2008. november 28., péntek

### Execute a file by its extension and wait to finish

Problem/Question/Abstract:

Execute/open any file with the associated application, waiting until it finish.

We will make it thanks to the function of the API ShellExecuteEx

Here the code is:

procedure TForm1.Button1Click(Sender: TObject);

procedure RunAndWaitShell(Ejecutable,
Argumentos:string
var
Info:TShellExecuteInfo;
pInfo:PShellExecuteInfo;
exitCode:DWord;
begin
{Puntero a Info}
{Pointer to Info}
pInfo:=@Info;
{Rellenamos Info}
{Fill info}
with Info do
begin
cbSize:=SizeOf(Info);
wnd:=Handle;
lpVerb:=nil;
lpFile:=PChar(Ejecutable);
{Parametros al ejecutable}
{Executable parameters}
lpParameters:=Pchar(Argumentos+#0);
lpDirectory:=nil;
hInstApp:=0;
end;
{Ejecutamos}
{Execute}
ShellExecuteEx(pInfo);

{Esperamos que termine}
{Wait to finish}
repeat
exitCode := WaitForSingleObject(Info.hProcess,500);
Application.ProcessMessages;
until (exitCode <> WAIT_TIMEOUT);
end;

begin
end;

If we call to an executable, this it will be executed.
If we call to a non executable file, the function will execute its associate application.

For example, to open a file HTML with the default browser of the system:

RunAndWaitShell('c:\kk\registro.html', '', Sw_ShowNormal);

We can also execute and wait to finish a DOS program.

For example, this opens my DOS editor QEdit to edit the Autoexec.bat:

RunAndWaitShell('c:\discoc\tools\q.exe', 'c:\autoexec.bat', Sw_ShowNormal);

## 2008. november 27., csütörtök

### How to center a TOpenDialog on a form

Problem/Question/Abstract:

How to center a TOpenDialog on a form

{ ... }
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure OpenDialog1Show(Sender: TObject);
private
{ Private declarations }
procedure MoveDialog(var Msg: TMessage); message WM_USER;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

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

procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
PostMessage(Self.Handle, WM_USER, 0, 0);
end;

procedure TForm1.MoveDialog(var Msg: TMessage);
var
rec: TRect;
wh: HWND;
l, t, r, b: Integer;
begin
wh := OpenDialog1.Handle
else
wh := Windows.GetParent(OpenDialog1.Handle);
if IsWindow(wh) then
if GetWindowRect(wh, rec) then
begin
l := (Width - (rec.Right - rec.Left)) div 2 + Left;
t := (Height - (rec.Bottom - rec.Top)) div 2 + Top;
r := rec.Right - rec.Left;
b := rec.Bottom - rec.Top;
MoveWindow(wh, l, t, r, b, True);
end;
end;

## 2008. november 26., szerda

### How to store records to a stream for later retrieval

Problem/Question/Abstract:

How to store records to a stream for later retrieval

Stores a record to stream. Record can later be retrieved with RecordFromStream procedure.

procedure RecordToStream
(DSet: TDataSet; {Dataset in question}
Stream: TStream; {Stream to store to}
PhysFieldsOnly: Boolean; {Do not store lookup and calculated fields}
FieldsNotStore: array of TField); {Additional fields that should not be stored}

function DoStoreFld(aFld: TField): Boolean;
{Checks whether the field should be stored}
var
i: Integer;
begin
Result := not PhysFieldsOnly or (aFld.FieldNo > 0);
{FieldNo of Lookup and calculated fields is <= 0}
if Result then
for i := 0 to High(FieldsNotStore) do
if aFld = FieldsNotStore[i] then
begin
Result := false;
break;
end;
end;

procedure WriteFldname(fldname: string);
var
L: longint;
begin
L := length(fldname);
Stream.Write(L, sizeOf(L));
Stream.Write(fldname[1], L);
end;

var
I, Cnt, Len: Longint;
Fld: TField;
FldBuff: Pointer;
BStream: TBlobStream;
begin
Cnt := DSet.FieldCount;
Getmem(FldBuff, 256);
try
for i := 1 to Cnt do
begin
Fld := DSet.Fields[i - 1];
if not DoStoreFld(Fld) then
Continue;
WriteFldname(Fld.Fieldname);
if Fld is TBlobField then
begin
BStream := TBlobStream.Create(Fld as TBlobField, bmRead);
try
Len := BStream.Size;
Stream.Write(len, SizeOf(Len));
Stream.CopyFrom(BStream, Len);
finally
BStream.Free;
end;
end
else
begin
Len := Fld.dataSize;
Fld.Getdata(FldBuff);
Stream.Write(Len, SizeOf(Len));
Stream.Write(FldBuff^, Len);
end;
end;
Len := 0;
{Mark the end of the stream with zero}
Stream.Write(Len, SizeOf(Len));
finally
Freemem(FldBuff, 256);
end;
end;

Reads record from the stream. The record was previously stored with RecordToStream procedure. Dset must be in edit/insert mode.

procedure RecordFromStream
(DSet: TDataSet; {Dataset in question}
Stream: TStream; {Stream to retrieve from}
FieldsToIgnore: array of TField); {Fields that should not be retrieved}

var
i: Integer;
begin
Result := (aFld <> nil) and (aFld.FieldNo > 0);
{calculated and lookup fields are allways ignored}
if Result then
for i := 0 to High(FieldsToIgnore) do
if aFld = FieldsToIgnore[i] then
begin
Result := false;
break;
end;
end;

var
L: longint;
begin
if L = 0 then
result := ''
else
begin
SetLength(Result, L);
end;
end;

var
Len: Longint;
Fld: TField;
Fldname: string;
FldBuff: Pointer;
begin
Getmem(FldBuff, 256);
try
while Fldname <> '' do
begin
if Fldname = '' then
break;
Fld := DSet.FindField(Fldname);
begin
if Fld is TBlobField then
begin
with TBlobStream.Create(Fld as TBlobField, bmWrite) do
try
CopyFrom(Stream, Len);
finally
Free;
end;
end
else
begin
if Fld.datasize <> Len then
raise Exception.CreateFmt('Field size changed: Field: %s', [Fldname]);
Fld.Setdata(FldBuff);
end;
end
else
begin
Stream.Seek(Len, soFromCurrent);
end;
end
finally
Freemem(FldBuff, 256);
end;
end;

## 2008. november 25., kedd

### How to reposition the cursor in a TEdit

Problem/Question/Abstract:

How to reposition the cursor in a TEdit

The example below uses two TEdit's:

unit Cursor;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
procedure Edit1Change(Sender: TObject);
procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
CurPos: integer;
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.Edit1Change(Sender: TObject);
begin
CurPos := Edit1.SelStart;
edit2.Text := IntToStr(CurPos);
end;

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_LEFT then
dec(CurPos);
if Key = VK_RIGHT then
inc(CurPos); {Right Arrow}
edit2.text := inttostr(CurPos);
end;

end.

## 2008. november 24., hétfő

### Sorting aTable Using DBISortTable

Problem/Question/Abstract:

How to sort aTable using DBISortTable

I'm not a masochist by nature, but having started to delve into the Borland Database Engine has made me rethink that. Well, I shouldn't be too hard on myself. Let me just say that I think Borland should come out with a manual that is specific to Delphi regarding DBI calls. The current manual is written for C/C++ programmers, so if you're not all that familiar with the syntax (or really rusty with it like I am), it's a long process in making the translation to Pascal using the examples. Actually, it really sucks! but that's beside the point. I'll add, though, that once you do learn how to pass the myriad parameters to the functions, it becomes relatively easy - I say relatively because there's a lot that can go wrong, and you'd never know it until you see the results. For example, I was passing the wrong type of parameter in the pSortOrder param. The function ran without a hitch, only to empty my table! ARRRGH!

Before I go on, I advise you to purchase the Borland Database Engine manual from Borland. I think it's only US\$15.00, and it's worth it. I will not be discussing the data types, just how to make the call. In any case, here's the code.

The DBIPROCS.INT file lists the function call as follows:

function DbiSortTable({ Sort table }
hDb: hDBIDb; { Database handle }
pszTableName: PChar; { Table name of source }
pszDriverType: PChar; { Driver type /NULL }
hSrcCur: hDBICur; { OR cursor of table to sort }
pszSortedName: PChar; { Destination table (NULL if sort to self) }
phSortedCur: phDBICur; { If non-null, return cursor on destination }
hDstCur: hDBICur; { OR cursor of destination }
iSortFields: Word; { Number of sort fields }
piFieldNum: PWord; { Array of field numbers }
pbCaseInsensitive: PBool; { Which fields should sort c-i (Opt) }
pSortOrder: pSORTOrder; { Array of Sort orders (Opt) }
ppfSortFn: ppfSORTCompFn; { Array of compare fn pntrs (Opt) }
bRemoveDups: Bool; { TRUE : Remove duplicates }
hDuplicatesCur: hDBICur; { Cursor to duplicates table (Opt) }
var lRecsSort: Longint { in/out param. - sort this number }
): DBIResult;

And here's a method that uses the call. Mind you, that this will sort only on one field because that was all I needed it to do. If you want to sort on more fields, all you have to do is increase the size of the array (the piFieldNum param) and make sure you make the right field number assignments to the array elements (see the comments in the code below). Okay, here's the code...

uses DBIProcs, DBITypes, DBIErrs {You must add these to your uses section!!!}

{====================================================================================
Sorts a table using the DBISortTable method. The trick here was setting the sort direction.
The pSortOrder is a pointer to an enumerated type. So first you have to set a var that is of that type to an appropriate value, then set a pointer's value to equal the value of the var. It's a real pain.
Note  : This sorts STANDARD driver tables only. To any type, you'd set up a PChar to hold the valid driver type and insert the pointer as a param for driver type in      the DBISortTable declaration. Also, this will sort on only ONE field. Furthermore,
the method will not sort Paradox tables to self (which this does) if the table has a primary index.
=====================================================================================}

procedure SortATable(dbName, tblName, {Database and Table Name}
sortOrd: string; {'A' = Ascending 'D' = Descending}
fldNum: Integer); {The field number to sort on}
var
msg: string;
hDb: hDBIDb;
pOptFldDesc: pFLDDesc;
pOptParams: pBYTE;
dbRes: DBIResult;
dName,
tName: PChar;
sOrd: sortOrder;
pSort: pSortOrder;
arrFlds: array[0..0] of Integer;
{This is the array of fieldnums. Note it's only one element large}
boolVal: Boolean;
pRecs: LongInt;
begin
{Initialize vars}
arrFlds[0] := fldNum; {Set the element to the field number to sort on}
boolVal := True;
New(pSort);
if (sortOrd = 'A') then
sOrd := sortASCEND
else
sOrd := sortDESCEND;
pSort^ := sOrd; {set the value of the pointer to whatever was passed}
DBIInit(nil); {initialize the database engine}

{Now, get a handle to the default database. We won't specify a path just yet }
dbRes := DBIOpenDatabase(nil, nil, dbiREADWRITE, dbiOPENSHARED, nil, 0,
@pOptFldDesc, @pOptParams, hDb);
case dbRes of
DBIERR_UNKNOWNDB: msg := 'Database specified is unknown. Check your drivers.';
DBIERR_NOCONFIGFILE: msg := 'No IDAPI.CFG file for this machine. Install BDE.';
DBIERR_DBLIMIT: msg := 'Maximum number of databases have been opened.
Close down one and retry';
end;

if (dbRes <> DBIERR_NONE) then
begin
raise Exception.Create(msg);
Exit;
end;
GetMem(tName, SizeOf(PChar) * 256);
GetMem(dName, SizeOf(PChar) * 256);
StrPCopy(tName, tblName);
StrPCopy(dName, GetAliasPath(dbName));

{Now set the directory to the specified path of the alias passed.
Why do this when we can pass the alias to DBIOpenDatabase directly?
Well, I ran across some really problems doing that, so I decided
to do it after I got the handle.}

DBISetDirectory(hDb, dName);

{Make the call to DbiSortTable, passing the appropriate parameters.
Note that about half of the parameters are nil.
That's because they're optional for simple sorts, and since they're pointers,
you can pass nils.}
try
dbRes := DbiSortTable(hDb, tName, nil, nil, nil, nil, nil, 1,
@arrFlds, @boolVal, pSort, nil, False, nil, pRecs);
case dbRes of
DBIERR_INVALIDHNDL: msg := 'Invalid database handle - alias bad';
DBIERR_INVALIDFILENAME: msg := 'Invalid file name specified';
DBIERR_UNKNOWNTBLTYPE: msg := 'The source driver type was not provided.';
DBIERR_INVALIDPARAM: msg := 'The specified number of sort fields is invalid.';
DBIERR_NOTSUPPORTED: msg := 'DBISortTable does not support sorting to self on a '  +  'Paradox table with a primary index.';
end;

if (dbRes <> DBIERR_NONE) then
raise Exception.Create(msg);
finally
{Free up all memory used.}
DbiCloseDatabase(hDb);
Dispose(pSort);
FreeMem(tName, SizeOf(PChar) * 256);
FreeMem(dName, SizeOf(PChar) * 256);
end;
end;

{===============================================================================
Gets the path of an existing alias. Will produce an error message if the alias
doesn't exist. I threw this in from the previous page.
===============================================================================}

function GetAliasPath(aliasName: string): string;
var
cfgRec: DBDesc;
dbRes: DBIResult;
tempStr: array[0..255] of char;
begin
result := '';
dbRes := DBIGetDatabaseDesc(StrPCopy(tempStr, aliasName), @cfgRec);
if dbRes = DBIERR_OBJNOTFOUND then
begin
raise Exception.create('The database alias input is not a valid BDE alias.');
end
else
result := strPas(cfgRec.szPhyName);
end;

Note: This is an OLD Delphi 1.0 method for sorting a table. If you're going to use this in your Delphi 2+ applications, make sure you use the BDE uses file instead of the DBIProcs, etc. declarations in your uses section. Furthermore, you don't need to trap the errors yourself. Instead, enclose the BDE calls in the Check function to trap errors. It's a much cleaner implemenation. Note that I could use compiler directives to make this compatible with older versions of Delphi, but time is of the essence, and this has been sitting in my home directory for quite awhile.