## 2004. december 31., péntek

### Variety of Floating point functions

Problem/Question/Abstract:

Variety of Floating point functions

// FloatDecimals

function FloatDecimals(Value, decimals: extended): extended;
var
Factor: extended;
begin
Factor := Power(10, Decimals);
Value := Value * Factor;
Value := Round(Value);
Value := Value / Factor;
Result := Value;
end;

// FloatRound ( Same as FloatDecimals but more aqurate )

function FloatRound(Value, Digits: extended): extended;
var
Factor: extended;
begin
Factor := Power(10, Digits);
Result := (Value * Factor) + 0.5;
Result := Trunc(Result) / Factor;
end;

// FloatCompare

function FloatCompare(Value1, Value2: Extended): Boolean;
begin
Result := False;
if abs(Value1 - Value2) < 0.00001 then
Result := True;
end;

// FloatLessEqual

function FloatLessEqual(Value1, Value2: extended): Boolean;
begin
Result := False;
if (abs(Value1 - Value2) < 0.00001) or (Value1 < Value2) then
Result := True;
end;

// FloatGreateEqual

function FloatGreaterEqual(Value1, Value2: extended): Boolean;
begin
Result := False;
if (abs(Value1 - Value2) < 0.00001) or (Value1 > Value2) then
Result := True;
end;

// FloatStr (Format a extended value towards a string with 2 decimals )

function FloatStr(Value: extended): string;
begin
Result := FloatToStrF(Value, ffFixed, 18, 2);
end;

// FloatStr ( Format a extended value towards a string with specified decimals )

function FloatStr(Value: extended; Digits: Byte): string;
begin
Result := FloatToStrF(Value, ffFixed, 18, Digits);
end;

## 2004. december 30., csütörtök

### Add a New Menu Item to the System Menu of an Application

Problem/Question/Abstract:

How can I add my own custom menu item to another application - one I haven't written?

This tip is something that I've wanted to do for awhile, but kept on forgetting to write the article for it. It involves adding a menu choice to the system menu of an application. For the most part, you'll never have a need to do this. But there are some things like setting a form style, or some other action that is more system oriented than application oriented that just belong in the system menu. Well, here it is folks, and as usual, it's pretty incredibly easy to implement.

If you've tried to do this before but couldn't, it's because there is no way to add a menu item with standard Delphi calls. You have to trap Windows the windows message WM_SYSCOMMAND and evaluate the wParam message element to see if your added menu item was selected. Really folks, it's not that hard, and a little digging in the API help was all I needed to do find out how to implement this in a program. Basically, what you have to do is this:

Create a new form.
Override the OnMessage event by assigning a new event handler procedure for the OnMessage event.
Create a constant that will be used as the ordinal identifier for your menu choice.
In the FormCreate, make your menu choice with the AppendMenu API call.

Here's the code to show you how to do it:

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{This declaration is of the type TMessageEvent which
is a pointer to a procedure that takes two variable
arguments of type TMsg and Boolean, respectively}

procedure WinMsgHandler(var Msg: TMsg;
var Handled: Boolean);
end;

var
Form1: TForm1;

const
MyItem = 100; {Here's the menu identifier.
It can be any WORD value}

implementation

{\$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin

{First, tell the application that its message
handler is different from the default}
Application.OnMessage := WinMsgHandler;

MF_SEPARATOR, 0, '');

{Add your menu choice. Since the Item ID is high,
using the MF_BYPOSITION constant will place
it last on the system menu}
MF_BYPOSITION, MyItem, 'My Men&u Choice');

end;

procedure TForm1.WinMsgHandler(var Msg: TMsg;
var Handled: Boolean);
begin
{if the message is a system one...}
if Msg.Message = WM_SYSCOMMAND then
if Msg.wParam = MyItem then
{Put handling code here. I've opted for
a ShowMessage for demonstration purposes}
ShowMessage('You picked my menu!!!');
end;

end.

As you can see, this is fairly straight-forward. Granted, the tip is not very complicated. However, it does open up many doors to things you can do. In anticipation of some questions you might have later, The AppendMenu command can also be used with minimized apps. For instance, if you minimize your app, the icon represents the application, not your form. Therefore in order to make the system menu with your changes visible when in minimized form you would use Application.Handle instead of Self.Handle to deal with the application's system menu.

## 2004. december 29., szerda

### Get outlookexpress directory

Problem/Question/Abstract:

Did you ever wonder how to retrieve the outlookexpress directory. Down below the answer ..

function GetOutlookExpressDir: string;
var
Reg: TRegistry;
ts, userID: string;
begin
ts := '';
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Microsoft\Outlook Express', False) then
ts := Reg.ReadString('Store Root');
if ts = '' then
begin
if Reg.OpenKey('\Identities', False) then
begin
userID := Reg.ReadString('Default User ID');
if Reg.OpenKey('\Identities\' + userID +
'\Software\Microsoft\Outlook Express\5.0', False) then
ts := Reg.ReadString('Store Root');
end;
end;
finally
if (ts <> '') then
begin
SetLength(userID, 1024);
if (ExpandEnvironmentStrings(pointer(ts), @userID[1], 1024) > 0) then
result := pchar(userID)
else
result := ts;
end;
Reg.CloseKey;
Reg.Free;
end;
end;

## 2004. december 28., kedd

### How to check for any lower case or space in a string

Problem/Question/Abstract:

How to check for any lower case or space in a string

function ContainsLowerCaseOrSpace(AString: string): boolean;
var
MySet: set of char;
Len, Counter: integer;
begin
MySet := ['a'..'z', ' '];
Len := Length(AString);
Result := Len <> 0;
Counter := 1;
while (not Result) and (Counter <= Len) do
begin
if AString[Counter] in MySet then
Result := True
else
Inc(Counter);
end;
end;

procedure AddSpaceBeforeUpperCaseCharOrNumber(var AString: string);
var
Counter: integer;
bLastIsNumber: boolean;
bLastIsUpper: boolean;
begin
Counter := Length(AString);
bLastIsUpper := False; {Assume the last character will never be an upper case}
bLastIsNumber := AString[Counter] in ['0'..'9'];
dec(Counter);
while Counter > 1 do
begin
if AString[Counter] in ['0'..'9'] then
begin
if not bLastIsNumber then
Insert(' ', AString, Counter + 1);
bLastIsNumber := True;
end
else
begin
if bLastIsNumber or bLastIsUpper then
begin
Insert(' ', AString, Counter + 1);
bLastIsNumber := False;
end;
bLastIsUpper := AString[Counter] in ['A'..'Z'];
end;
dec(Counter);
end;
end;

## 2004. december 27., hétfő

### How to create isometric maps

Problem/Question/Abstract:

I'm planning to make an isometric map based game. Now, to do this, I need to know if the user clicked on one (or more) squares, for example, a building or a creature. I cannot figure out how to do this.

Create a new project. On the form, create a TImage and align it to client. Also assign the form's OnCreate event, and the Image's OnMouseUp and OnMouseDown events. Paste this code into Unit1 and run. A 10x10 grid will be drawn. Click in it to highlight a square.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
private
public
end;

var
Form1: TForm1;

implementation

uses
Math;

{\$R *.DFM}

var
XC: Integer;
YC: Integer;
LastX: Single;
LastY: Single;

const
Scale = 20;

procedure Map(const WorldX: Single; const WorldY: Single; out DisplayX: Integer;
out DisplayY: Integer);
begin
DisplayX := Round(XC + Scale * (WorldX - WorldY) * 0.5 * Sqrt(3));
DisplayY := Round(YC + Scale * (WorldX + WorldY) * 0.5);
end;

procedure UnMap(const DisplayX: Integer; const DisplayY: Integer; out WorldX: Single;
out WorldY: Single);
var
Sum: Single;
Diff: Single;
begin
Diff := (DisplayX - XC) / (0.5 * Scale * Sqrt(3));
Sum := (DisplayY - YC) / (0.5 * Scale);
WorldY := (Sum - Diff) / 2;
WorldX := Sum - WorldY;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
X1: Integer;
Y1: Integer;
X2: Integer;
Y2: Integer;
begin
XC := ClientWidth div 2;
YC := ClientHeight div 2;
with Image1.Picture.Bitmap do
begin
Width := Image1.Width;
Height := Image1.Height;
end;
for I := -5 to 5 do
begin
Map(I, 5, X1, Y1);
Map(I, -5, X2, Y2);
with Image1.Picture.Bitmap.Canvas do
begin
MoveTo(X1, Y1);
LineTo(X2, Y2);
end;
Map(5, I, X1, Y1);
Map(-5, I, X2, Y2);
with Image1.Picture.Bitmap.Canvas do
begin
MoveTo(X1, Y1);
LineTo(X2, Y2);
end;
end;
end;

procedure ColorizeCell(const Color: TColor);
var
PolygonData: array[0..3] of TPoint;
begin
if ((Abs(LastX) < 5) and (Abs(LastY) < 5)) then
begin
Map(Floor(LastX), Floor(LastY), PolygonData[0].X, PolygonData[0].Y);
Map(Floor(LastX), Ceil(LastY), PolygonData[1].X, PolygonData[1].Y);
Map(Ceil(LastX), Ceil(LastY), PolygonData[2].X, PolygonData[2].Y);
Map(Ceil(LastX), Floor(LastY), PolygonData[3].X, PolygonData[3].Y);
with Form1.Image1.Picture.Bitmap.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := Color;
Polygon(PolygonData);
end;
end;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Unmap(X, Y, LastX, LastY);
ColorizeCell(clRed);
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ColorizeCell(clWhite);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
ColorizeCell(clWhite);
Unmap(X, Y, LastX, LastY);
ColorizeCell(clYellow);
end;

end.

## 2004. december 26., vasárnap

### How to store a text file in a resource and display the lines in a TStringGrid at runtime

Problem/Question/Abstract:

I am trying to work out how to store approximately 1000 lines of text (3 columns, 30 chars each) inside an application. I want to read the values and then display them in a TStringGrid and do some further manipulation.

If you want to read the data into a stringgrid a way to do that without building a class around the resource data would be this. You start by placing the data into a file and the file into a resource as detailed in Tip Number 1004. Loading this data into a TStringGrid would work like this:

var
rs: TResourceStream;
numElements: Integer;
datarec: TFileData;
i: Integer;
begin
rs := TResourceStream.Create(hInstance, 'FILEDATA', RT_RCDATA);
try
numElements := rs.Size div Sizeof(numElements);
grid.Perform(WM_SETREDRAW, 0, 0);
try
grid.RowCount := numElements + 1; {assuming a header row}
{following assumes grids colcount has been set correctly already}
for i := 1 to numElements do
begin
grid.Cells[grid.FixedCols, i] := datarec.col1;
grid.Cells[grid.FixedCols + 1, i] := datarec.col2;
grid.Cells[grid.FixedCols + 2, i] := datarec.col3;
end;
finally
grid.Perform(WM_SETREDRAW, 1, 0);
grid.Invalidate;
end;
finally
rs.free
end;
end;

## 2004. december 25., szombat

### How to pick from a list of TPanels in a TListBox and display the selected panel

Problem/Question/Abstract:

How to pick from a list of TPanels in a TListBox and display the selected panel

unit Unit1;

interface

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

type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure ListBox1Click(Sender: TObject);
private
{ Private declarations }
FPanelList: TList;
FActivePanel: TPanel;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

{TForm1}

constructor TForm1.Create(AOwner: TComponent);
var
i: integer;
TempPanel: TPanel;
begin
inherited;
FPanelList := TList.Create;
for i := 0 to 20 do
begin
TempPanel := TPanel.Create(self);
TempPanel.Caption := 'TPanel' + IntToStr(i);
end;
end;

destructor TForm1.Destroy;
var
i: integer;
begin
for i := FPanelList.Count - 1 downto 0 do
TPanel(FPanelList[i]).Free;
FPanelList.Free;
inherited;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
if FActivePanel <> nil then
FActivePanel.Parent := nil;
FActivePanel := FPanelList[ListBox1.ItemIndex];
FActivePanel.Parent := self;
end;

end.

## 2004. december 24., péntek

### How to play a WAV file when minimizing or maximizing a window

Problem/Question/Abstract:

How to play a WAV file when minimizing or maximizing a window

Try the API SndPlaySound. It works fine without the need of visible components. Use the OnResize event and check WindowStatus for any changes.

procedure TForm1.FormResize(Sender: TObject);
begin
case WindowStatus of
wsMinimized: sndPlaySound('min.wav', );
wsMaximized: sndPlaySound('max.wav', );
end;
end;

## 2004. december 23., csütörtök

### How to register and remove fonts at runtime

Problem/Question/Abstract:

How to register and remove fonts at runtime

The following source code will show you how to add (register) and remove fonts at runtime.

unit Unit1;

interface

uses
Windows, Sysutils, Messages, Classes, Graphics, Forms, StdCtrls, FileCtrl, Controls;

type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
FileListBox1: TFileListBox;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private Declarations }
procedure GetNewFontNames;
public
{ Public Declarations}
end;
var
Form1: TForm1;

implementation

{\$R *.DFM}
var
sFontfile: string;
result_send: Integer;
LFont: TLogFont;

procedure TForm1.FormCreate(Sender: TObject);
var
index: Integer;
begin
Form1.caption := 'Loddfont - Dossier  ' + extractfilepath(application.exename);
if FileListBox1.Items.Count = 0 then
button1.caption := 'Fermer. Pas de polices dans ce dossier !';
for index := 0 to FileListBox1.Items.Count - 1 do
begin
sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
#0;
if result_add = 0 then
begin
button1.caption := 'Fermer. Probl�me lors du chargement de ce dossier !';
end
else
begin
result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
button1.caption := 'D�charger les polices et fermer Loddfont';
end;
end;
GetNewFontNames;
messagebeep(1);
end;

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
FontType: Integer; Data: Pointer): Integer; stdcall;
var
S: TStrings;
Temp: string;
begin
S := TStrings(Data);
Temp := LogFont.lfFaceName;
if (S.Count = 0) or (AnsiCompareText(S[S.Count - 1], Temp) <> 0) then
Result := 1;
end;

procedure TForm1.GetNewFontNames;
var
DC: HDC;
begin
DC := GetDC(0);
LFont.lfCharSet := DEFAULT_CHARSET;
EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(Listbox1.Items), 0);
ReleaseDC(0, DC);
Listbox1.sorted := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
index: Integer;
begin
for index := 0 to FileListBox1.Items.Count - 1 do
begin
sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
#0;
RemoveFontResource(@sFontfile[1]);
end;
result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
form1.close;
end;

end.

## 2004. december 22., szerda

### Two colour fade effects

Problem/Question/Abstract:

Two color fade effects

With a fast SetPal procedure you can create a smooth fade. Here are a few simple but effective fade routines:

var
fadepal: array[0..15, 1..3] of byte;
i, j: Integer;

begin
for i := 0 to 15 do
for j := 63 downto 0 do
begin
for i := 0 to 15 do
setpal(colnum[i], fadepal[i, 1] * j div 63, fadepal[i, 2] * j div 63, fadepal[i, 3] * j div 63);
delay(10);
end;
end;

begin
for j := 0 to 63 do
begin
for i := 0 to 15 do
setpal(colnum[i], fadepal[i, 1] * j div 63, fadepal[i, 2] * j div 63, fadepal[i, 3] * j div 63);
delay(10);
end;
end;

Based on this you can also make interesting 'psycho-fades': instead of fading to black fade to another colour or to 2 or 4 or 16 other colors.

## 2004. december 21., kedd

### Find out if IP Address is valid

Problem/Question/Abstract:

Find out if IP Address is valid

function IsWrongIP(ip: string): boolean;
var
z, i: byte;
st: array[1..3] of byte;
const
ziff = ['0'..'9'];
begin
st[1] := 0;
st[2] := 0;
st[3] := 0;
z := 0;
Result := False;
for i := 1 to length(ip) do
if ip[i] in ziff then
else
begin
if ip[i] = '.' then
begin
inc(z);
if z < 4 then
st[z] := i
else
begin
IsWrongIP := True;
exit;
end;
end
else
begin
IsWrongIP := True;
exit;
end;
end;
if (z <> 3) or (st[1] < 2) or (st[3] = length(ip)) or (st[1] + 2 > st[2]) or
(st[2] + 2 > st[3]) or (st[1] > 4) or (st[2] > st[1] + 4) or (st[3] > st[2] + 4) then
begin
IsWrongIP := True;
exit;
end;
z := StrToInt(copy(ip, 1, st[1] - 1));
if (z > 255) or (ip[1] = '0') then
begin
IsWrongIP := True;
exit;
end;
z := StrToInt(copy(ip, st[1] + 1, st[2] - st[1] - 1));
if (z > 255) or ((z <> 0) and (ip[st[1] + 1] = '0')) then
begin
IsWrongIP := True;
exit;
end;
z := StrToInt(copy(ip, st[2] + 1, st[3] - st[2] - 1));
if (z > 255) or ((z <> 0) and (ip[st[2] + 1] = '0')) then
begin
IsWrongIP := True;
exit;
end;
z := StrToInt(copy(ip, st[3] + 1, length(ip) - st[3]));
if (z > 255) or ((z <> 0) and (ip[st[3] + 1] = '0')) then
begin
IsWrongIP := True;
exit;
end;
end;

## 2004. december 20., hétfő

### How to specify the name of a database that is in a different directory

Problem/Question/Abstract:

In an SQL select statement, how do I specify the name of a database that is in a different directory? Is there a way to parameterize the name so that a BDE alias is used to supply the directory?

You cannot parameterize the value in an SQL statement such that a BDE alias could use the value. You could programmatically change the directory specified in the BDE alias itself, though. For that, see the TSession.ModifyAlias method.

But there are other ways to do this, ways that do not involve aliases. The table reference in a local SQL statement can consist of just a table name:

SELECT *
FROM Customer

It can be a table name and filename extension:

SELECT *
FROM "Customer.db"

It can be a table name prefixed with the name of a BDE alias:

SELECT *
FROM ": DBDEMOS: Customer.db"

or it can be a table name prefixed with a specific drive and directory reference:

SELECT *
FROM "C:\Program Files\Common Files\Borland Shared\Data\Customer"

With the different parts of an SQL statement on different lines within the TQuery.SQL property, you can more easily change just one of those parts without affecting the other parts. Do this by referencing one element of the string list object that is the SQL property. For example, to change just the second line (the FROM clause):

with Query1 do
begin
Close;
SQL[1] := '"' + DatabaseStrVar + 'Customer.db"';
Open;
end;

You could then set this memory variable DatabaseStrVar to a number of different values and the same code would still work.

1. An empty string.
2. The name of an alias (including colons in the variable).
3. A valid drive/ directory reference (ending in a back-slash).

## 2004. december 19., vasárnap

### Create a standard windows shortcut file

Problem/Question/Abstract:

How can I create a standard windows shortcut file (*.lnk) from my Delphi application?

Below is an example that creates a shortcut to a DOS batch file. You need to use the procedure CreateLink();

{****************************************************************}
{*                                                              *}
{* Language:    Delphi 3.00, 32 bit                             *}
{*              All code is within this one source file.        *}
{*                                                              *}
{* Description: Used to programmically create a 'ShortCut' to a *}
{*              DOS batch file. The ShortCut when invoked will  *}
{*              run in a minimized state. Location of newly     *}
{*              created ShortCut is in the same directory as    *}
{*              the batch file.                                 *}
{*                                                              *}
{* Comments:    It is up to the programmer to insure that all   *}
{*              commands called in the batch file are valid.    *}
{*                                                              *}
{* Suggestions: Attempt running the batch file under abnormal   *}
{*              conditions to see how things go, does the DOS   *}
{*              calls hang? etc.                                *}
{*                                                              *}
{* Error Codes: 0 = Success                                     *}
{*              1 = Either to many or not enough parameters     *}
{*              2 = File passed to this util, does not exist    *}
{*              3 = Failed to created ShortCut                  *}
{****************************************************************}
uses
Windows, ShlObj, ActiveX, ComObj, SysUtils, Dialogs;

{\$R *.RES}

procedure CreateLink(Target, Args, WorkDir, ShortCutName: string);
var
IObj: IUnknown;
IPFile: IPersistFile;
TargetW: WideString;
begin
IPFile := IObj as IPersistFile;

begin
SetPath(PChar(Target));
SetArguments(PChar(Args));
SetShowCmd(SW_SHOWMINIMIZED);
SetWorkingDirectory(PChar(WorkDir));
end;
TargetW := ShortCutName;
IPFile.Save(PWChar(TargetW), False);
end;

var
a, b: string;

begin
if ParamCount = 1 then
begin
a := ParamStr(1);
if FileExists(a) then
begin
ShowMessage('A = ' + a);
b := ExtractFilename(a) + '.lnk';
ShowMessage('B = ' + b);
try
CreateLink(a, '', '', ExtractFileDir(a) + #92 + b);
except
halt(3); { Failed to create shortcut }
end;
end
else
halt(2); { File does not exist }
end
else
halt(1); { Wrong amount of arguments }
end.

## 2004. december 18., szombat

### How to determine the current record number of a dataset

Problem/Question/Abstract:

How to determine the current record number of a dataset

If the dataset is based upon a Paradox or dBASE table then the record number can be determined with a couple of calls to the BDE (as shown below). The BDE doesn't support record numbering for datasets based upon SQL tables, so if your server supports record numbering you will need to refer to its documentation.

The following function is given as part of a whole unit and takes as its parameter any component derived from TDataset (i.e. TTable, TQuery, TStoredProc) and returns the current record number (greater than zero) if it is a Paradox or dBASE table. Otherwise, the function returns zero.

For dBASE tables the record number returned is always the physical record number. So, if your dataset is a TQuery or you have a range set on your dataset then the number returned won't necessarily be relative to the dataset being viewed, rather it will be based on the record's physical position in the underlying dBASE table.

uses
DB, DBTables, DbiProcs, DbiTypes, DbiErrs;

function GetRecordNumber(Dataset: TDataset): Longint;
var
CursorProps: CurProps;
RecordProps: RECProps;
begin
{ Return 0 if dataset is not Paradox or dBASE }
Result := 0;
with Dataset do
begin
{ Is the dataset active? }
if State = dsInactive then
raise EDatabaseError.Create('Cannot perform this operation ' + 'on a closed dataset');
{ We need to make this call to grab the cursor's iSeqNums }
Check(DbiGetCursorProps(Handle, CursorProps));
{ Synchronize the BDE cursor with the Dataset's cursor }
UpdateCursorPos;
{ Fill RecordProps with the current record's properties }
Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
{ What kind of dataset are we looking at? }
case CursorProps.iSeqNums of
0: Result := RecordProps.iPhyRecNum; { dBASE }
1: Result := RecordProps.iSeqNum; { Paradox }
end;
end;
end;

end.

## 2004. december 17., péntek

### How to copy a 2D array with picture greylevels to an image

Problem/Question/Abstract:

I want to move a 2D array with picture grey-levels to an Image or BMP object without first save the array to disk? I want to display the image faster on the canvas than I do now by using canvas.pixels.

A solution (not necessarily the best but it works) is as follows:

1. Create a Bitmap (TBitmap) within the TImage

Bitmap := TBitmap.Create;
BitMap.Width := NCol;
BitMap.Height := NRow;
{...}

2. Create a logical palette (greyscale or whatever) and assign it to Bitmap.Palette

CreatePalette(MyLogPalette);
{ etc. }

3. Now draw pixels into the Bitmap canvas NOT the image canvas (which is slow...). Use the
number of colours in your logical palette to scale the intensity values.

4. Clean up. Free logical palette etc.

DeleteObject(Image.Picture.Bitmap.ReleasePalette);

## 2004. december 16., csütörtök

### How to change brightness and contrast in large bitmaps (2)

Problem/Question/Abstract:

I have a Truecolor bitmap in TBitmap. Is there any fast coding to set the brightness?

Add a fixed value and clip it to the range. I have used a LUT, which is faster for larger bitmaps. The range of Brightness is -255 (-100%) to 255 (+100%). You can use a 32 or 24 Bit calculation depending on the compiler setting ChangeBrightness24Bit.

procedure ChangeBrightness(Bitmap: TBitmap; Brightness: Integer);
var
LUT: array[Byte] of Byte;
v, i: Integer;
{\$IFDEF ChangeBrightness24Bit}
w, h, x, y: Integer;
LineSize: LongInt;
pLineStart: PByte;
{\$ENDIF}
p: PByte;
begin
{ create LUT }
for i := 0 to 255 do
begin
v := i + Brightness;
if v < 0 then
v := 0
else if v > 255 then
v := 255;
LUT[i] := v;
end;

{\$IFDEF ChangeBrightness24Bit}
{ edit bitmap }
w := Bitmap.Width;
h := Bitmap.Height - 1;
Bitmap.PixelFormat := pf24Bit;
pLineStart := PByte(Bitmap.ScanLine[h]);
{ pixel line is aligned to 32 Bit }
LineSize := ((w * 3 + 3) div 4) * 4;
w := w * 3 - 1;
for y := 0 to h do
begin
p := pLineStart;
for x := 0 to w do
begin
p^ := LUT[p^];
Inc(p);
end;
Inc(pLineStart, LineSize);
end;
{\$ELSE}
{ edit bitmap }
Bitmap.PixelFormat := pf32Bit;
p := PByte(Bitmap.ScanLine[Bitmap.Height - 1]);
for i := 0 to Bitmap.Width * Bitmap.Height - 1 do
begin
p^ := LUT[p^];
Inc(p);
p^ := LUT[p^];
Inc(p);
p^ := LUT[p^];
Inc(p, 2);
end;
{\$ENDIF}
end;

## 2004. december 15., szerda

### How to identify the paper names of the active printer

Problem/Question/Abstract:

How to identify the paper names of the active printer

procedure TFReport.GetPapernames(sl: TStrings);
type
TPaperName = array[0..63] of Char;
TPaperNameArray = array[1..High(Integer) div Sizeof(TPaperName)] of TPaperName;
PPapernameArray = ^TPaperNameArray;
var
Device, Driver, Port: array[0..255] of Char;
hDevMode: THandle;
i, numPaperformats: Integer;
pPaperFormats: PPapernameArray;
begin
Printer.GetPrinter(Device, Driver, Port, hDevmode);
numPaperformats := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
if numPaperformats > 0 then
begin
GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
try
WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, Pchar(pPaperFormats), nil);
sl.Clear;
for i := 1 to numPaperformats do
finally
FreeMem(pPaperformats);
end;
end;
end;

## 2004. december 13., hétfő

### Stream forms to and from disk

Problem/Question/Abstract:

I have a form that creates an advanced SQL string and I am trying to stream the entire form (TAdvanced) to disk in order to save the state of the form, and then be able to easily recall it later without having to decode the SQL string. However, after successfully (I think) streaming it to disk, I get the error "A component named PageControl1 already exists". I have tried all kinds of variations on this, but there always seems to be some conflict - either TAdvanced can't be assigned to TAdvanced or the current, or others. Any suggestions would be appreciated. Do I need to manually iterate through the components of the form and write each one in turn to the stream?

I would use Read/ WriteComponentResFile with code similar to:

constructor TFrmPersistent.Create(AOwner: TComponent);
begin
if FileExists('Persistent.xGS') then
begin
inherited CreateNew(AOwner);
self.Visible := false;
FormCreate(self);
end
else
inherited Create(AOwner);
end;

procedure TFrmPersistent.FormDestroy(Sender: TObject);
begin
WriteComponentResFile('Persistent.xGS', self);
end;

## 2004. december 12., vasárnap

### Make Your Own Self Extractor (sfx)

Problem/Question/Abstract:

How to create an SFX (Self Extracting Executable)

This tutorial will teach you the basics and structure of a SFX, in two parts, in theory (this file) and in practice (the project files)

STEP 1 o_o Choices [File Format]

We must take accountable what type of SFX where going to use, in this tutorial we will use the standard compression/storage standard.

Fields per Frame (File)
File Name
[Options]
Fixed String Storage (255 Byte Standard)
FAST
EASY TO UNDERSTAND
ZOMBIE READ (NO PROC)
WASTED SPACE
WASTED MEMORY
Dynamic String Storage (1 to 256 Bytes)
OPTIMAL SPACE USAGE

LESS CHANGE OF CORRUPTION
A LITTLE SLOWER
Data Size [Options]
Fixed Cardinal Storage (4 Byte Standard)
FAST
EASY TO UNDERSTAND
ZOMBIE READ (NO PROC)
WASTED SPACE
Dynamic Cardinal Read (Advanced 1 - 5 Bytes)
OPTIMAL SPACE USAGE
LESS CHANCE OF CORRUPTION
A LITTLE SLOWER
Size Check [Options]
Uncompressed Size (Cardinal)
FAST
EASY
UNSAFE
CRC 32 (Cardinal)
SAFE
GET TO LEARN CRC32
SLOW
OVERKILL

You must look well into what you need and what out of the SFX to be able to choose the proper format to build, EVEN IF PEOPLE DON'T NOTICE, DO IT RIGHT!

STEP 2 o_0 Frame Format Structure Layout

Field Type Size
File Name DString 1 - 256 Bytes
Data Size Cardinal 4 Bytes
Uncompressed Size Cardinal 4 Bytes

We will introduce you step by step to the wild world of Dynamic Variables
Simple? YES
Useless? NO

Since this format doesn't have a POSITION field, we will use the old fashioned DATA HEADER approach to the SFX. This means it will be that it is meant to DUMP the files not to LOOK UP the files.

There are ways we can CONVERT this Frame Format to use in a FAT like table, but lets keep it simple (FOR NOW)

STEP 3 0_0 SFX File Format Structure

Data Type Size
SFX ID  Char 2
Frame Count Word 2
Frame Data Raw UNKNOWN
SFX Data Size Cardinal 4

SFX ID is used to detect if the executable (image file) contains valid SFX Data
Frame Count is used to tell us how many frames to process
Frame Data is the Frame Header (Structure) + Raw/Compressed File Data
SFX Data Size is NEEDED (you will see)

STEP 4 0_! How to add data to and Image File Module (EXE)

A little known fact of the all mighty image file (EXE) is that like a GOOD file format, it is that only what is specified is needed.

By that I mean that you can add what ever you want at the end and nothing will happen, no ZIP drive bursting in flames or even worse a "BLUE SCREEN" (c) Micro\$oft 1991-2002

Now you see why I need the SFX Length at the END? yes its to go to the end of the READ-ONLY Image File (EXE) and read the Length, then look up the SFX ID to see if any SFX data is present on that Image File (EXE)

STEP 5 !_! Now to build an SFX module

Well this is an easy and important part of the process, make it as SMALL as POSSIBLE, yes kiddies

"YOU CAN PACK THE IMAGE FILE (EXE)"
TIP: UPX is great for SFX MODULES

Use less DELPHI libraries as possible, API is the way to go!
but since this is a intro tutorial we MUST make it simple.

Make a procedure to read and process the data,
in this case we can use it to READ, UNCOMPRESSED, WRITE the files.

FINAL STEP CODING!

How to read and write a Dynamic String

function ReadDString(Stream: TStream): string;
var

LEN: Byte; // Length Byte

begin

Stream.Read(LEN, 1); // Read Length (255 Max)
SetLength(Result, LEN); // Set Delphi D-String Array Size
Stream.Read(PChar(Result)^, LEN); // Read Data to D-String Array

end;

procedure WriteDString(Stream: TStream; const Str: string);
var

LEN: Byte; // Length Byte

begin

LEN := Length(Str); // Set Length Byte what Str[0] used to be
Stream.Write(LEN, 1); // Write Length Byte (255 Max)
Stream.Write(PChar(Str)^, LEN); // Write D-String Array Data

end;

COMMENT

Why the "PChar(Str)^" why not just use Str?
Well since the Str is a Delphi Dynamic-String Array (array of char), it stores its pointer, so if you attempt to use Str you are actually writing its pointer NOT the data, so what i do is I get the Pointer of the first Character on the array "PChar(Str)" then I release it as a VARIABLE or CONSTANT, as if it where a normal variable!.

Download project files for both the SFX Maker and the SFX it self
it is your job to try to understand the code, (i re-use variables allot), the main idea is this:

CREATE NEW SFX FILE
WRITE SFX MODULE (MODULE EXE)
WRITE SFX DATA

SFX DATA
WRITE ID ('SF')
WRITE FILE COUNT
WRITE FILE
WRITE LENGTH

WRITE FILE
WRITE FILENAME
WRITE COMPRESSED LENGTH
WRITE UNCOMPRESSED LENGTH
WRITE COMPRESSED FILE DATA

## 2004. december 11., szombat

### Dropping Tables from MS SQL Server with Delphi

Problem/Question/Abstract:

How do I go about dropping Tables from MS SQL Server with Delphi

I've been doing extensive work with Client/Server Delphi and MS SQL Server as my back-end database. The operational model that I use for my Client/Server is that the client application acts only as local interface, and that all queries and calculations - even temporary files - are performed or created on the server. Now this presents a couple of problems in that garbage cleanup isn't quite as easy as it is when using local tables as temporary files.

For instance, a lot of my programs create temporary files that I either reference later in the program or that I use as temporary storage for outer joins. Once I'm done with them, I need to delete them. With local tables, it's a snap. Just get a list of the tables, and with a little bit of code that uses some Windows API calls, delete them. Not so easy with SQL Server tables. The reason why is that you have to go through the BDE to accomplish the task - something that's not necessarily very intuitive. Luckily, however, it doesn't involve low-level BDE API calls.

Below is a procedure listing that drops tables from any SQL Server database. After the listing I'll discuss particulars...

Parameter Descriptions

//var Ses : TSession;         //A valid, open session
//DBName : String;            //Name of the SQL Server DB
//ArTables : array of String; //An array of table names
//StatMsg : TStatusMsg);      //A status message callback
//procedure

TStatusMsg is a procedural type used as a callback procedure

type
TStatusMsg = procedure(Msg: string);

procedure DropMSSQLTempTables(var Ses: TSession;
DBName: string;
ArTables: array of string;
StatMsg: TStatusMsg);
var
N: Integer;
qry: TQuery;
lst: TStringList;
begin
lst := TStringList.Create;

Ses.GetTableNames(DBName, '', False, False, lst);

try
for N := Low(arTables) to High(arTables) do
if (lst.IndexOf(ArTables[N]) > 0) then
begin
StatMsg('Removing ' + arTables[N] +
' from client database');
qry := TQuery.Create(nil);
with qry do
begin
Active := False;
SessionName := Ses.SessionName;
DatabaseName := DBName;
SQL.Add('DROP TABLE ' + arTables[N]);
try
ExecSQL;
finally
Free;
qry := nil;
end;
end;
end;
finally
lst.Free;
end; { try/finally }
end;

The pseudo-code for this is pretty easy.

Get a listing of all tables in the SQL Server database passed to the procedure.
Get a table name from the table name array.
If a passed table name happens to be in the list of table retrieved from the database, DROP it.
Repeat 2. and 3. until all table names have been exhausted.

The reason why I do the comparison in step 3 is because if you issue a DROP query against a non-existent table, SQL Server will issue an exception. This methodology avoids that issue entirely.

Below is a detailed description of the parameters.

Parameter Name
Type
Description
Ses
var TSession
This is a session instance variable that you pass by reference into the procedure. Note: It MUST be instantiated prior to use. The procedure does not create an instance. It assumes it already exists. This is especially necessary when using this procedure within a thread. But if you're not creating a multi- threaded application, then you can use the default Session variable.
DBName
String
Name of the MS SQL Server client database
ArTables
Array of String
This is an open array of string that you can pass into the procedure. This means that you can pass any size array and the procedure will handle it. For instance, in the Primary table maker program, I define an array as follows:

arPat[0] := 'dbo.Temp0';
arPat[1] := 'dbo.Temp1';
arPat[2] := 'dbo.Temp2';
arPat[3] := 'dbo.Temp3';
arPat[4] := 'dbo.Temp4';
arPat[5] := 'dbo.Temp5';
arPat[6] := 'dbo.PatList';
arPat[7] := 'dbo.PatientList';
arPat[8] := 'dbo.EpiList';
arPat[9] := 'dbo.' + FDisease + 'CrossTbl_' + FQtrYr;
arPat[10] := 'dbo.' + FDisease + 'Primary_' + FQtrYr;

and pass it into the procedure.
StatMsg
TStatusMsg
This is a procedural type of : procedure(Msg : String). You can&#8217;t use a class method for this procedure; instead, you declare a regular procedure that references a regular procedure. For example, I declare an interface-level procedure called StatMsg that references a thread instance variable and a method as follows:

procedure StatMsg(Msg: string);
begin
thr.FStatMsg := Msg;
end;

The trick here is that "thr" is the instance variable used to instantiate my thread class. The instance variable resides in the main form of my application. This means that it too must be declared as an interface variable.

I'm usually averse to using global variables and procedures. It's against structured programming conventions. However, what this procedure buys me is the ability to place it in a centralized library and utilize it in all my programs.

Before you use this, please make sure you review the table above. You need to declare a type of TStatusMsg prior to declaring the procedure. If you don't, you'll get a compilation error.

## 2004. december 10., péntek

### Query result into a string list

Problem/Question/Abstract:

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Let's say we have a table named 'Contact' which holds the fields 'first_name', 'last_name', 'phone', 'salutation'.
Let's say you just need to load these result once into your application, you can either keep a permanent connection to access the data or you can load it once, or whenever necessary, into memory and then free the connection.

Let's choose to load the data into memory, otherwise this article would not have any reason for existing! :)

What I show here is a very simple "trick", using a TQuery and TStringList, I show how to load each record from the TQuery's result set into a string of the TStringList.
So, let's say we need the last name and from the contact table.
You know a simple

SELECT last_name FROM contact

will do the job, all you need to do is to loop the result and add it to the string list.
But, how about if we need the salutation, last name and contact fields all at once in only one string ?  Well, the solution is also simple, for record a loop through the requeted attributes is also done!

Before I show the code to do this simple task, I'll explain how it will be achieved:

1. Receiver the database name, table name, attributes, field separator and a string list.
2. Split the attributes string into a list of strings
3. Run the database query
4. Loop in the result set
4.1. For each result set, loop the attributes
4.2. Add all attributes from the result set into the string list

And now, a possible implementation of this:

You will require these units: dbtables, stdctrls and classes.

// - One Attribute for each array position, sequentially -

procedure FillRecordSL(DBName, T, A, C, FS: string; var SL: TStringList);
var
Attrs: TStringList;
F: ShortInt;

// - Split Attributes -
procedure SplitAttributes(A: string; var Attrs: TStringList);
var
X: Integer;
S: string;
begin
if not (Assigned(Attrs)) then
Attrs := TStringList.Create;

S := '';
X := 1;
while (X <= Length(A)) do
begin
if (A[X] = ',') then
begin
S := '';
end
else
S := S + A[X];

Inc(X);
end;

end;

begin
Attrs := TStringList.Create;
SlitAttributes(A, Attrs);

with TQuery.Create(nil) do
begin
DatabaseName := DBName;
FilterOptions := [foCaseInsensitive];
SQL.Add('SELECT ' + A + ' FROM ' + T);
if Length(C) > 0 then
SQL.Add('WHERE ' + C);
Prepare;
while not (Prepared) do
;
Open;
First;
try
while not (EOF) do
begin
AuxStr := '';
for F := 0 to Attrs.Count - 1 do
AuxStr := AuxStr + FS + Fields[F].AsString;
Delete(AuxStr, 1, Length(FS));
Next;
end;
Close;
finally
Free;
end;
end;

Attrs.Free;
end;

Let's assume that your database name is MyDB and you already have a SL variable of type TStringList.
Now some examples, to access the salutation, last name and contact, all you have to do is to call the procedure this way:

FillRecordSL('MyDB', 'contact', 'salutation, last_name, contact', '', ' ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Mr. Kong 098765432'
SL[1] = 'Mrs. Chita 098765431'
SL[2] = 'Miss Tarzan 123456789'

FillRecordSL('MyDB', 'contact', 'salutation, first_name, last_name, contact',
'salutation = ''Mrs.''', '; ', SL);

Now the SL varibale helds someting like this:

SL[1] = 'Mrs.; Mila; Chita; 098765431'

FillRecordSL('MyDB', 'contact', 'last_name, first_name, contact', '', ', ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Kong, King, 098765432'
SL[1] = 'Chita, Mila, 098765431'
SL[2] = 'Tarzan, Jane, 123456789'

You can expand this procedure to increase its capabilities, what I ment to show here was just a starting point.
Hope it helps you.

## 2004. december 9., csütörtök

### Data Encryption - How It Works...

Problem/Question/Abstract:

How does Data Encryption Work

Encryptions Early Predecessors
&#8220;Since man was created, war began&#8221;

A little known fact is that even since the days of the Greeks- Encryption was a priority, people trying to stay one step ahead of there rivals, Text Messages where good as gold and a great way to communicate, but in war it is an indispensable tool but not so secure.

the &#8220;Cesar&#8221; cipher is a good example, Cesar used a very simple but effective method for protecting his messages that where sent to his army.

Normal

ABCDEFGHIJKLMNOPQRSTUVWXYZ

Coded

EFGHIJKLMNOPQRSTUVWXYZABCD

The letters where shifted left 4 spaces

A message might look like this:

MCFVNH

Meaning this:

HYBRID

Even in the early 1900&#8217;s the USA used a similar form to communicate with its troops, a BOOK a Paragraph was used as the CODEC, starting by logging the letters so they wouldn&#8217;t repeat them self&#8217;s:

For example:

&#8220;IT WAS THE BEST OF TIMES, IT WAS THE WORST OF TIMES&#8221;

The letters get logged starting from the beginning.

&#8220;IT &#8221; = &#8220;AB&#8221;

&#8220;WAS&#8221; = &#8220;CDE&#8221;

&#8220;THE&#8221; = &#8220;BFG&#8221;

Notice that the &#8216;T&#8217; got repeated so its value is still &#8216;B&#8217; and so on.

How Data Gets Encrypted
&#8220;The virtual age&#8221;

Now encryption changed thanks to computers, since the birth of the all mighty BYTE one single change and you have a whole new number.

Now a BYTE is made of 8 BITS

8-7-6-5-4-3-2-1

each BIT has a value (the double of the last) assigned to it

128-64-32-16-8-4-2-1

The max value of a BYTE is 255 (the sum of all the BITS)

Logical operators are used to modify the bits in a byte or more

OR

The OR operator is used to set the BITS in a value. example:

If you decided to OR the value: 4

(00000100)

with the value: 2

(00000010)

the result will be the number 6

(00000110)

since the sum of the 3rd BIT and the 2nd BIT gives us 6

AND

(Extract)

The AND operator is used to check if the BITS in a VALUE are set.

If you decided to AND the value: 4

(00000100)

with the value: 8

(00001000)

the result will be the number 0

(00000000)

Since the value 8 (the 4th BIT) is not set

If the BIT where set

the result will be the number 8 (AGAIN)

(00001000)

XOR

(Toggle)

The all mighty XOR operator is used to toggle the BITS in a VALUE (1=0 and 0=1)

If you decided to XOR the value: 255

(11111111)

with the value: 4

(00000100)

the result will be the number 251

(11111011)

The all the BITS in the value where toggled now if we repeat the process with the last result (251)

(11111011)

with the value: 4

(00000100)

the result will be the number 255 again

(11111111)

Now you see why the XOR is used so much, since you need not remember the original value only the KEY or in this case the 4

All values that you XOR are changed BIT by BIT so if you use a VALUE (KEY) lower than the DATA you will only change the first bytes in that value

For example an Integer (123456789) uses 4-Bytes and the value 90210 uses 2-Bytes, so if you XOR 123456789 with 90210 the changes will only affect the first 2-Bytes.

Random numbers are great but you must find a better way to generate them, since most Compilers have there own way of generating them (using the TIME is the most common) the DATA may get lost or corrupted easily.

Now the most popular is the PGP type of Encryption that I will explain later,

But first we need to explain how to generate a GOOD and SAFE key

Data Types
&#8220;One spoon or two&#8221;

The key as well as the data gets split in different data sets for example you can toggle 1 byte / 2 bytes (word) / 4 bytes (W32 Integer) / 8 bytes (int64). This way you can toggle more data and take less time. But you must always remember where your algorithm is going to be used; some systems can&#8217;t handle a 64bit Integer (some handhelds, etc). And a must is to always pair up the data size with the key size, you don&#8217;t want to encrypt text and leave readable hole.

Cipher Logic
&#8220;Lose your self in the numbers&#8221;

A KEY is always important, the time for the magical &#8220;SWORDFISH&#8221; password has ended; now you need not remember a single word but the less similar to a WORD the better.

A good KEY is longer than 128-BITS (32 BYTES/CHARS)

It is always recommended to use the full 8-BITS in each BYTE rather than just the ones used for the &#8216;Letter Characters&#8217;, the less repetitive the better.

Yes in the case of some PGP like keys they can still use the small passwords, that is because the DATA is not encrypted with the key it self instead it is Encrypted with a Session key, that key is created via any temporary data on the machine, memory, mouse position, windows version, etc.

And then the Session key is encrypted with the user key. In the case of PGP the Session key is encrypted with the Public Key.

Predetermined Keys
&#8220;Does size REALLY matter&#8221;

One of the best ways to encrypt data is to use predetermined

Keys for example the well known BLOWFISH and TWOFISH use this technique as well as many others. The USER KEY gets split in multiple sections that are used to toggle the Predetermined Keys, which in turn toggle the data in various passes.

Time and Time Again
&#8220;Shake well&#8221;

The best technique is to toggle the same part more than once, in most cases 16 times is enough. Another use for this is to shred data like most programs you can scramble the data so much that it will become unrecognizable to any data recovery program, others just zero-out the bytes, but in most cases the data on a disk can still be recovered if it was just zeroed, the Hard Disk leaves a small trace or residue of the last value there (un-format for example).

&#8220;Crouching Tiger, Hidden Footprint&#8221;

Now it is best to learn assembler for this but any language will do, since time is of the essence, I use assembler, to cover your tracks it is best to add fake procedures or moves like shifting and switching variables, in the event that a cracker might want to break the encryption. Now a days it is useless since the world revolves around keys, the cracker can have the code but not the data.

## 2004. december 8., szerda

### Ensure that every node in a TTreeView is unique (2)

Problem/Question/Abstract:

I have a 3 level TTreeview. The nodes in levels 2 and 3 must have unique captions (text). Items will be added in a loop so I can't check the "Selected" text against the data to be entered. However, I will know which node where data entry will begin. If adding child nodes to a node on level 2 for example, I assume I need to loop through the children of the particular parent node of the node on level 2 and check the text property? Does this make sense?

Yes. Use the edited nodes Parent.GetfirstChild to get a reference to the first child node of that parent. Then use that nodes GetNextSibling to find the next node on that level to examine, and so on. Untested:

function IsDuplicateNode(aNode: TTreenode): Boolean;
var
walker: TTreenode;
begin
Assert(Assigned(aNode), 'Need a node to examine!');
if Assigned(aNode.Parent) then
walker := aNode.Parent.GetFirstChild
else
walker := TTreeview(aNode.Treeview).Items[0];
Result := False;
while Assigned(walker) do
begin
if (walker <> aNode) and AnsiSametext(walker.Text, aNode.Text) then
begin
Result := true;
Break;
end;
walker := walker.GetNextSibling;
end;
end;

## 2004. december 7., kedd

### How to get the PopupPoint of a TPopupMenu

Problem/Question/Abstract:

I have a popup menu assigned to a TListView. I'm trying to get the ListItem where the right click occured. I can not get the coords where the popup click happened due to the fact that PopupMenu.PopupPoint is protected.

type
end;

var
pt: TPoint;
begin
Label1.Caption := Format('Popped up at: X = %d, Y = %d', [pt.x, pt.y]);
end;

By the way, PopupPoint returns screen coordinates.

## 2004. december 6., hétfő

### Registering a file type on Windows 9x/2000/NT

Problem/Question/Abstract:

Registering a file type on Windows 9x/2000/NT

This is typically the task of an installer like Wise or InstallShield, buy you may be in a situation where you have to do it manually.

Registering an application to handle a certain file type means putting a few entries in the registry. Just use the function from the code below.

program RegisterExt;

uses
Registry;

procedure RegisterExtension(
const sAppName: string;
const sAppPath: string;
const sIconName: string;
const sExtension: string);
var
Reg: TRegistry;
begin { RegisterExtension }
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_CLASSES_ROOT;
OpenKey('.ext', True);
WriteString('', sAppName);
CloseKey;
OpenKey(sAppName, True);
WriteString('', sAppName);
OpenKey('DefaultIcon', True);
WriteString('', sIconName);
CloseKey;
OpenKey(sAppName + '\shell\open\command', True);
WriteString('', sAppPath);
CloseKey;
Free;
end { with Reg };
end; { RegisterExtension }

begin
RegisterExtension('MyGreatApplication',
'c:\program files\mystuff\myApp.exe',
'c:\program files\mystuff\myApp.ico',
'.shl');
end.

## 2004. december 5., vasárnap

### How to create a status bar that displays the system's time, date and keyboard status

Problem/Question/Abstract:

How to create a status bar that displays the system's time, date and keyboard status

unit Status;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, Menus, Gauges;

type
TStatus = class(TCustomPanel)
private
FDate: Boolean;
FKeys: Boolean;
FTime: Boolean;
FResources: Boolean;
DateTimePanel: TPanel;
ResPanel: TPanel;
ResGauge: TGauge;
CapPanel: TPanel;
NumPanel: TPanel;
InsPanel: TPanel;
HelpPanel: TPanel;
UpdateWidth: Boolean;
FTimer: TTimer;
procedure SetDate(A: Boolean);
procedure SetKeys(A: Boolean);
procedure SetTime(A: Boolean);
procedure SetResources(A: Boolean);
procedure SetCaption(A: string);
function GetCaption: string;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetupPanelFields(ThePanel: TPanel);
procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
published
property ShowDate: Boolean read FDate write SetDate default True;
property ShowKeys: Boolean read FKeys write SetKeys default True;
property ShowTime: Boolean read FTime write SetTime default True;
property ShowResources: Boolean read FResources write SetResources default True;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderStyle;
property BorderWidth;
property Caption: string read GetCaption write SetCaption;
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentCtl3d;
property ParentFont;
property ParentShowHint;
property ShowHint;
property Visible;
end;

procedure Register;

implementation

procedure Register;
begin
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin
with ThePanel do
begin
Alignment := taCenter;
Caption := '';
BevelInner := bvLowered;
BevelOuter := bvNone;
{Set all these true so they reflect the settings of the TStatus}
ParentColor := True;
ParentFont := True;
ParentCtl3D := True;
end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
begin
SetupPanelFields(ThePanel);
with ThePanel do
begin
Align := alRight;
end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Parent := TWinControl(AOwner);
FTime := True;
FDate := True;
FKeys := True;
FResources := True;
{Force the status bar to be aligned bottom}
Align := alBottom;
Height := 19;
BevelInner := bvNone;
BevelOuter := bvRaised;
{When UpdateWidth is set TRUE, status bar will recalculate panel widths once}
UpdateWidth := True;
Locked := True;
TabOrder := 0;
;
TabStop := False;
Font.Name := 'Arial';
Font.Size := 8;
{Create the panel that will hold the date and time}
DateTimePanel := TPanel.Create(Self);
DateTimePanel.Parent := Self;
SetupPanel(DateTimePanel, '  00/00/00 00:00:00 am  ');
{Create the panel that will hold the resources graph}
ResPanel := TPanel.Create(Self);
ResPanel.Parent := Self;
SetupPanel(ResPanel, '                    ');
{Create the 2 Gauges that will reside within the Resource Panel}
ResGauge := TGauge.Create(Self);
ResGauge.Parent := ResPanel;
ResGauge.Align := alClient;
ResGauge.ParentFont := True;
ResGauge.BackColor := Color;
ResGauge.ForeColor := clLime;
ResGauge.BorderStyle := bsNone;
{Create the panel that will hold the CapsLock state}
CapPanel := TPanel.Create(Self);
CapPanel.Parent := Self;
SetupPanel(CapPanel, '  Cap  ');
{Create the panel that will hold the NumLock state}
NumPanel := TPanel.Create(Self);
NumPanel.Parent := Self;
SetupPanel(NumPanel, '  Num  ');
{Create the panel that will hold the Insert/Overwrite state}
InsPanel := TPanel.Create(Self);
InsPanel.Parent := Self;
SetupPanel(InsPanel, '  Ins  ');
{Create the panel that will hold the status text}
HelpPanel := TPanel.Create(Self);
HelpPanel.Parent := Self;
SetupPanelFields(HelpPanel);
{Have the help panel consume all remaining space}
HelpPanel.Align := alClient;
HelpPanel.Alignment := taLeftJustify;
{This is the timer that will update the status bar at regular intervals}
FTimer := TTimer.Create(Self);
if FTimer <> nil then
begin
{Updates will occur twice a second}
FTimer.Interval := 500;
FTimer.Enabled := True;
end;
end;

destructor TStatus.Destroy;
begin
FTimer.Free;
HelpPanel.Free;
InsPanel.Free;
NumPanel.Free;
CapPanel.Free;
ResGauge.Free;
ResPanel.Free;
DateTimePanel.Free;
inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin
FDate := A;
UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin
FKeys := A;
UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin
FTime := A;
UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin
FResources := A;
UpdateWidth := True;
end;

{When we set or get the TStatus caption, it is affecting the HelpPanel caption instead}

procedure TStatus.SetCaption(A: string);
begin
HelpPanel.Caption := ' ' + A;
end;

function TStatus.GetCaption: string;
begin
GetCaption := HelpPanel.Caption;
end;

{This procedure sets the captions appropriately}

begin
if ShowDate and ShowTime then
DateTimePanel.Caption := DateTimeToStr(Now)
else if ShowDate and not ShowTime then
DateTimePanel.Caption := DateToStr(Date)
else if not ShowDate and ShowTime then
DateTimePanel.Caption := TimeToStr(Time)
else
DateTimePanel.Caption := '';
if UpdateWidth then
with DateTimePanel do
if ShowDate or ShowTime then
Width := Canvas.TextWidth('  ' + Caption + '  ')
else
Width := 0;
if ShowResources then
begin
ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
if ResGauge.Progress < 20 then
ResGauge.ForeColor := clRed
else
ResGauge.ForeColor := clLime;
end;
if UpdateWidth then
if ShowResources then
ResPanel.Width := Canvas.TextWidth('                    ')
else
ResPanel.Width := 0;
if ShowKeys then
begin
if (GetKeyState(vk_NumLock) and \$01) <> 0 then
NumPanel.Caption := '  Num  '
else
NumPanel.Caption := '';
if (GetKeyState(vk_Capital) and \$01) <> 0 then
CapPanel.Caption := '  Cap  '
else
CapPanel.Caption := '';
if (GetKeyState(vk_Insert) and \$01) <> 0 then
InsPanel.Caption := '  Ins  '
else
InsPanel.Caption := '';
end;
if UpdateWidth then
if ShowKeys then
begin
NumPanel.Width := Canvas.TextWidth(' Num ');
InsPanel.Width := Canvas.TextWidth(' Ins ');
CapPanel.Width := Canvas.TextWidth(' Cap ');
end
else
begin
NumPanel.Width := 0;
InsPanel.Width := 0;
CapPanel.Width := 0;
end;
UpdateWidth := False;
end;

{This allows font changes to be detected so the panels will be adjusted}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin
inherited;
UpdateWidth := True;
end;

end.

interface

implementation

end.

## 2004. december 4., szombat

### How to transfer data between a TDBGrid and the clipboard

Problem/Question/Abstract:

How to transfer data between a TDBGrid and the clipboard

The grid must be in Edit or Insert mode for the paste to work.

Add 'ClipBrd' to the Uses list
Add 'gk: Word;' to your global variables
Add the following procedures to Implementation, substituting names as required

procedure TMyForm.MyDBGridKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
{OnKeyDown event handler for your DBGrid}
const
vk_c = \$43;
vk_v = \$56;
begin
if Shift = [ssCtrl] then
begin
if key = vk_v then
Shift := [ssShift];
if (key = vk_c) or (key = vk_v) then
begin
gk := Key;
key := 0;
end;
end;
end;

procedure TMyForm.MyDBGridKeyPress(Sender: TObject; var Key: Char);
{OnKeyPress event handler for your DBGrid}
const
vk_c = \$43;
vk_v = \$56;
begin
if gk <> 0 then
begin
Key := chr(0);
if gk = vk_c then
ClipBoard.AsText := MyTable.Fields[MyDBGrid.SelectedIndex].AsString;
if gk = vk_v then
begin
if (MyTable.State = dsEdit) or (MyTable.State = dsInsert) then
MyTable.Fields[MyDBGrid.SelectedIndex].AsString := ClipBoard.AsText
else
MessageBeep(0);
end;
gk := 0;
end;
end;

## 2004. december 3., péntek

### How to avoid palette problems with a TImage / TBitmap

Problem/Question/Abstract:

I have written an D 4.0 application that opens a jpeg, paints it to a TImage canvas, alters the TImage, and then saves the TImage back to a new jpeg file. The application works great on the development machine, however when installing it on another machine (using IS 2) it generates incorrect pictures. The jpeg are displayed correctly. When I draw to the canvas the picture is also correct. However when the image is saved to a new file the original portion of the image looks like garbage, however the portion that was added is correct. I can't find any dependencies listed that need to get distributed. Did I miss something?

First of all, the canvas of a TImage is not meant to be written on by anyone else but the image the TImage contains. Also, this sounds like a palette problem. If so, your development machine probably doesn't use palettes (16,24 or 32 bit color depth) and your test machine uses palettes (8 bit color depth). Try something like this instead (not tested):

procedure DrawBitmapOnJPEG(JPEG: TJPEGImage; BMP: TBitmap);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
{ Convert JPEG to bitmap (DIB hopefully) }
Bitmap.Assign(JPEG);
{ Avoid palette problems }
Bitmap.PixelFormat := pf24bit;
{ Draw BMP on JPEG }
Bitmap.Canvas.Draw(0, 0, BMP);
{ Convert bitmap back to JPEG }
JPEG.Assign(Bitmap);
finally
Bitmap.Free;
end;
end;

## 2004. december 2., csütörtök

### Invisible title - hide the program's title bar

Problem/Question/Abstract:

Invisible title - hide the program's title bar

This is a quick way to hide your program's title bar:

procedure TForm1.FormCreate(Sender: TObject);
var
OldStyle: longint;
begin
OldStyle := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, OldStyle and not WS_CAPTION);
ClientHeight := Height;
end;

## 2004. december 1., szerda

### Copy the current record of a dataset

Problem/Question/Abstract:

Copy the current record of a dataset

I found this routine which copies the current record of the currently selected record. This is useful e.g. to keep a temporary record for display in a form.

{************************************************
// procedure AppendCurrent
//
// Will append an exact copy of the current
// record of the dataset that is passed into
// the procedure and will return the dataset
// in edit state with the record pointer on
// the currently appended record.
************************************************}

procedure AppendCurrent(Dataset: Tdataset);
var
aField: Variant;
i: Integer;
begin
// Create a variant Array
aField := VarArrayCreate(
[0, DataSet.Fieldcount - 1],
VarVariant);
// read values into the array
for i := 0 to (DataSet.Fieldcount - 1) do
begin
aField[i] := DataSet.fields[i].Value;
end;
DataSet.Append;
// Put array values into new the record
for i := 0 to (DataSet.Fieldcount - 1) do
begin
DataSet.fields[i].Value := aField[i];
end;
end;

## 2004. november 30., kedd

Problem/Question/Abstract:

The objects I present in this article allow you to download data from any URL using the GET method, using only the standard socket components included with Delphi 4+. The object (TabHTTPRequest) is capable of connecting directly to a web server and then requesting a file, the object can also pass a query string; as of this writing it can only get a file using the GET method and using a query string. If there is sufficient interest I can expand the object to also handle POST and cookies, as well as interpreting the result so the return header can be used, so let me know what you guys think!

TInternetURI &#8211; This object takes a URI (uniform resource indicator) and splits it into it&#8217;s various components to allow the GET object to accept a URL such as http://www.borland.com/delphi/ as a parameter. You do not need to use this object directly.  This object however, follows the complete RFC standard for HTTP addresses and can be used to interpret any URL into its various components.

TabHTTPRequest &#8211; This object is designed to connect to a web server and download the HTML, which can then be used in your application.

A couple examples:

URL:

http://www.borland.com/delphi/

CODE:

with TabHTTPRequest.Create do
begin
Get('http://www.borland.com/delphi/');
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

URL:

CODE:

with TabHTTPRequest.Create do
begin
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

URL: (This is an actual search on yahoo)

CODE:

with TabHTTPRequest.Create do
begin
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

Once get has been called you can access the HTML through the ResultData property:

mmHTML.Lines.Text := URLObject.ResultData.DataString;

I hope you found this article and function to be useful; I&#8217;d love to hear your comments, suggestions, etc.

The following is the source code for the functions described above, feel free to use the code in your own programs, but please leave my name and address intact!

I also have a complete test program available by request via e-mail.

// ---------------------------ooo------------------------------ \\
// &copy;2000 David Lederman
// dlederman@ssccompany.com
// ---------------------------ooo------------------------------ \\
unit abHTTPGet;

interface

uses
Classes, Sysutils, ScktComp;

// ---------------------------ooo------------------------------ \\
// This type will crack a Uniform Resource Indicator
// ---------------------------ooo------------------------------ \\
type
TInternetURI = class(TObject)
private
function CrackScheme(var URIData: string): string;
function CrackLocation(var URIData: string): string;
function CrackQuery(var URIData: string): string;
function CrackParams(var URIData: string): string;
public
Scheme: string;
NetLocation: string;
Path: string;
Query: string;
Fragment: string;
Params: string;
constructor Create(URIData: string);
destructor Destroy; override;
end;

type
TabHTTPRequest = class
private
iBuffer: string;
Socket: TClientSocket;
public
ResultData: TStringStream;
HostToConnect: string;
PortToConnect: Integer;
FileToGet: string;
TimeOut: Integer;
function Get: Boolean; overload;
function Get(URL: string): Boolean; overload;
constructor Create;
destructor Destroy; override;
end;

// ---------------------------ooo------------------------------ \\
// Global HTTP Routines
// ---------------------------ooo------------------------------ \\
function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
MaxCount: Integer = 1): string;
function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
True; MaxCount: Integer = 1): string;

implementation

{ TabHTTPRequest }

constructor TabHTTPRequest.Create;
begin
// Simply Set Defaults
HostToConnect := 'www.InternetToolsCorp.com';
PortToConnect := 80;
FileToGet := '/';
TimeOut := 5000;
// Create the socket object
Socket := TClientSocket.Create(nil);
Socket.ClientType := ctBlocking;
// Create the result stream
ResultData := TStringStream.Create('');
end;

destructor TabHTTPRequest.Destroy;
begin
// Free the helper objects
Socket.Free;
ResultData.Free;
inherited;
end;

function TabHTTPRequest.Get: Boolean;
var
Waiter: TWinSocketStream;
BufferData: array[0..4028] of char;
BufferString: string;
begin
// Setup the Request
Waiter := nil;
iBuffer := '';
Socket.Host := HostToConnect;
Socket.Port := PortToConnect;
// Reset the data stream
ResultData.Size := 0;
try
// Do the request
// Open the connection
//  Socket.Open;
Socket.Open;
// Create the waiter
Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
// Prepare the request
BufferString := 'GET ' + FileToGet + ' HTTP/1.1' + #13#10 + 'Host: ' +
HostToConnect + #13#10 + #13#10;
// Write the Request
Waiter.Write(BufferString[1], Length(BufferString));
Waiter.Free;
Waiter := nil;
// Now process the result of the request
while Socket.Socket.Connected do
begin
try
// Create the waiter
Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
// Wait for data
if Waiter.WaitForData(TimeOut) then
begin
// Try to read a chunck of data
// Check if we got data
if DataRead = 0 then
begin
// Get out
Socket.Close;
end
else
begin
// Save the data to the stream
end;
end
else
begin
Socket.Close;
end;
finally
Waiter.Free;
Waiter := nil;
end;
end;
// close the socket
if Socket.Active then
Socket.Close;
Result := True;
// Clean up
if Waiter <> nil then
Waiter.Free;
except
// Free the waiter object
if Waiter <> nil then
Waiter.Free;
// Close the socket if it's open
if Socket.Active then
Socket.Close;
// reraise the exception
raise;
end;
end;

function TabHTTPRequest.Get(URL: string): Boolean;
begin
// Crack the URL
try
// Make sure than a scheme is in place
if Pos('://', URL) = 0 then
begin
// Simply Prepend the HTTP
URL := 'http://' + URL;
end;
// Make sure that a / is in the URL
if Pos('/', Copy(URL, 8, Length(URL))) = 0 then
begin
// Simply Append the trailing /
URL := URL + '/';
end;

with TInternetURI.Create(URL) do
begin
// Check if there is a port in the net location
if Pos(':', NetLocation) <> 0 then
begin
// Copy the host name
HostToConnect := Copy(NetLocation, 1, Pos(':', NetLocation) - 1);
// Copy the port
PortToConnect := StrToInt(Copy(NetLocation, Pos(':', NetLocation) + 1,
Length(NetLocation)));
end
else
begin
HostToConnect := NetLocation;
PortToConnect := 80;
end;
FileToGet := '';
// Set the File to get
if Query <> '' then
FileToGet := Path + '?' + Query;
if FileToGet = '' then
FileToGet := '/';
Free
end; // with
// Now simply call get
Result := Get;
except
raise;
end;
end;

{ TInternetURI }

function TInternetURI.CrackLocation(var URIData: string): string;
var
StartPos, EndPos: Integer;
begin
// Step 1. - See if the network ID is here
StartPos := Pos('//', URIData);
// If the starting // is not found then there is no network location
if StartPos = 0 then
Exit;
// Delete the first //
Delete(URIData, StartPos, 2);
// Now look for the trailing slash
EndPos := Pos('/', URIData);
if (EndPos = 0) or (EndPos = 1) then
Exit;
// Now Copy the String Upto the /
Result := Copy(URIData, 1, EndPos - 1);
// Now Delete the network location
Delete(URIData, 1, EndPos - 1);
end;

function TInternetURI.CrackParams(var URIData: string): string;
var
StartPos: Integer;
begin
// Step 1. - See if the query is here
StartPos := Pos(';', URIData);
// If the starting ; is not found then there are no params
if StartPos = 0 then
Exit;
// Copy the Params String
Result := Copy(URIData, StartPos + 1, Length(URIData));
Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackQuery(var URIData: string): string;
var
StartPos: Integer;
begin
// Step 1. - See if the query is here
StartPos := Pos('?', URIData);
// If the starting ? is not found then there is no query
if StartPos = 0 then
Exit;
// Copy the Query String
Result := Copy(URIData, StartPos + 1, Length(URIData));
Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackScheme(var URIData: string): string;
const
AllowedChars = ['A'..'Z', 'a'..'z', '0'..'9', '+', '-', '.'];
var
tString, WorkData: string;
i: Integer;
StringLength: Integer;
InValidScheme: Boolean;
begin
// Step 1. - Get To The First
WorkData := TrimToToken(':', URIData, False);
if WorkData = '' then
begin
Result := '';
Exit;
end;
// Get The String Length
StringLength := Length(WorkData);
// See if any invalid characters are in the system
InValidScheme := False;
for i := 1 to StringLength do
begin
// Check if the char is valid
InValidScheme := (WorkData[i] in AllowedChars) = False;
if InValidScheme then
Break;
end;
if InValidScheme then
begin
// we need to return the data back to the string
URIData := WorkData + ':' + URIData;
end
else
begin
Result := WorkData;
end;
end;

constructor TInternetURI.Create(URIData: string);
begin
// Step 1. - Copy The Fragment
Fragment := TrimPastToken('#', URIData, False);
// Step 2. - Crack the Scheme
Scheme := CrackScheme(URIData);
// Step 3. - Crack the Network Location
NetLocation := CrackLocation(URIData);
// Step 4. - Crack the Query
Query := CrackQuery(URIData);
// Step 5. - Crack the Parameters
Params := CrackParams(URIData);
// Finally !! Copy the Path (which should be all that is remaining)
Path := URIData;
end;

destructor TInternetURI.Destroy;
begin
inherited;

end;

// ---------------------------ooo------------------------------ \\
// Global routines for HTTP Processing
// ---------------------------ooo------------------------------ \\
// ---------------------------ooo------------------------------ \\
// This function will take the DataToParse and create a string
// list seperating the data using the user-defined tokens.
// ---------------------------ooo------------------------------ \\

function TokenizeString(Tokens: TSysCharSet; DataToParse: string): TStringList;
var
StringLength: Integer;
i, CurPos, StartPos: Integer;
tempString: string;
begin
try
// Create the result set
Result := TStringList.Create;
// Get The String Length
StringLength := Length(DataToParse);
// Setup the search
CurPos := 1;
StartPos := 1;
// Look for the tokens
for i := 1 to StringLength do
begin
// Increment the current position
Inc(CurPos);
// See if the char is in the token list
if DataToParse[i] in Tokens then
begin
// copy the string to current
tempString := Copy(DataToParse, StartPos, (CurPos - 1) - StartPos);
StartPos := i + 1;
end;
end;
// Copy the final string (if neccesary)
if (StartPos - 1) <> StringLength then
begin
tempString := Copy(DataToParse, StartPos, StringLength);
end;
except
Result.Free;
Result := nil;
end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the right of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
MaxCount: Integer = 1): string;
var
i: Integer;
begin
// First Tokenize the string
with TokenizeString([Token], DataToParse) do
begin
// Check if there were any occurences of Token
if Count = 0 then
begin
// Return blank then free and exit
Result := '';
Free;
Exit;
end;
// reset the final string
DataToParse := '';
for i := 0 to (MaxCount - 1) do
begin
// concat the string
if CopyToken then
Result := Result + Strings[i] + Token
else
Result := Result + Strings[i];
end;
// Copy and remaining data
for i := (MaxCount) to Pred(Count) do
begin
DataToParse := DataToParse + Strings[i];
end;
Free;
end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the left of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
True; MaxCount: Integer = 1): string;
var
i: Integer;
begin
// First Tokenize the string
with TokenizeString([Token], DataToParse) do
begin
// Check if there were any occurences of Token
if Count = 0 then
begin
// Return blank then free and exit
Result := '';
Free;
Exit;
end;
// reset the final string
DataToParse := '';
for i := 0 to (MaxCount - 1) do
begin
// concat the string
DataToParse := DataToParse + Strings[i];
end;
// Copy and remaining data
for i := (MaxCount) to Pred(Count) do
begin
if CopyToken then
Result := Result + Token + Strings[i]
else
Result := Result + Strings[i];
end;
Free;
end;
end;

end.

## 2004. november 29., hétfő

### How to position maximized forms

Problem/Question/Abstract:

I am working on a project that must keep the 640x480 pixel screen size. I would like to make it MDI. I've designed a small form with a menu and a tool bar (like Delphi's IDE). The user will click on this IDE like form and a new window will be display. Here is the problem: When the user maximizes this window, it goes to (0,0) thus hiding IDE form.

Handle WM_GETMINMAXINFO, that allows you to specify position and size of the maximized window:

private
{ Private declarations }

procedure WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo); message WM_GETMINMAXINFO;

procedure TForm2.WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo);
var
r: TRect;
begin
inherited;
SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
r.top := Application.Mainform.Height + Application.Mainform.Top;
with msg.MinMaxInfo^.ptMaxSize do
begin
x := r.right - r.left;
y := r.bottom - r.top;
end;
msg.Minmaxinfo^.ptmaxPosition := r.TopLeft;
end;

This code will make the form use the full available screen area (minus taskbar) under the main form, you will need to modify it to limit it to a maximum of 640x480.

## 2004. november 28., vasárnap

### Export ALL tables from MS jet to CSV via ADO

Problem/Question/Abstract:

How to export All Tables in a Microsoft Jet DB to a CSV file

procedure TMainForm.SaveAllTablesToCSV(DBFileName: string);
var
InfoStr,
FileName,
RecString,
WorkingDirectory: string;
OutFileList,
TableNameList: TStringList;
TableNum,
FieldNum: integer;
VT: TVarType;
begin
WorkingDirectory := ExtractFileDir(DBFileName);
TableNameList := TStringList.Create;
OutFileList := TStringList.Create;
InfoStr := 'The following files were created' + #13#13;

for TableNum := 0 to TableNameList.Count - 1 do
begin
FileName := WorkingDirectory + '\' +
TableNameList.Strings[TableNum] + '.CSV';
Caption := 'Saving "' + ExtractFileName(FileName) + '"';
OutFileList.Clear;

while not ADOTable1.Eof do
begin

RecString := '';
for FieldNum := 0 to ADOTable1.FieldCount - 1 do
begin
case VT of
// just write the field if not a string
vtInteger, vtExtended, vtCurrency, vtInt64:
RecString := RecString + ADOTable1.Fields[FieldNum].AsString
else
// it IS a string so put quotes around it
RecString := RecString + '"' +
end; { case }

// if not the last field then use a field separator
if FieldNum < (ADOTable1.FieldCount - 1) then
RecString := RecString + ',';
end; { for FieldNum }

end; { while }

OutFileList.SaveToFile(FileName);
InfoStr := InfoStr + FileName + #13;

end; { for  TableNum }
TableNameList.Free;
OutFileList.Free;
Caption := 'Done';
ShowMessage(InfoStr);
end;

procedure TMainForm.Button1Click(Sender: TObject);
const
ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
ConnStrC = ';Persist Security Info=False';
ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
if OpenDialog1.Execute then

try
ConnStrA + OpenDialog1.FileName + ConnStrC;
SaveAllTablesToCSV(OpenDialog1.FileName);
except
ShowMessage('Could not Connect to ' + #13 +
'"' + OpenDialog1.FileName + '"');
Close;
end;

end;

## 2004. november 27., szombat

### How to check file and directory attributes

Problem/Question/Abstract:

How to check file and directory attributes

The sample below works with the folder c:\temp .

procedure TForm1.Button1Click(Sender: TObject);
var
Ergebnis: integer;
Hidden: boolean;
Directory: boolean;
begin
{Get the current file attributes and store them in a local bool variable.
lbl_hidden, lbl_ReadOnly and lbl_Directory are TLabels}
Ergebnis := fileGetAttr('C:\Temp');
if Ergebnis and faHidden <> 0 then
begin
hidden := True;
lbl_hidden.Caption := 'Hidden File';
end
else
begin
Hidden := False;
lbl_hidden.Caption := 'Not a hidden file';
end;
if Ergebnis and faDirectory <> 0 then
begin
Directory := True;
lbl_Directory.Caption := 'We have a directory';
end
else
begin
Directory := False;
lbl_Directory.Caption := 'There is no directory';
end;
if Ergebnis and faReadOnly <> 0 then
begin
lbl_ReadOnly.Caption := 'File is write-protected';
end
else
begin
lbl_ReadOnly.Caption := 'File is not write-protected';
end;
refresh;
sleep(4000);
{Set attributes}
{Check set attributes and reset Ergebnis variable to original status}
Ergebnis := FileGetAttr('C:\Temp');
if Ergebnis and faHidden <> 0 then
begin
lbl_hidden.Caption := 'Attribute Hidden is set'; {TLabel}
if not hidden then
Ergebnis := Ergebnis xor fahidden;
end
else
lbl_hidden.Caption := 'Attribute Hidden is not set';
if Ergebnis and faReadOnly <> 0 then
begin
lbl_ReadOnly.Caption := 'Attribute Read Only is set';
if not ReadOnly then
Ergebnis := Ergebnis xor faReadOnly;
end
else
if Ergebnis and faDirectory <> 0 then
begin
lbl_Directory.Caption := 'Directory set';
if not Directory then
Ergebnis := Ergebnis xor faDirectory;
end
else
lbl_Directory.Caption := 'Directory not set';
refresh;
sleep(4000);
{Reset attributes}
FileSetAttr('C:\Temp', Ergebnis);
{Check if attributes were reset correctly}
Ergebnis := fileGetAttr('C:\Temp');
if Ergebnis and faHidden <> 0 then
lbl_hidden.Caption := 'Hidden file'
else
lbl_hidden.Caption := 'Not a hidden file';
if Ergebnis and faDirectory <> 0 then
lbl_Directory.Caption := 'We have a directory'
else
lbl_Directory.Caption := 'There is no directory';
if Ergebnis and faReadOnly <> 0 then
lbl_ReadOnly.Caption := 'File is write-protected'
else
lbl_ReadOnly.Caption := 'File is not write-protected';
refresh;
end;