## 2005. február 28., hétfő

### How to create a random string

Problem/Question/Abstract:

How to create a random string

Solve 1:

var
LoopInt: Integer;
DirName, FullName, RanStr: string;
FileSavedTo: TextFile;
{ Length of string to create }
RandArray: array[0..4087] of Char;
FirstCount: Extended;
begin
FirstCount := GetTickCount;
Label2.Caption := '';
Randomize;
RanStr := '';
DirName := Directory95ListBox1.Directory;
if DirName[Length(DirName)] <> '\' then
DirName := DirName + '\';
FullName := DirName + Edit1.Text;
if FileExists(FullName) then
DeleteFile(FullName);
for LoopInt := Low(RandArray) to High(RandArray) do
begin
RanStr := RanStr + Chr(Random(255 - 32 + 1) + 32);
end;
AssignFile(FileSavedTo, FullName);
if FileExists(FullName) then
Reset(FileSavedTo)
else
Rewrite(FileSavedTo);
Writeln(FileSavedTo, RanStr);
CloseFile(FileSavedTo);
Label2.Caption := ' Done ';
Label4.Caption := FloatToStr((GetTickCount - FirstCount) / 1000);
FileListBox1.Update;
end;

Randomize should be called only once in an application. You should therefore put the above code into the form's OnCreate event for example, or remove Randomize from the above code and call it from the form's OnCreate event handler.

Solve 2:

This routine creates passwords from a string table with selected chars. Note: The password length must be shorter than the given string table length.

{Call Randomize only once at application start.}

procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;

function RandomPwd(PWLen: integer): string;
{Set the table of chars to be used in passwords}
const
StrTable: string = '!#\$%&/()=?@<>|{[]}\*~+#;:.-_' + 'ABCDEFGHIJKLMabcdefghijklm' +
'0123456789' + '�������' + 'NOPQRSTUVWXYZnopqrstuvwxyz';
var
N, K, X, Y: integer;
begin
if (PWlen > Length(StrTable)) then
K := Length(StrTable) - 1
else
K := PWLen;
SetLength(result, K); {Set the length of the result string}
Y := Length(StrTable); {Table length for inner loop}
N := 0; {Loop start value}
while N < K do
begin {Loop to create K chars}
X := Random(Y) + 1; {Get next random char}
{Check for the presence of this char in the result string}
if (pos(StrTable[X], result) = 0) then
begin
Result[N] := StrTable[X];
end;
end;
end;

Used like this:

procedure TForm1.Button1Click(Sender: TObject);
var
cPwd: string;
begin
{e.g. create a random password string with 30 chars}
cPwd := RandomPwd(30);
{ ... }
end;

## 2005. február 27., vasárnap

### How to display image transition effects on the table.next event

Problem/Question/Abstract:

How to display image transition effects on the table.next event

Here's a rather simple example, using the :DBDEMOS:BIOLIFE table:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables, ExtCtrls;

type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Image1: TImage;
Timer1: TTimer;

procedure DataSource1DataChange(Sender: TObject; Field: TField);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
Y: integer;
NewBitmap: TBitmap;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

const
BIOLifeWidth = 250;
BIOLifeHeight = 150;

procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
begin
if Table1.State = dsBrowse then
begin
if NewBitmap = nil then
begin
NewBitmap := TBitmap.Create;
Image1.Picture.Graphic := TBitmap.Create;
with TBitmap(Image1.Picture.Graphic) do
begin
Width := BIOLifeWidth;
Height := BIOLifeHeight;
end;
end;
NewBitmap.Assign(Table1.FieldByName('Graphic'));
Y := 0;
Timer1.Enabled := true;
end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
R: TRect;
begin
R := Rect(0, Y, BIOLifeWidth, Y + 4);
with TBitmap(Image1.Picture.Graphic) do
begin
Canvas.CopyRect(R, NewBitmap.Canvas, R);
Inc(Y, 4);
if Y >= BIOLifeHeight then
Timer1.Enabled := false;
end;
end;

end.

## 2005. február 26., szombat

### Select multiple rows in a TStringGrid

Problem/Question/Abstract:

Is there any way to allow the user to select multiple rows that are not consecutive for example selecting rows 1,4,5,13, and 16 but not 2,3,6,7,8... ?

The standard selection mechanism build into the stringgrid only supports one consecutive block of selected cells (via the selection property). If you want more you have to code it. Find a way to store the selected state on a per-cell or per-row basis and then use the mouse events to give the user a means to change the state and a OnDrawCell handler to draw the cells accordingly.

I used the fixed column 0 in this grid to store the selected state for a row, the cell is either empty (not selected) or contains a space character (selected). I choose to draw a selection marker in column 0 instead of painting the selected rows with another background/ foreground color in this app. Something missing is the ability to click on the fixed column cell to toggle the selected state. I never got around to add that, you would use MouseToCell in OnMouseUp for that and make sure the Row property is set to that cells row before calling ToggleSelection. More work needs to be invested to support range selections as well.

const
sRowSelected = ' ';
sRowNotSelected = #0;

{This method is attached to the OnKeyPress event handler for the SGridIndications object. We use it to implement selection/ deselection of rows in the grid by a press of the spacebar. The grid is otherwise read-only.}

procedure TEinsendeMainForm.SGridIndicationsKeyPress(Sender: TObject; var Key: Char);
begin
if key = ' ' then
ToggleSelectedState;
key := #0;
end;

{This method is attached to the OnMouseUp event handler for the SGridIndications object. We use it to implement selection/deselection of rows in the grid by a click of the mouse. Any mouse button can be used.}

procedure TEinsendeMainForm.SGridIndicationsMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ToggleSelectedState;
end;

{procedure TEinsendeMainForm.SGridIndicationsDrawCell

Parameters:
Sender: the SGridIndications object
Col: column index for cell to draw
Row: row index for cell to draw
Rect: cell rectangle
State: cell state

Call method: static

Description:
This method is attached to the grids OnDrawCell event that is called every time a
cell needs to be draw. We rely mostly on the default drawing done by the grid
to display the data.The only thing we add is for the fixed column 0 cells:
if the cell contains a blank as a marker that it is selected we draw a red triangle as a visual cue for the selected state for this row. This type of selection is independend of the standard row selection the grid is set up for and allows any
number of rows to be selected and deselected individually. The grid does not support this kind of selection directly.

Error Conditions: none

Created: 29.06.97 11:58:58 by Peter Below
}

procedure TEinsendeMainForm.SGridIndicationsDrawCell(Sender: TObject;
Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var
poly: array[1..3] of TPoint;
dy, dx: Integer;
begin
if (Col = 0) and ((Sender as TStringGrid).Cells[0, Row] = ' ') then
begin
with TStringGrid(Sender).Canvas do
begin
Brush.Color := clRed;
Pen.Color := clRed;
poly[1].X := Rect.Right - 5;
poly[1].Y := (Rect.Bottom - Rect.Top) div 2 + Rect.Top;
dy := (Rect.Bottom - Rect.Top) * 6 div 10;
dx := Round(Sqrt(3 * dy * dy) / 2);
poly[2].X := poly[1].X - dx;
poly[3].X := poly[2].X;
poly[2].Y := poly[1].Y - dy div 2;
poly[3].Y := poly[1].Y + dy div 2;
Polygon(poly);
end;
end;
end;

{function TEinsendeMainForm.CountSelectedIndications
Parameters: none

Returns:
the number of rows currently marked as selected in the indication grid.

Call method: static

Description:
Iterates over all rows of the grid and checks the content of column 0.

Error Conditions: none

Created: 29.06.97 13:42:31 by P. Below
}

function TEinsendeMainForm.CountSelectedIndications: Integer;
var
i: Integer;
begin
Result := 0;
with SGridIndications do
for i := 1 to RowCount - 1 do
if Cells[0, i][1] = sRowSelected then
Inc(Result);
end;

{procedure TEinsendeMainForm.UnselectAllIndications
|
Parameters: none

Call method: static

Description: Deselects all indications in the indication grid.

Error Conditions: none

Created: 07.07.97 13:28:28 by P. Below
}

procedure TEinsendeMainForm.UnselectAllIndications;
var
i: Integer;
begin
with sGridIndications do
for i := 1 to RowCount - 1 do
Cells[0, i] := sRowNotSelected;
end;

{procedure TEinsendeMainForm.ToggleSelectedState

Parameters: none

Call method: static

Description:
Inverts the selection state of the current row in the indication grid. Called by several event handlers for the grid.

Error Conditions: none

Created: 29.06.97 13:44:28 by P. Below
}

procedure TEinsendeMainForm.ToggleSelectedState;
begin
with SGridIndications do
if Cells[0, row] = sRowSelected then
Cells[0, row] := sRowNotSelected
else
Cells[0, row] := sRowSelected;
LblNumSelIndications.Caption := IntToStr(CountSelectedIndications) +
sIndicationsSelected;
end;

{procedure TEinsendeMainForm.SelectIndication

Parameters:
IndicationCode: the numeric (Prisma) code for the indication
state: new state (selected or unselected) to set.

Call method: static

Description: Searches thru the indication grid for the indication and sets it state, if found.

Error Conditions: none

Created: 07.07.97 13:31:41 by P. Below
}

procedure TEinsendeMainForm.SelectIndication(const IndicationCode: string; state:
Boolean);
var
i: Integer;
ch: Char;
begin
with sGridIndications do
begin
i := Cols[1].IndexOf(IndicationCode);
if i > 0 then
begin
if state then
ch := sRowSelected
else
ch := sRowNotSelected;
Cells[0, i] := ch;
end;
end;
end;

## 2005. február 25., péntek

### Fix a small bug in TLabel.AutoSize

Problem/Question/Abstract:

Fix a small bug in TLabel.AutoSize

If you switch between small fonts and large fonts, your labels' sizes will not be fixed. AutoSize works only when you change the label's caption or when you switch the property AutoSize on.

The following piece of code could be run e.g. in FormCreate to fix the sizes.

for I := 0 to ComponentCount - 1 do
if Components[I] is TLabel then
with TLabel(Components[I]) do
if AutoSize = True then
begin
AutoSize := False;
AutoSize := True;
end;

## 2005. február 24., csütörtök

### How to draw checkboxes in a TDBGrid

Problem/Question/Abstract:

How to draw checkboxes in a TDBGrid

Two procedures follow. The first is called from the OnDrawColumnCell event of any grid that has visible boolean fields, as so:

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
DrawCheckBoxes(Sender, Rect, DataCol, Column, State);
end;

Here's the procedure. Place this in your toolkit or utility unit.

procedure DrawCheckBoxes(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
MyRect: TRect;
fld: TField;
begin
with (Sender as TDBGrid) do
begin
fld := Column.Field;
if fld is TBooleanField then
begin
MyRect.Top := ((Rect.Bottom - Rect.Top - 11) div 2) + Rect.Top;
MyRect.Left := ((Rect.Right - Rect.Left - 11) div 2) + Rect.Left;
MyRect.Bottom := MyRect.Top + 10;
MyRect.Right := MyRect.Left + 10;
if gdSelected in State then
Canvas.Pen.Color := clWhite
else
Canvas.Pen.Color := clBlack;
Canvas.Polyline([
Point(MyRect.Left, MyRect.Top), Point(MyRect.Right, MyRect.Top),
Point(MyRect.Right, MyRect.Bottom), Point(MyRect.Left, MyRect.Bottom),
Point(MyRect.Left, MyRect.Top)]);
if fld.AsBoolean then
begin
Canvas.MoveTo(MyRect.Left + 2, MyRect.Top + 4);
Canvas.LineTo(MyRect.Left + 2, MyRect.Top + 7);
Canvas.MoveTo(MyRect.Left + 3, MyRect.Top + 5);
Canvas.LineTo(MyRect.Left + 3, MyRect.Top + 8);
Canvas.MoveTo(MyRect.Left + 4, MyRect.Top + 6);
Canvas.LineTo(MyRect.Left + 4, MyRect.Top + 9);
Canvas.MoveTo(MyRect.Left + 5, MyRect.Top + 5);
Canvas.LineTo(MyRect.Left + 5, MyRect.Top + 8);
Canvas.MoveTo(MyRect.Left + 6, MyRect.Top + 4);
Canvas.LineTo(MyRect.Left + 6, MyRect.Top + 7);
Canvas.MoveTo(MyRect.Left + 7, MyRect.Top + 3);
Canvas.LineTo(MyRect.Left + 7, MyRect.Top + 6);
Canvas.MoveTo(MyRect.Left + 8, MyRect.Top + 2);
Canvas.LineTo(MyRect.Left + 8, MyRect.Top + 5);
end;
end;
end;
end;

There's a little setup involved. Select each visible boolean field in the fields editor and set the DisplayValues to ' ;'. That's space + semicolon. I like the DisplayWidth set to 2.

The next procedure is optional/ extra. It's a keystroke handler that will change the value of the field if the user presses space, T, F, Y, or N.Place it in your utility unit also and call it from your OnKeyPress event in the grid as so:

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
CheckBoxKeyPress(Sender, Key);
end;

And here's the procedure:

procedure CheckBoxKeyPress(const Sender: TObject; var Key: Char);
var
fld: TField;
tbl: TDataset;
i: integer;
begin
if UpCase(Key) in [' ', 'T', 'F', 'Y', 'N'] then
begin
with (Sender as TDBGrid) do
begin
i := SelectedIndex;
fld := SelectedField;
tbl := fld.DataSet;
if fld is TBooleanField then
begin
if not (tbl.State in [dsEdit, dsInsert]) then
tbl.Edit;
if Key = ' ' then
fld.AsBoolean := not fld.AsBoolean
else if (UpCase(Key) = 'T') or (UpCase(Key) = 'Y') then
fld.AsBoolean := True
else
fld.AsBoolean := False;
tbl.Post;
Key := #0;
Inc(i);
if i = FieldCount then
begin
i := 0;
tbl.Next;
if tbl.EOF then
tbl.Append;
end;
SelectedIndex := i;
end;
end;
end;
end;

## 2005. február 23., szerda

### How to display memo fields in a TDBGrid

Problem/Question/Abstract:

How to display memo fields in a TDBGrid

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
P: array[0..50] of char; {array size is number of characters needed}
BS: tBlobStream; {from the memo field}
S: string;
begin
if Field is TMemoField then
begin
with (Sender as TDBGrid).Canvas do
begin
FillChar(P, SizeOf(P), #0); {terminate the null string}
BS.Free;
S := StrPas(P);
while Pos(#13, S) > 0 do
S[Pos(#13, S)] := ' ';
while Pos(#10, S) > 0 do
S[Pos(#10, S)] := ' ';
FillRect(Rect); {clear the cell}
TextOut(Rect.Left, Rect.Top, S); {fill cell with memo data}
end;
end;
end;

For mouse right click behavior you need to intercept the right click mouse message.

## 2005. február 22., kedd

### Check which column of a TListView in vsReport style has been clicked

Problem/Question/Abstract:

How can I know which column was click in a TListView? GetItemAt only works with the first column.

Solve 1:

The method GetItemAt only provides the information about which ListItem (if any) is located at the specified coordinates passed as parameters, but only works with the first column of the TListView. The rest are ignored. If we needed to know if the user clicked on an element in another column, we can declare a new method in a derived class:

type
TListViewX = class(TListView)
public
function GetItemAtX(X, Y: integer; var Col: integer): TListItem;
end;

implementation

function TListViewX.GetItemAtX(X, Y: integer;
var Col: integer): TListItem;
var
i, n, RelativeX, ColStartX: Integer;
ListItem: TlistItem;
begin
Result := GetItemAt(X, Y);
if Result <> nil then
begin
Col := 0; // First column
end
else if (ViewStyle = vsReport)
and (TopItem <> nil) then
begin
// First, let's try to find the row
ListItem := GetItemAt(TopItem.Position.X, Y);
if ListItem <> nil then
begin
// Now let's try to find the Column
RelativeX := X - ListItem.Position.X - BorderWidth;
ColStartX := Columns[0].Width;
n := Columns.Count - 1;
for i := 1 to n do
begin
if RelativeX < ColStartX then
break;
if RelativeX <= ColStartX +
StringWidth(ListItem.SubItems[i - 1]) then
begin
Result := ListItem;
Col := i;
break;
end; //if
Inc(ColStartX, Columns[i].Width);
end; //for
end; //if
end; //if
end;

Casting to the new class

We don't need to intall this new component and register it in the components palette as we explained in another article ("Adding new methods and properties without registering new components"). Instead, any time we want to access this method, we can just cast the object (for example ListView1) to our new class. For example in a MouseDown event:

procedure TForm1.ListView1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
col: integer;
li: TListItem;
begin
li := TListViewX.GetItemAtX(x, y, col);
if li <> nil then
ShowMessage('Column #' + IntToStr(col));
end;

Solve 2:

uses
commctrl;

procedure TForm1.ListView1Click(Sender: TObject);
var
pt: TPoint;
col: Integer;
pos: Integer;
begin
GetCursorPos(pt);
pt := Listview1.ScreenToClient(pt);
Pos := -GetScrollPos(ListView1.Handle, SB_HORZ);
Col := -1;
while Pos < Pt.X do
begin
Inc(Col);
Inc(Pos, ListView_GetColumnWidth(ListView1.Handle, Col));
end;
if Col >= ListView1.Columns.Count then
Col := -1; {clicked past last column}
showmessage(inttostr(col));
end;

## 2005. február 21., hétfő

### Application Settings (article 2)

Problem/Question/Abstract:

Managing Application Settings

Introduction

In part 1 of this article, we looked at how we can automate the handling of application settings using a base object, TGXAppSettings. In part 2, we are going to look at using an object dataset to interface the application settings object to data aware controls.

The Object Dataset

Now that we have created our TRichEditSettings object, we need to somehow enable the end user of our application to manipulate the properties of TRichEditSettings. A first crack at doing this might look something like this:

begin
cbWordWrap.Checked := Settings.WordWrap;
edFontName.Text := Settings.FontName;
edFontSize.Text := IntToStr(Settings.FontSize);
end;

procedure TForm1.SaveSettings;
begin
Settings.WordWrap := cbWordWrap.Checked;
Settings.FontName := edFontName.Text;
Settings.FontSize := StrToInt(edFontSize.Text);
end;

This approach works fine when there is only a few properties to deal with, but in a real application there could be hundreds of properties and this approach will get very tedious, very quickly. Fortunately, due to architectural changes made in Delphi 3, we can do something about this.

In Delphi 1 and 2, data access was tightly bound to the BDE. Starting with Delphi 3, Borland abstracted the TDataset class thereby allowing anyone to create a provider of data. Since Delphi 3 was released lot of vendors have taken advantage of this by creating TDataset descendants that enable developers to access various datasources such as SQL Server, Interbase, Dbase without having to go through the BDE. I know what your asking yourself, how does this benefit us in this case?

Simple really. What we are going to do is create a TDataset descendant that treats objects as if they were a database. The object itself can be considered the "Table" while the properties will become the "Fields". By doing this we can directly connect the properties of our application settings object to data aware controls and thereby eliminate the work of transferring the information manually to visual controls and back again.

Using the Object Dataset

Now explaining how to write a complete dataset descendant is far beyond the scope of this article. Instead, I'm going to focus on how to use the object dataset I've written in the context of application settings.

The first thing we need to do is create an options form. Here a the picture of the one included in the sample code.

At the bottom of the form are three non-visual components. The leftmost component is the TRichEditSettings component, the middle component is the TGXObjectDataset and the right component is a standard TDataSource component.

Once we have dropped these components on the form, we need to hook them up. Set the GXObjectDataset's Component property to RichEditSettings1. You can create persistent field objects at this time if you desire, but generally there is no need to. In order to better show how the RichEditSettings properties become fields, I have included a picture below of the fields editor showing the persistent fields generated by the GXObjectDataset when connected to a TRichEditSettings component.

Next, connect the datasource to the GXObjectDataset. Finally, go through the data aware components and set the datasource and datafield property. Remember, every property of TRichEditSettings will appear as a field.

Now that this has been completed, we can write the code to show the options dialog from the main form. It's very straightforward.

procedure TMainForm.acOptionsExecute(Sender: TObject);
var
Dlg: TfmOptions;
begin
Dlg := TfmOptions.Create(Self);
try
Dlg.RichEditSettings1.Assign(RichEditSettings);
Dlg.GXObjectDataset1.Open;
if Dlg.ShowModal = mrOK then
begin
if (Dlg.GXObjectDataset1.State in dsEditModes) then
Dlg.GXObjectDataset1.Post;
RichEditSettings.Assign(Dlg.RichEditSettings1);
SelectionChange(Editor);
end;
finally
Dlg.Free;
end;
end;

In the above code, we first create the options dialog. We then assign the current RichEditSettings object of the main form to the dialog's RichEditSettings. This means that the user is working on a copy. Next we open the GXObjectDataset on the dialog so that when the dialog is shown, the user will be able to edit the various values. After this, we then show the dialog modally.

If the user clicked the OK button, we check to see if the GXObjectDataset is in edit mode, and if so, post the changes. This will cause the underlying properties of the RichEditSettings component of the dialog to be updated with the user changes. We then assign the option dialog's RichEditSettings to the main forms RichEditSettings in order to capture the users changes. Finally, we update the richedit control with the new changes.

Conclusion

Well, this was a short Part 2 but I hope you have seen that managing application settings can be easy instead of being a chore.

Code

## 2005. február 20., vasárnap

### How to get the number of files in a folder

Problem/Question/Abstract:

How to get the number of files in a folder

uses
Windows, { ... }

function FileCount(const aFolder: string): Integer;
var
H: THandle;
Data: TWin32FindData;
begin
Result := 0;
H := FindFirstFile(PCHAR(aFolder + '*.*'), Data);
if H <> INVALID_HANDLE_VALUE then
repeat
Inc(Result, Ord(Data.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0));
until
not FindNextFile(H, Data);
Windows.FindClose(H);
end;

## 2005. február 19., szombat

### Get a name of enum value

Problem/Question/Abstract:

How can I retrieve the string name of some enumerate value?

For example, if you have the some enum type TyourEnumType = (One, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten) and you want in run-time to get a string with same value for each of them (for example, fill the combobox items with enum values), then you can use the next procedure:

uses TypInfo;

var
i: Integer;
begin
for i := Ord(Low(TyourEnumType)) to Ord(High(TyourEnumType)) do
end;

## 2005. február 18., péntek

### How to minimize a secondary-form to the taskbar

Problem/Question/Abstract:

How to minimize a secondary-form to the taskbar

You can minimize a secondary-form to the taskbar using the following piece of code:

type
TForm = class(TForm)
...
private
{ Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
end;

implementation

.....

procedure TForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
{ Set the extended style for iconizing to the taskbar }
{ See CreateWindowEx }
with Params do
exStyle := exStyle or WS_EX_APPWINDOW;
end;

## 2005. február 17., csütörtök

### Sending e-mail with attachment using MS Outlook

Problem/Question/Abstract:

How to send e-mail with attachment using MS outlook

Solve 1:

The unit that can do the job is scratched below:

unit OutLookMail;

interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Outlook8, OleServer, COMobj, ActiveX;

type
TMailRecord = record
FileToAttach: string;
MailTo: string;
CC: string;
BCC: string;
Subject: string;
Body: string;
end;

procedure OutLookMailProc(MailDetail: TMailRecord);

implementation

procedure OutLookMailProc(MailDetail: TMailRecord);
var
objOutlook: OutlookApplication;
CurrentInterface: IUnknown;
ActiveApplication: HResult;
CurrentMailItem: MailItem;
MailInspector: Inspector;
begin
ActiveApplication := GetActiveObject(CLASS_OutlookApplication, nil,
CurrentInterface);
if ActiveApplication = MK_E_UNAVAILABLE then
objOutlook := CoOutlookApplication.Create
else
begin
OleCheck(ActiveApplication);
OleCheck(CurrentInterface.QueryInterface(OutlookApplication, objOutlook));
end;
CurrentMailItem := objOutlook.CreateItem(0) as MailItem;
CurrentMailItem.To_ := MailDetail.MailTo;
if MailDetail.FileToAttach <> '' then
EmptyParam);
CurrentMailItem.cc := MailDetail.CC;
CurrentMailItem.BCC := MailDetail.BCC;
CurrentMailItem.Subject := MailDetail.Subject;
CurrentMailItem.Body := MailDetail.Body;
MailInspector := CurrentMailItem.GetInspector;
MailInspector.Display(False);
Showmessage('I am waiting you to finish the mail process. Please click OK when done !');
objOutlook.Quit;
objOutlook := nil;
end;

end.

Unit for the Demo:

unit MailDemo;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Db, qrprntr, Qrctrls, qrExtra, qrexport, DBTables, QuickRpt, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
EditMailTo: TEdit;
Label1: TLabel;
Label2: TLabel;
EditSubject: TEdit;
Label3: TLabel;
EditFileToAttach: TEdit;
Memo1: TMemo;
Label4: TLabel;
Label5: TLabel;
EditCC: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses OutLookMail;

{\$R *.DFM}

const
CRLF = chr(13) + chr(10);

procedure TForm1.Button1Click(Sender: TObject);
var
MailDetail: TMailRecord;
x: integer;
begin
MailDetail.FileToAttach := EditFileToAttach.Text;
MailDetail.MailTo := EditMailTo.Text;
MailDetail.CC := EditCC.Text;
MailDetail.subject := EditSubject.Text;
MailDetail.Body := '';
for x := 0 to Memo1.Lines.Count - 1 do
MailDetail.Body := MailDetail.Body + Memo1.lines[x] + CRLF;
OutLookMailProc(MailDetail);
end;

end.

Solve 2:

procedure SendMail;
var
OleApp, OleItem: OleVariant;
begin
try
try
OleApp := GetActiveOleObject('Outlook.Application');
except
OleApp := CreateOleObject('Outlook.Application');
end;

OleItem := OleApp.CreateItem(0);
OleItem.Body := 'EMail body text here';
OleItem.CC := 'Semi Colon delimited CC here';
OleItem.BCC := 'Semi Colon delimted BCC here';
OleItem.Send;
OleItem := VarNull;
OleApp := VarNull;
except
OleItem := VarNull;
OleApp := VarNull;
ShowMessage('EMail failed');
end;
end;

## 2005. február 16., szerda

### Detect whether the default or the keypad Enter key was pressed

Problem/Question/Abstract:

How to detect whether the default or the keypad Enter key was pressed

You could put something like this on an Application.OnMessage event, or trap the WM_KEYUP message in your component:

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := HandleMessage;
end;

procedure TForm1.HandleMessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := False;
if Msg.Message = WM_KEYUP then
begin
if Msg.wParam = VK_RETURN then
begin
if Msg.LParam and (1 shl 24) > 0 then
else
end;
end;
end;

## 2005. február 15., kedd

### Changing extension in Save Dialog

Problem/Question/Abstract:

How can I make the Save dialog automatically change the file extension of the filename when the user selects a different Filter?

The solution to this problem is to handle the OnTypeChange event of the TSaveDialog and directly send a message to the dialog. Start by assigning an event handler for the OnTypeChange event (this is called whenever the user selects a different filter in the dialog). Delphi keeps track of which FilterIndex is currently selected even when the dialog is open, so we can write the following code:

procedure TForm1.SaveDialogTypeChange(Sender: TObject);
var
buf: array[0..MAX_PATH] of char;
S: string;
od: TSaveDialog;
H: THandle;
begin
// get a pointer to the dialog
od := (Sender as TSaveDialog);
// Send the message to the dialogs parent so it can handle it the normal way
H := GetParent(od.Handle);
// get the currently entered filename
SendMessage(H, CDM_GETSPEC, MAX_PATH, integer(@buf));
S := buf;
// change the extension to the correct one
case od.FilterIndex of
1:
S := ChangeFileExt(S, '.rtf');
2:
S := ChangeFileExt(S, '.html');
3:
S := ChangeFileExt(S, '.txt');
end;
// finally, change the currently selected filename in the dialog
SendMessage(H, CDM_SETCONTROLTEXT, edt1, integer(PChar(S)));
end;

In the example, I have three filters for RTF, HTML and TXT and the code changes the extension to the correct one simply by calling ChangeFileExt on the existing filename. The CDM_* constants are defined in CommDlg.pas, so you must add this to your uses clause (or redeclare them in your unit). The constant edt1 is taken from the file Dlgs.pas where every constant used in the common dialogs are listed. edt1 is the first edit control on any common dialog, edt2 the second etc.

## 2005. február 14., hétfő

### Searching Strings by the way they sound

Problem/Question/Abstract:

Did you ever want to find a string - But were not sure of it's spelling? A typical case would be names (Micael/Maical/Michael/Maichael) all sound same but differ in spelling!

Most of you may already be familiar with the magical "Soundex" function which is present in many Db environments ranging from FoxPro to Oracle/SQL Server. Few of you may wonder how it works! Well, here is the implementation of the Soundex function in Pascal based on an algorithm that I found in a computer magazine long time back. The original program worked in Turbo Pascal, but I have modified it for Delphi (The only change being use of ShortString instead of String!)

The function seems to return the same values as does SQL Server for the little tests that I conducted. However, as you will have already guessed, I provide you no gurantee that it will provide same values for all strings.

Please save the code below in a file called Soundx.pas. You will need to include the file in your source (Uses Soundx) and then you will have access to the Soundex() function.

For the example given in the Question/Problem/Abstract, Soundex returns the same value (M240) for each of Micael/Maical/Michael/Maichael

Wishing you all a "Sound" search (Ha!)

{******************************************************}
{* Description: Implementation of Soundex function    *}
{******************************************************}
{* Author        : Paramjeet Singh Reen               *}
{* eMail         : Paramjeet.Reen@EudoraMail.com      *}
{******************************************************}
{* This program is based on the algorithm that I had  *}
{* found in a magazine. I do not gurantee the fitness *}
{* of this program. Please use it at your own risk.   *}
{******************************************************}
{* Category :Freeware.                                *}
{******************************************************}

unit Soundx;

interface

type
SoundexStr = string[4];

//Returns the Soundex code for the specified string.
function Soundex(const InpStr: ShortString): SoundexStr;

implementation

const
Alphs: array['A'..'Z'] of Char = ('0', '1', '2', '3', '0', '1', '2', '0', '0', '2',
'2',
'4', '5', '5', '0', '1', '2', '6', '2', '3', '0', '1',
'0', '2', '0', '2');

function Soundex(const InpStr: ShortString): SoundexStr;
var
vStr: ShortString;
vCh1: Char;
i: Word;

begin
//Store the given InpStr in local variable in uppercase
vStr := '';
for i := 1 to Length(InpStr) do
vStr := vStr + UpCase(InpStr[i]);

//Replace all occurances of "PH" with "F"
i := Pos('PH', vStr);
while (i > 0) do
begin
Delete(vStr, i, 2);
Insert('F', vStr, i);
i := Pos('PH', vStr);
end;

//Replace all occurances of "CHR" with "CR"
i := Pos('CHR', vStr);
while (i > 0) do
begin
Delete(vStr, i, 3);
Insert('CR', vStr, i);
i := Pos('CHR', vStr);
end;

//Replace all occurances of "Z" with "S"
for i := 1 to Length(vStr) do
if (vStr[i] = 'Z') then
vStr[i] := 'S';

//Replace all occurances of "X" with "KS"
i := Pos('X', vStr);
while (i > 0) do
begin
Delete(vStr, i, 1);
Insert('KS', vStr, i);
i := Pos('X', vStr);
end;

i := 2;
while (i <= Length(vStr)) do
if (vStr[i] = vStr[i - 1]) then
Delete(vStr, i, 1)
else
Inc(i);

//Starting from 2nd char, remove all chars mapped to '0' in Alphs table
i := 2;
while (i <= Length(vStr)) do
if (Alphs[vStr[i]] = '0') then
Delete(vStr, i, 1)
else
Inc(i);

//Assemble Soundex string from Alphs table
vCh1 := vStr[1];
for i := 1 to Length(vStr) do
vStr[i] := Alphs[vStr[i]];

//Remove all adjacent duplicates from assembled Soundex string
i := 2;
while (i <= Length(vStr)) do
if (vStr[i] = vStr[i - 1]) then
Delete(vStr, i, 1)
else
Inc(i);

//Final assembly of Soundex string
vStr := vCh1 + Copy(vStr, 2, 255);
for i := Length(vStr) to 3 do
vStr := vStr + '0';
Soundex := vStr;
end;

end.

## 2005. február 13., vasárnap

### Retrieve a folder list from MS Outlook

Problem/Question/Abstract:

Do you want to use the MS Outlook from Delphi application?

The procedure below allow to load a tree of available folders into TTreeView:

procedure RetrieveOutlookFolders(tvFolders: TTreeView);

var
i: Integer;
node: TTreeNode;
begin
for i := 1 to Folder.Count do
begin
Folder.Item[i].Name;

end;
end;

var
outlook, NameSpace: OLEVariant;
begin
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');

outlook := UnAssigned;
end;

the data in Outlook have the next structure: outlook application defines a MAPI's namespace which have a collection of folders. Each folder contains an items or sub-folders
this code load a full tree in TreeView. Of course, if you have a lot of pst-files with messages (active, archive, backup etc) and each of this pst-file have a large structure of folders, this code will work slowly. So as suggestion: you can rewrite a code and load the one level only. In this case code will work quickly and a list of sub-folders you'll receive in OnExpanding event of your TreeView
each folder of Outlook have an unique idenifier. You can save it somewhere (for example, in Data property of TTreeNode). Remember that this ID is long string value which you can receive as EntryID in loop of LoadFolder procedure:

Folder.Item[i].EntryID

PS: if this topic is interested for you, I'll continue this serie of tips and shall show how to load the messages/contacts/tasks/etc from some folder or create a new item.

## 2005. február 12., szombat

### How to embed binary data in an executable

Problem/Question/Abstract:

I have a very specialized script language which requires an executable program (The Engine) to load and process scripts. This works on the basis that each script requires its own copy of the executable processing engine (for reasons about to be explained). I want to take this a step further by embedding a script inside the executable at runtime. This will be done from my existing script editor. Something like a compile script function. How can I open an executable file, safely add a block of binary data which can then be read when the executable is running? I know this can be done. If virus writers can put additional executable code into an *.exe file, then I must be able to put binary data in.

I wrote this component to embed data in forms or datamodules. Drop the component in the form, double click it and select the file to embed. I have written a version that compresses the data also, but I lost it, anyway, is not complicated to do so if you want compressed data.

unit uBinaryData;

interface

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

type
TBinaryData = class(TComponent)
private
MemStream: TStream;
TempFileName: string;
procedure WriteData(Stream: TStream);
procedure SetStream(Stream: TStream);
function GetDataSize: Longint;
procedure SetDataSize(ASize: Longint);
protected
procedure DefineProperties(Filer: TFiler); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetTempFile(const Ext: string): string;
procedure DeleteTempFile;
procedure SaveToFile(const FName: string);
property Stream: TStream read MemStream write SetStream;
published
property DataSize: Longint read GetDataSize write SetDataSize;
end;

TBinaryDataEditor = class(TComponentEditor)
protected
function GetVerbCount: Integer; override;
function GetVerb(index: Integer): string; override;
procedure ExecuteVerb(index: Integer); override;
procedure Edit; override;
end;

procedure Register;

implementation

{ TBinaryData }

constructor TBinaryData.Create;
begin
inherited;
MemStream := TMemoryStream.Create;
end;

destructor TBinaryData.Destroy;
begin
MemStream.Free;
if TempFileName <> '' then
DeleteTempFile;
inherited;
end;

function TBinaryData.GetDataSize;
begin
Result := MemStream.Size;
end;

procedure TBinaryData.SetDataSize;
begin
(MemStream as TMemoryStream).SetSize(ASize);
end;

procedure TBinaryData.DefineProperties;
begin
inherited;
end;

var
ASize: Longint;
begin
if ASize > 0 then
begin
(MemStream as TMemoryStream).SetSize(ASize);
end;
end;

procedure TBinaryData.WriteData;
var
ASize: Longint;
begin
ASize := MemStream.Size;
Stream.Write(ASize, sizeof(ASize));
if ASize > 0 then
Stream.Write((MemStream as TMemoryStream).Memory^, ASize);
end;

procedure TBinaryData.SetStream;
begin
if Stream <> nil then
else
(MemStream as TMemoryStream).SetSize(0);
end;

function TBinaryData.GetTempFile;
const
FirstChars: PChar = 'AAA';
var
PathBuffer: array[0..255] of char;
FileName: array[0..MAX_PATH] of char;
FileStream: TFileStream;
begin
GetTempPath(256, PathBuffer);
if GetTempFileName(PathBuffer, FirstChars, 0, FileName) = 0 then
raise Exception.Create('No se pudo crear el archivo temporal');
Result := StrPas(FileName);
DeleteFile(Result);
Result := ChangeFileExt(Result, Ext);
TempFileName := Result;
FileStream := TFileStream.Create(Result, fmCreate);
try
MemStream.Seek(0, 0);
FileStream.CopyFrom(MemStream, MemStream.Size);
finally
FileStream.Free;
end;
end;

procedure TBinaryData.DeleteTempFile;
begin
DeleteFile(TempFileName);
TempFileName := '';
end;

procedure TBinaryData.SaveToFile;
var
s: TFileStream;
begin
s := TFileStream.Create(FName, fmCreate);
try
Stream.Seek(0, 0);
s.CopyFrom(Stream, Stream.Size);
finally
s.Free;
end;
end;

{ TBinaryDataEditor }

function TBinaryDataEditor.GetVerbCount;
begin
Result := 1;
end;

function TBinaryDataEditor.GetVerb;
begin
end;

procedure TBinaryDataEditor.ExecuteVerb;
begin
Edit;
end;

procedure TBinaryDataEditor.Edit;
var
OpenDialog: TOpenDialog;
FileStream: TFileStream;
begin
OpenDialog := TOpenDialog.Create(Application);
try
OpenDialog.Filter := '*.*';
if OpenDialog.Execute then
if FileExists(OpenDialog.Filename) then
begin
try
(Component as TBinaryData).Stream := FileStream;
Designer.Modified;
finally
FileStream.Free;
end;
end;
finally
OpenDialog.Free;
end;
end;

procedure Register;
begin
RegisterComponents('Misc', [TBinaryData]);
RegisterComponentEditor(TBinaryData, TBinaryDataEditor);
end;

end.

## 2005. február 11., péntek

### How to resize controls according to the users font settings

Problem/Question/Abstract:

How to resize controls according to the users font settings

You don't need the resolution (unless you plan on rearranging the controls on your form depending on resolution). You can get the appropriate "base unit" for sizing controls like this:

BaseUnit := Canvas.TextHeight('0');

This returns a value which is 8 times what Windows calls a "dialog unit." Every control can be sized to some integral number of dialog units. For example, I normally make my buttons 40 units wide and 14 units tall. So the code would go something like this:

ButtonWidth := (40 * BaseUnit) div 8;
ButtonHeight := (14 * BaseUnit) div 8;
MyButton.SetBounds(L, T, ButtonWidth, ButtonHeight);

This will resize the button in accordance with whatever the user's font size setting happens to be. It is the font.height that changes during the automatic scaling of the form (if you leave form.scaled set to true) and this will make the component scale as well.

## 2005. február 10., csütörtök

### Make my program open a file specified as a command line parameter?

Problem/Question/Abstract:

How do I make my program open a file specified as a command line parameter?

To do this you need to use two functions - ParamCount and ParamStr. ParamCount returns the number of command line parameters specified when the program was run.  ParamStr returns the parameter string of a specified parameter.

Basically all you need to do is check to see whether any parameters have been passed, and if so evaluate them. The format of the parameter(s) is entirely up to you, and you can produce code to deal with anything from a single parameter to a whole range.

This simple example only allows for a single parameter - a file name - and if a file name is passed the program loads that file when the form is shown. It requires a single form with a Memo dropped onto it. Simply put the following code into the form's OnShow event:

procedure TForm1.FormShow(Sender: TObject);
begin
��Memo1.Clear;
��if ParamCount > 0 then
��begin
��  ��case ParamCount of
��  ����// allow for other possible parameter counts here
��  ��else
��  �����begin
��  �������ShowMessage('Invalid Parameters');
��  �������Application.Terminate;
��  �����end;
��  end;
end;

To prove this code, after compiling the program of course, select Start | Run and enter the following. Make sure that you replace the path of the exe file with the correct path for your machine:

"F:\Borland\Delphi 3\Project1.exe" "c:\windows\win.ini"

This will open the Win.ini file in the memo in the application you created.  Obviously this example could be extended considerably (there is no check to make sure that the file exists, for example) and the parameters could be parsed to determine what should be done with the information. It does not have to be a file opening command, it could just as easily be configuration information or indeed anything else that you may wish to specify when the program is run.

## 2005. február 9., szerda

### How to save a metafile displayed in a TImage as a bitmap

Problem/Question/Abstract:

How to save a metafile displayed in a TImage as a bitmap

Try to give the width and height of the image in the bitmap before drawing the metafile or use the assign method of the bitmap to get the results you want. For example:

{ ... }
var
aBitmap: TBitmap;
begin
aBitmap := TBitmap.Create;
aBitmap.width := Image.picture.width;
aBitmap.height := Image1.picture.height;
try
aBitmap.Canvas.Draw(0, 0, Image1.Picture.Metafile);
abitmap.SaveToFile('D:\temp\mybit.bmp');
finally
aBitmap.free;
end;

or try:

{ ... }
var
aBitmap: TBitmap;
begin
aBitmap := TBitmap.Create;
try
aBitmap.assign(image1.picture.graphic);
aBitmap.SaveToFile('D:\temp\mybit.bmp');
finally
aBitmap.free;
end;

## 2005. február 8., kedd

### Pitfalls reading from the Registry (ProxyEnable)

Problem/Question/Abstract:

Pitfalls reading from the Registry (ProxyEnable)

The following has been verified for Delphi 3. It may be slightly different for Delphi 5.
In a project I had to read the Boolean field &#8220;ProxyEnable&#8221; from the registry. It is stored in

HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings

On the systems that I work with (NT 4.0/ sp 5, NT 4.0/ sp 6, Win 2000/ sp 1) I checked and determined that this value was stored as a REG_DWORD. 0 meant false, 1 meant true. So I simply coded as shown in 1)

Pitfall 1): Unexpected Entry Type

On some customer machines, the value ProxyEnable was stored as a REG_BINARY. Reading a REG_BINARY with ReadInteger() causes an exception &#8211; and to make things worse, exception handling was not yet in place since it was executed during the initialization of my application.

So I changed my code to 2) and hoped it would work.

Pitfall 2): Read the exact length

This was a surprising one. When you have a registry value of type REG_BINARY that is 4 bytes long and you try reading it with

&#8230; then you will experience another exception. The correct code is as shown in part 3.

// Version 1:
// raises an exception because of the unexpected entry type

// Version 2:
// detect type with GetDataType(),
// but not size... raises an exception if the size is wrong

case GetDataType(sProxyEnable) of
rdInteger:
rdBinary:
// other types..
end;

// Version 3:
// detect type and size (GetDataSize())! Works so far.

case GetDataType(sProxyEnable) of
rdInteger:
rdBinary:
// other types..
end;

## 2005. február 7., hétfő

### How to get a list of all published methods for a given class

Problem/Question/Abstract:

Is there a way to get a list of all published methods for a given class? Preferably, I'd like to fill a TList with references to them, but even the text representation would work.

Enumerate the published methods of a class and all its ancestor classes:

procedure EnumMethods(aClass: TClass; lines: TStrings);

type
TMethodtableEntry = packed record
len: Word;
name: ShortString;
end;
{Note: name occupies only the size required, so it is not a true shortstring!
The actual entry size is variable, so the method table is not an array
of         TMethodTableEntry!}

var
pp: ^Pointer;
pMethodTable: Pointer;
pMethodEntry: ^TMethodTableEntry;
i, numEntries: Word;
begin
if aClass = nil then
Exit;
pp := Pointer(Integer(aClass) + vmtMethodtable);
pMethodTable := pp^;
lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable]));
if pMethodtable <> nil then
begin
{first word of the method table contains the number of entries}
numEntries := PWord(pMethodTable)^;
{make pointer to first method entry, it starts at the second word of the table}
pMethodEntry := Pointer(Integer(pMethodTable) + 2);
for i := 1 to numEntries do
begin
with pMethodEntry^ do
{make pointer to next method entry}
pMethodEntry := Pointer(Integer(pMethodEntry) + pMethodEntry^.len);
end;
end;
EnumMethods(aClass.ClassParent, lines);
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
memo1.clear;
EnumMethods(Classtype, memo1.lines);
end;

## 2005. február 6., vasárnap

### How to compare the contents of folders including subdirectories

Problem/Question/Abstract:

I need to compare the file contents of a folder and its subfolders on all Win98 machines at my client's site (each machine was setup differently but, over time, has had different patches applied to the program in question). I need to report back only the differences found in files based upon Time/ Date stamp. Is there a good way to do this?

You use a recursive scanning loop (FindFirst/ FindNext/ FindClose) starting at the topmost folder you need to examine. The loop stores each file it find into a TStringlist. It stores a relative path to the start folder. For each file found it also stores the searchrec.time into the Objects property of the stringlist (it uses AddObject instead of Add). It will fit with a little typecast since it is four bytes, like an object reference. After the end of the scan you have a list of all files, which you can now write to disk for your reference computer to produce a master list that will be used on the other PCs to find the differences. The output file needs to contain the timestamp, of course, so it would be produced with something like:

procedure SaveScan(files: TStringlist; const filename: string);
var
f: textfile;
i: Integer;
begin
assignfile(f, filename);
rewrite(f);
try
for i = 0 to files.count - 1 do
writeLn(f, Format('%p%s', [pointer(files.Objects[i]), files[i]]));
finally
closefile(f);
end;
end;

Reading the list back would be:

procedure LoadScan(files: TStringlist; const filename: string);
var
f: textfile;
S: string;
begin
assignfile(f, filename);
reset(f);
try
files.clear;
while not EOF(f) do
begin
files.AddObject(Copy(S, 9, Maxint), TObject(StrToInt('\$' + Copy(S, 1, 8))));
end;
finally
Closefile(f);
end;
end;

Ok, on the other PCs you repeat the scan to build the list of files on that PC, you load the master list into another TStringlist, sort both lists and then compare them item by item. How complex that can get depends on what kinds of differences you expect to find. If there can be missing and extra files in addition to changed ones it gets a bit intricate but not too daunting. It goes like this:

You define two counters for the two lists, lets call them mi for the master list and li for the "local" list to compare it to. Both start out at 0.

while (mi < masterlist.count) do
begin
if masterlist[mi] = locallist[li] then
begin
{compare the two objects properties, if not equal report the file as changed}
Inc(mi);
Inc(li);
end
else if masterlist[mi] < locallist[li] then
begin
{report masterlist[mi] as missing}
Inc(mi);
end
else
begin
{report locallist[li] as extra}
Inc(li);
end;
if mi >= masterlist.count then
{report any remaining files in locallist as extra}
if li >= locallist.count then
{report any remaining files in masterlist as missing and increment mi for each,
so the loop is terminated}
end;

## 2005. február 5., szombat

### How to autosize columns in a TDBGrid

Problem/Question/Abstract:

How to autosize columns in a TDBGrid

This procedure will let you define the general layout of the grid at design-time by creating static columns for the grid, confident that proportions between columns will be maintained at run-time regardless of whether the user resizes the grid. To enable this new feature, disable column sizing for the grid (dgColSizing set to False in the grid options) and make a call to the new procedure in the OnResize event of the form holding the grid.

interface

uses
Windows, Forms, DBGrids;

implementation

var
TotalColumnWidth, ColumnCount, GridClientWidth, Filler, i: Integer;
begin
ColumnCount := DBGrid.Columns.Count;
if ColumnCount = 0 then
Exit;
{compute total width used by grid columns and vertical lines if any}
TotalColumnWidth := 0;
for i := 0 to ColumnCount - 1 do
TotalColumnWidth := TotalColumnWidth + DBGrid.Columns[i].Width;
if dgColLines in DBGrid.Options then
{include vertical lines in total (one per column)}
TotalColumnWidth := TotalColumnWidth + ColumnCount;
{compute grid client width by excluding vertical scrollbar, grid indicator and grid border}
GridClientWidth := DBGrid.Width - GetSystemMetrics(SM_CXVSCROLL);
if dgIndicator in DBGrid.Options then
begin
GridClientWidth := GridClientWidth - IndicatorWidth;
if dgColLines in DBGrid.Options then
Dec(GridClientWidth);
end;
if DBGrid.BorderStyle = bsSingle then
begin
if DBGrid.Ctl3D then {border is sunken (vertical border is 2 pixels wide)}
GridClientWidth := GridClientWidth - 4
else {border is one-dimensional (vertical border is one pixel wide)}
GridClientWidth := GridClientWidth - 2;
end;
if TotalColumnWidth < GridClientWidth then
begin
Filler := (GridClientWidth - TotalColumnWidth) div ColumnCount;
for i := 0 to ColumnCount - 1 do
DBGrid.Columns[i].Width := DBGrid.Columns[i].Width + Filler;
end
else if TotalColumnWidth > GridClientWidth then
begin
Filler := (TotalColumnWidth - GridClientWidth) div ColumnCount;
if (TotalColumnWidth - GridClientWidth) mod ColumnCount <> 0 then
Inc(Filler);
for i := 0 to ColumnCount - 1 do
DBGrid.Columns[i].Width := DBGrid.Columns[i].Width - Filler;
end;
end;

## 2005. február 4., péntek

Problem/Question/Abstract:

Another piece of code to determine your machine's local IP number - the function GetLocalIP returns it as a string.

function LWToIP(LW: LongWord): string;
begin
Result := IntToStr(LW and \$FF);
LW := LW shr 8;
Result := Result + '.' + IntToStr(LW and \$FF);
LW := LW shr 8;
Result := Result + '.' + IntToStr(LW and \$FF);
LW := LW shr 8;
Result := Result + '.' + IntToStr(LW and \$FF);
end;

function TForm1.GetLocalIP: string;
var
name, A: PChar;
h: hostent;
I: Integer;
begin
GetMem(name, 255);
try
I := GetHostName(name, 255);
if I <> 0 then
I := wsagetlastError;
if I <> 0 then
StatusBar1.Panels[0].Text := 'Error: ' + IntToStr(I)
else
begin
h := GetHostByName(name)^;
if h.h_length <> 4 then
Result := ''
else
begin
I := 0;
while (A^ <> #0) and (CompareStr(A, h.h_name) <> 0) do
begin
inc(I, 4);
Inc(A, 4)
end;
if I < 4 then
begin
Result := h.h_name
end
else
begin
while I >= 4 do
begin
Dec(A, 4);
Dec(I, 4);
Result := Result + LWToIP(PLongWord(A)^) + ', ';
end;
Delete(Result, Length(Result) - 1, 2);
end
end
end
finally
FreeMem(name)
end
end;

## 2005. február 3., csütörtök

### PCX Image Component

Problem/Question/Abstract:

PCX image component. Fully supports reading and writing of: 1, 8 and 24 bit PCX images.

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                           =========                               //
//                                                                   //
// Completed: The 10th of August 2001                                //
// Author:    M. de Haan                                             //
// Email:     M.deHaan@inn.nl                                        //
// Tested:    under W95 SP1, NT4 SP6, WIN2000                        //
// Version:   1.0                                                    //
//-------------------------------------------------------------------//
// Update:    The 14th of August 2001 to version 1.1.                //
// Reason:    Added version check.                                   //
//            Added comment info on version.                         //
//            Changed PCX header ID check.                           //
//-------------------------------------------------------------------//
// Update:    The 19th of August 2001 to version 2.0.                //
// Reason:    Warning from Delphi about using abstract methods,      //
//            caused by not implementing ALL TGraphic methods.       //
//            (Thanks goes to R.P. Sterkenburg for his diagnostic.)  //
//            GetEmpty.                                              //
//-------------------------------------------------------------------//
// Update:    The 13th of October 2001 to version 2.1.               //
// Reason:    strange errors, read errors, EExternalException, IDE   //
//            hanging, Delphi hanging, Debugger hanging, windows     //
//            hanging, keyboard locked, and so on.                   //
// Changed:   Assign procedure.                                      //
//-------------------------------------------------------------------//
// Update:    The 5th of April 2002 to version 2.2.                  //
// Changed:   RLE compressor routine.                                //
// Reason:    Incompatibility problems with other programs caused    //
//            by the RLE compressor.                                 //
//            Other programs encode: \$C0 as: \$C1 \$C0.                //
//            (\$C0 means: repeat the following byte 0 times          //
//            \$C1 means: repeat the following byte 1 time.)          //
// Changed:   File read routine.                                     //
// Reason:    Now detects unsupported PCX data formats.              //
// Added:     'Unsupported data format' in exception handler.        //
// Renamed:   Procedure ConvertPCXDataToImage to                     //
//            Convert24BitPCXDataToImage.                            //
//-------------------------------------------------------------------//
// Update:    The 14th of April 2002 to version 2.3.                 //
//            Now capable of reading and writing 1 and 24 bit PCX    //
//            images.                                                //
// Added:     1 bit PCX support in writing.                          //
// Changed:   Procedure TPCXImage.SaveToFile.                        //
//-------------------------------------------------------------------//
// Update:    The 19th of April 2002 to version 2.4.                 //
//            Now capable of reading and writing: 1, 8 and 24 bit    //
//            PCX images.                                            //
// Renamed:   Procedure ConvertImageTo1And8bitPCXData.               //
// Renamed:   Procedure Convert1And8bitPCXDataToImage.               //
// Changed:   Procedure fSetPalette, fGetPalette.                    //
//-------------------------------------------------------------------//
// Update:    The 7th of May 2002 to version 2.5.                    //
// Reason:    The palette of 8-bit PCX images couldn't be read in    //
//            the calling program.                                   //
// Changed:   Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
// Tested:    All formats were tested with the following programs:   //
//            - import in Word 97,                                   //
//            * (Word ignores the palette of 1 bit PCX images!)      //
//            - import and export in MigroGrafX.                     //
//            * (MicroGrafX also ignores the palette of 1 bit PCX    //
//              images.)                                             //
//            No problems were detected.                             //
//                                                                   //
//===================================================================//
//                                                                   //
//         The PCX image file format is copyrighted by:              //
//           ZSoft, PC Paintbrush, PC Paintbrush plus                //
//                       Royalty fees: NONE                          //
//                                                                   //
//===================================================================//
//                                                                   //
// The author can not be held responsable for using this software    //
// in anyway.                                                        //
//                                                                   //
// The features and restrictions of this component are:              //
// ----------------------------------------------------              //
//                                                                   //
// The reading and writing (import / export) of files / images:      //
//     - PCX version 5 definition, PC Paintbrush 3 and higher,       //
//     - RLE-compressed,                                             //
//     - 1 and 8 bit PCX images WITH palette and                     //
//     - 24 bit PCX images without palette,                          //
//     are supported by this component.                              //
//                                                                   //
// Known issues                                                      //
// ------------                                                      //
//                                                                   //
// 1) GetEmpty is NOT tested.                                        //
//                                                                   //
// 2) SaveToClipboardFormat is NOT tested.                           //
//                                                                   //
// 3) LoadFromClipboardFormat is NOT tested.                         //
//                                                                   //
// 4) 4 bit PCX images (with palette) are NOT (yet) implemented.     //
//    (I have no 4-bit PCX images to test it on...)                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////

unit
PCXImage;

interface

uses
Windows,
SysUtils,
Classes,
Graphics;

const
WIDTH_OUT_OF_RANGE = 'Illegal width entry in PCX file header';
HEIGHT_OUT_OF_RANGE = 'Illegal height entry in PCX file header';
FILE_FORMAT_ERROR = 'Invalid file format';
VERSION_ERROR = 'Only PC Paintbrush (plus) V3.0 and ' +
'higher are supported';
FORMAT_ERROR = 'Illegal identification byte in PCX file' +
PALETTE_ERROR = 'Invalid palette signature found';
ASSIGN_ERROR = 'Can only Assign a TBitmap or a TPicture';
ASSIGNTO_ERROR = 'Can only AssignTo a TBitmap';
PCXIMAGE_EMPTY = 'The PCX image is empty';
BITMAP_EMPTY = 'The bitmap is empty';
INPUT_FILE_TOO_LARGE = 'The input file is too large to be read';
IMAGE_WIDTH_TOO_LARGE = 'Width of PCX image is too large to handle';
CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
PCX_WIDTH_ERROR = 'Unexpected line length in PCX data';
PCX_HEIGHT_ERROR = 'More PCX data found than expected';
PCXIMAGE_TOO_LARGE = 'PCX image is too large';
ERROR_UNSUPPORTED = 'Unsupported PCX format';

const
sPCXImageFile = 'PCX V3.0+ image';

var
CF_PCX: WORD;

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                                                                   //
///////////////////////////////////////////////////////////////////////

type
QWORD = Cardinal; // Seems more logical to me...

type
fColorEntry = packed record
ceRed: BYTE;
ceGreen: BYTE;
ceBlue: BYTE;
end; // of packed record fColorEntry

type
fID: BYTE;
fVersion: BYTE;
fCompressed: BYTE;
fBitsPerPixel: BYTE;
fWindow: packed record
wLeft,
wTop,
wRight,
wBottom: WORD;
end; // of packed record fWindow
fHorzResolution: WORD;
fVertResolution: WORD;
fColorMap: array[0..15] of fColorEntry;
fReserved: BYTE;
fPlanes: BYTE;
fBytesPerLine: WORD;
fPaletteInfo: WORD;
fFiller: array[0..57] of BYTE;
end; // of packed record TPCXImageHeader

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                             PCXData                               //
//                                                                   //
///////////////////////////////////////////////////////////////////////

type
TPCXData = object
fData: array of BYTE;
end; // of Type TPCXData

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                             ScanLine                              //
//                                                                   //
///////////////////////////////////////////////////////////////////////

const
fMaxScanLineLength = \$FFF; // Max image width: 4096 pixels

type
mByteArray = array[0..fMaxScanLineLength] of BYTE;
pmByteArray = ^mByteArray;

// The "standard" pByteArray from Delphi allocates 32768 bytes,
// which is a little bit overdone here, I think...

const
fMaxImageWidth = \$FFF; // Max image width: 4096 pixels

type
xByteArray = array[0..fMaxImageWidth] of BYTE;

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                          PCXPalette                               //
//                                                                   //
///////////////////////////////////////////////////////////////////////

type
TPCXPalette = packed record
fSignature: BYTE;
fPalette: array[0..255] of fColorEntry;
end; // of packed record TPCXPalette

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                             Classes                               //
//                                                                   //
///////////////////////////////////////////////////////////////////////

type
TPCXImage = class;
TPCXFile = class;

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           PCXFile                                 //
//                                                                   //
//                         File handler                              //
//                                                                   //
///////////////////////////////////////////////////////////////////////

TPCXFile = class(TPersistent)

private
fHeight: Integer;
fWidth: Integer;
fPCXData: TPCXData;
fPCXPalette: TPCXPalette;
fColorDepth: QWORD;
fCurrentPos: QWORD;

protected
// Protected declarations

public
// Public declarations
constructor Create;
destructor Destroy; override;
procedure SaveToFile(const Filename: string);
procedure SaveToStream(Stream: TStream);

published
// Published declarations
// The publishing is done in the TPCXImage section

end;

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                         TPCXImage                                 //
//                                                                   //
//                       Image handler                               //
//                                                                   //
///////////////////////////////////////////////////////////////////////

TPCXImage = class(TGraphic)

private
// Private declarations
fBitmap: TBitmap;
fPCXFile: TPCXFile;
fRLine: xByteArray;
fGLine: xByteArray;
fBLine: xByteArray;
fP: pmByteArray;
fhPAL: HPALETTE;

procedure fConvert24BitPCXDataToImage;
procedure fConvert1And8BitPCXDataToImage;
procedure fConvertImageTo24BitPCXData;
procedure fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
QWORD);
procedure fFillDataLines(const fLine: array of BYTE);
const byPlanes: BYTE; const wBytesPerLine: DWORD);
procedure fSetPalette(const wNumColors: WORD);
procedure fGetPalette(const wNumColors: WORD);
function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
function fGetBitmap: TBitmap; // Added 07/05/2002

protected
// Protected declarations
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure SetHeight(Value: Integer); override;
procedure SetWidth(Value: Integer); override;
function GetEmpty: Boolean; override;

public
// Public declarations
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
procedure SaveToFile(const Filename: string); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE); override;

published
// Published declarations
property Height: Integer
property Width: Integer
property PixelFormat: TPixelFormat
property Bitmap: TBitmap

end;

implementation

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                                                                   //
//                         Image handler                             //
//                                                                   //
///////////////////////////////////////////////////////////////////////

constructor TPCXImage.Create;

begin
inherited Create;
// Init HPALETTE
fhPAL := 0;

// Create a private bitmap to hold the image
if not Assigned(fBitmap) then
fBitmap := TBitmap.Create;

// Create the PCXFile
if not Assigned(fPCXFile) then
fPCXFile := TPCXFile.Create;

end;
//---------------------------------------------------------------------

destructor TPCXImage.Destroy;

begin
// Reversed order of create
// Free fPCXFile
fPCXFile.Free;
// Free private bitmap
fBitmap.Free;
// Delete palette
if fhPAL <> 0 then
DeleteObject(fhPAL);
// Distroy all the other things
inherited Destroy;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SetHeight(Value: Integer);

begin
if Value >= 0 then
fBitmap.Height := Value;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SetWidth(Value: Integer);

begin
if Value >= 0 then
fBitmap.Width := Value;
end;
//---------------------------------------------------------------------

function TPCXImage.GetHeight: Integer;

begin
Result := fPCXFile.fHeight;
end;
//---------------------------------------------------------------------

function TPCXImage.GetWidth: Integer;

begin
Result := fPCXFile.fWidth;
end;
//---------------------------------------------------------------------

function TPCXImage.fGetBitmap: TBitmap;

begin
Result := fBitmap;
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
//-------------------------------------------------------------------//
// NOT TESTED!

var
Size: QWORD;
Buf: Pointer;
Stream: TMemoryStream;
BMP: TBitmap;

begin
if (AData <> 0) and (AFormat = CF_PCX) then
begin
try
Stream := TMemoryStream.Create;
try
Stream.SetSize(Size);
Move(Buf^, Stream.Memory^, Size);
finally
Stream.Free;
end;
finally

end;
end
else if (AData <> 0) and (AFormat = CF_BITMAP) then
begin
BMP := TBitmap.Create;
try
Self.Assign(BMP);
finally
BMP.Free;
end;
end
else
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
//-------------------------------------------------------------------//
// NOT TESTED!

procedure TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE);

var
Stream: TMemoryStream;
Data: THandle;
Buf: Pointer;

begin
if Empty then
Exit;
// First store the bitmap to the clipboard
// Then try to save the PCX
Stream := TMemoryStream.Create;
try
SaveToStream(Stream);
Stream.Position := 0;
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
try
if Data <> 0 then
begin
Buf := GlobalLock(Data);
try
Move(Stream.Memory^, Buf^, Stream.Size);
finally
GlobalUnlock(Data);
end;
if SetClipBoardData(CF_PCX, Data) = 0 then
raise Exception.Create(CLIPBOARD_SAVE_ERROR);
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
end;
//-------------------------------------------------------------------//
// NOT TESTED!

function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002

begin
if Assigned(fBitmap) then
Result := fBitmap.Empty
else
Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
end;
//---------------------------------------------------------------------

procedure TPCXImage.SaveToFile(const Filename: string);

var
fPCX: TFileStream;
W, WW: QWORD;

begin
if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
raise Exception.Create(BITMAP_EMPTY);
W := fBitmap.Width;
WW := W div 8;
if (W mod 8) > 0 then
Inc(WW);
case fBitmap.PixelFormat of
pf1bit:
begin
// Fully supported by PCX and by this component
fConvertImageTo1And8BitPCXData(WW);
fGetPalette(2);
end;
pf4bit:
begin
// I don't have 4-bit PCX images to test with
// It will be treated as a 24 bit image
fConvertImageTo24BitPCXData;
end;
pf8bit:
begin
// Fully supported by PCX and by this component
fConvertImageTo1And8BitPCXData(W);
fGetPalette(256);
end;
pf15bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fConvertImageTo24BitPCXData;
end;
pf16bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fConvertImageTo24BitPCXData;
end;
pf24bit:
begin
// Fully supported by PCX and by this component
fConvertImageTo24BitPCXData;
end;
pf32bit:
begin
// Not supported by PCX
fConvertImageTo24BitPCXData;
end;
else
begin
fConvertImageTo24BitPCXData;
end; // of else
end; // of Case
fPCX := TFileStream.Create(Filename, fmCreate);
try
fPCX.Position := 0;
SaveToStream(fPCX);
finally
fPCX.Free;
end; // of finally
SetLength(fPCXFile.fPCXData.fData, 0);
end; // of Procedure SaveToFile
//-------------------------------------------------------------------//

procedure TPCXImage.AssignTo(Dest: TPersistent);

var
bAssignToError: Boolean;

begin
bAssignToError := True;

if Dest is TBitmap then
begin
// The old AssignTo procedure was like this.
// But then the palette was couldn't be accessed in the calling
// program for some reason.
// --------------------------
// (Dest as TBitmap).Assign(fBitmap);
// If fBitmap.Palette <> 0 then
//    (Dest as TBitmap).Palette := CopyPalette(fBitmap.Palette);
// --------------------------

// Do the assigning
(Dest as TBitmap).Assign(fBitmap);

if fPCXFile.fHasPalette then
(Dest as TBitmap).Palette := CopyPalette(fhPAL);
// Now the calling program can access the palette
// (if it has one)!
bAssignToError := False;
end;

if Dest is TPicture then
begin
(Dest as TPicture).Graphic.Assign(fBitmap);
bAssignToError := False;
end;

if bAssignToError then
raise Exception.Create(ASSIGNTO_ERROR);

// You can write other assignments here, if you want...

end;
//-------------------------------------------------------------------//

procedure TPCXImage.Assign(Source: TPersistent);

var
iX, iY: DWORD;
bAssignError: Boolean;

begin
bAssignError := True;

if (Source is TBitmap) then
begin
fBitmap.Assign(Source as TBitmap);
if (Source as TBitmap).Palette <> 0 then
begin
fhPAL := CopyPalette((Source as TBitmap).Palette);
fBitmap.Palette := fhPAL;
end;
bAssignError := False;
end;

if (Source is TPicture) then
begin
iX := (Source as TPicture).Width;
iY := (Source as TPicture).Height;
fBitmap.Width := iX;
fBitmap.Height := iY;
fBitmap.Canvas.Draw(0, 0, (Source as TPicture).Graphic);
bAssignError := False;
end;

// You can write other assignments here, if you want...

if bAssignError then
raise Exception.Create(ASSIGN_ERROR);

end;
//---------------------------------------------------------------------

procedure TPCXImage.Draw(ACanvas: TCanvas; const Rect: TRect);

begin
// Faster
// ACanvas.Draw(0,0,fBitmap);

// Slower
ACanvas.StretchDraw(Rect, fBitmap);
end;
//---------------------------------------------------------------------

begin
case fPCXFile.fPixelFormat of
1: fConvert1And8BitPCXDataToImage;
8: fConvert1And8BitPCXDataToImage;
24: fConvert24BitPCXDataToImage;
end;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SaveToStream(Stream: TStream);

begin
fPCXFile.SaveToStream(Stream);
end;
//---------------------------------------------------------------------

begin
end;
///////////////////////////////////////////////////////////////////////
//                                                                   //
//                       Called by RLE compressor                    //
//                                                                   //
///////////////////////////////////////////////////////////////////////

procedure TPCXImage.fFillDataLines(const fLine: array of BYTE);

var
By: BYTE;
Cnt: WORD;
I: QWORD;
W: QWORD;

begin
I := 0;
By := fLine[0];
Cnt := \$C1;
W := fBitmap.Width;

repeat

Inc(I);

if By = fLine[I] then
begin
Inc(Cnt);
if Cnt = \$100 then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] :=
BYTE(Pred(Cnt));
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
Cnt := \$C1;
By := fLine[I];
end;
end;

if (By <> fLine[I]) then
begin
if (Cnt = \$C1) then
begin
// If (By < \$C1) then
if (By < \$C0) then // changed 5/4/2002
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end
else
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end;
end
else
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end;

Cnt := \$C1;
By := fLine[I];
end;

until I = W - 1;

// Write the last byte(s)
if (Cnt > \$C1) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
end;

if (Cnt = \$C1) and (By > \$C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
end;

fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);

end;
//-------------------------------------------------------------------//
//                  RLE Compression algorithm                        //
//-------------------------------------------------------------------//

procedure TPCXImage.fConvertImageTo24BitPCXData; // Renamed 5/4/2002

var
H, W: QWORD;
X, Y: QWORD;
I: QWORD;

begin
H := fBitmap.Height;
W := fBitmap.Width;
fPCXFile.fCurrentPos := 0;
SetLength(fPCXFile.fPCXData.fData, 6 * H * W); // To be sure...
fBitmap.PixelFormat := pf24bit; // Always do this if you're using
// ScanLine!

for Y := 0 to H - 1 do
begin
fP := fBitmap.ScanLine[Y];
I := 0;
for X := 0 to W - 1 do
begin
fRLine[X] := fP[I];
Inc(I); // Extract a red line
fGLine[X] := fP[I];
Inc(I); // Extract a green line
fBLine[X] := fP[I];
Inc(I); // Extract a blue line
end;

fFillDataLines(fBLine); // Compress the blue line
fFillDataLines(fGLine); // Compress the green line
fFillDataLines(fRLine); // Compress the red line

end;

// Correct the length of fPCXData.fData
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//

procedure TPCXImage.fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
QWORD);

var
H, W, X, Y: QWORD;
oldByte, newByte: BYTE;
Cnt: BYTE;

begin
H := fBitmap.Height;
W := ImageWidthInBytes;
fPCXFile.fCurrentPos := 0;
SetLength(fPCXFile.fPCXData.fData, 2 * H * W); // To be sure...
oldByte := 0; // Otherwise the compiler issues a warning about
// oldByte not being initialized...
Cnt := \$C1;
for Y := 0 to H - 1 do
begin
fP := fBitmap.ScanLine[Y];
for X := 0 to W - 1 do
begin

newByte := fP[X];

if X > 0 then
begin
if (Cnt = \$FF) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
Cnt := \$C1;
end
else if newByte = oldByte then
Inc(Cnt);

if newByte <> oldByte then
begin
if (Cnt > \$C1) or (oldByte >= \$C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
Cnt := \$C1;
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
end;

end;
oldByte := newByte;
end;
// Write last byte of line
if (Cnt > \$C1) or (oldByte >= \$C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
Cnt := \$C1;
end;

fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
end;

// Write last byte of image
if (Cnt > \$C1) or (oldByte >= \$C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
// Cnt := 1;
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);

// Correct the length of fPCXData.fData
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
//                  RLE Decompression algorithm                      //
//-------------------------------------------------------------------//

procedure TPCXImage.fConvert24BitPCXDataToImage; // Renamed 5/4/2002

var

I: QWORD;
By: BYTE;
Cnt: BYTE;
H, W: QWORD;
X, Y: QWORD;
K, L: QWORD;

begin
Y := 0; // First line of image
fBitmap.Width := W; // Set bitmap width
fBitmap.Height := H; // Set bitmap height
fBitmap.PixelFormat := pf24bit; // Always do this if you're using
// ScanLine!
I := 0; // Pointer to data byte of fPXCFile
repeat

// Process the red line
// ProcessLine(fRLine,W);

X := 0; // Pointer to position in Red / Green / Blue line
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);

// one byte
if By < \$C1 then
if X <= W then // added 5/4/2002
begin
fRLine[X] := By;
Inc(X);
end;

// multiple bytes (RLE)
if By > \$C0 then
begin
Cnt := By and \$3F;

By := fPCXFile.fPCXData.fData[I];
Inc(I);

//FillChar(fRLine[J],Cnt,By);
//Inc(J,Cnt);

for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fRLine[X] := By;
Inc(X);
end;

end;

until X >= W;

// Process the green line
// ProcessLine(fGLine,W);

X := 0;
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);

// one byte
if By < \$C1 then
if X <= W then // added 5/4/2002
begin
fGLine[X] := By;
Inc(X);
end;

// multiple bytes (RLE)
if By > \$C0 then
begin
Cnt := By and \$3F;

By := fPCXFile.fPCXData.fData[I];
Inc(I);

for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fGLine[X] := By;
Inc(X);
end;

end;

until X >= W;

// Process the blue line
// ProcessLine(fBLine,W);

X := 0;
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);

// one byte
if By < \$C1 then
if X <= W then // added 5/4/2002
begin
fBLine[X] := By;
Inc(X);
end;

// multiple bytes (RLE)
if By > \$C0 then
begin
Cnt := By and \$3F;

By := fPCXFile.fPCXData.fData[I];
Inc(I);

for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fBLine[X] := By;
Inc(X);
end;

end;

until X >= W;

// Write the just processed data RGB lines to the bitmap
fP := fBitmap.ScanLine[Y];
L := 0;
for X := 0 to W - 1 do
begin
fP[L] := fBLine[X];
Inc(L);
fP[L] := fGLine[X];
Inc(L);
fP[L] := fRLine[X];
Inc(L);
end;

Inc(Y); // Process the next RGB line

until Y >= H;

SetLength(fPCXFile.fPCXData.fData, 0);
end;
//-------------------------------------------------------------------//

var
I, J: QWORD;
By: BYTE;
Cnt: BYTE;
H, W, WW: QWORD;
X, Y: QWORD;

begin
fBitmap.Width := W; // Set bitmap width
fBitmap.Height := H; // Set bitmap height
WW := W;

// 1 bit PCX
if fPCXFile.fPixelFormat = 1 then
begin
// All 1 bit images have a palette
fBitmap.PixelFormat := pf1bit; // Always do this if you're using
// ScanLine!
WW := W div 8; // Correct width for pf1bit
if W mod 8 > 0 then
begin
Inc(WW);
fBitMap.Width := WW * 8;
end;
fSetPalette(2);
end;

// 8 bit PCX
if fPCXFile.fPixelFormat = 8 then
begin
// All 8 bit images have a palette!
// This is how to set the palette of a bitmap
// 1. First set the bitmap to pf8bit;
// 2. then set the palette of the bitmap;
// 3. then set the pixels with ScanLine or with Draw.
// If you do it with StretchDraw, it won't work. Don't ask me why.
// If you don't do it in this order, it won't work either! You'll
// get strange colors.
fBitmap.PixelFormat := pf8bit; // Always do this if you're using
// ScanLine!
fSetPalette(256);
end;

I := 0;
Y := 0;
repeat
fP := fBitmap.ScanLine[Y];
X := 0; // Pointer to position in line
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);

// one byte
if By < \$C1 then
if X <= WW then
begin
fP[X] := By;
Inc(X);
end;

// multiple bytes (RLE)
if By > \$C0 then
begin
Cnt := By and \$3F;

By := fPCXFile.fPCXData.fData[I];
Inc(I);

for J := 1 to Cnt do
if X <= WW then
begin
fP[X] := By;
Inc(X);
end;

end;

until X >= WW;

Inc(Y); // Next line

until Y >= H;
end;
//---------------------------------------------------------------------

const byPlanes: BYTE; const wBytesPerLine: DWORD);

var
H, W: WORD;

begin
W := fBitmap.Width;
H := fBitmap.Height;

fPCXFile.fPCXHeader.fID := BYTE(\$0A); // BYTE (1)
fPCXFile.fPCXHeader.fVersion := BYTE(5); // BYTE (2)
fPCXFile.fPCXHeader.fCompressed := BYTE(1); // BYTE (3)
// 0 = uncompressed, 1 = compressed
// Only RLE compressed files are supported by this component
// BYTE (4)
fPCXFile.fPCXHeader.fWindow.wLeft := WORD(0); // WORD (5,6)
fPCXFile.fPCXHeader.fWindow.wTop := WORD(0); // WORD (7,8)
fPCXFile.fPCXHeader.fWindow.wRight := WORD(W - 1); // WORD (9,10)
fPCXFile.fPCXHeader.fWindow.wBottom := WORD(H - 1); // WORD (11,12)
fPCXFile.fPCXHeader.fHorzResolution := WORD(72); // WORD (13,14)
fPCXFile.fPCXHeader.fVertResolution := WORD(72); // WORD (15,16)

FillChar(fPCXFile.fPCXHeader.fColorMap, 48, 0); // Array of Byte
// (17..64)

fPCXFile.fPCXHeader.fReserved := BYTE(0); // BYTE (65)
// BYTE (66)
// WORD (67,68)
// must be even
// rounded above
fPCXFile.fPCXHeader.fPaletteInfo := WORD(1); // WORD (69,70)

FillChar(fPCXFile.fPCXHeader.fFiller, 58, 0); // Array of Byte
// (71..128)

fPCXFile.fColorDepth := 1 shl fPCXFile.fPixelFormat;
end;
//---------------------------------------------------------------------
(*
// From Delphi 5.0, graphics.pas
Function CopyPalette(Palette: HPALETTE): HPALETTE;

Var
PaletteSize    : Integer;
LogPal         : TMaxLogPalette;

Begin
Result := 0;
If Palette = 0 then
Exit;
PaletteSize := 0;
If GetObject(Palette,SizeOf(PaletteSize),@PaletteSize) = 0 then
Exit;
If PaletteSize = 0 then
Exit;
With LogPal do
Begin
palVersion := \$0300;
palNumEntries := PaletteSize;
GetPaletteEntries(Palette,0,PaletteSize,palPalEntry);
End;
Result := CreatePalette(PLogPalette(@LogPal)^);
End;
*)
//---------------------------------------------------------------------
// From Delphi 5.0, graphics.pas
(*
Procedure TPCXImage.fSetPixelFormat(Value : TPixelFormat);

Const
BitCounts : Array [pf1Bit..pf32Bit] of BYTE = (1,4,8,16,16,24,32);

Var
DIB     : TDIBSection;
Pal     : HPALETTE;
DC      : hDC;
KillPal : Boolean;

Begin
If Value = GetPixelFormat then
Exit;
Case Value of
pfDevice : Begin
HandleType := bmDDB;
Exit;
End;
pfCustom : InvalidGraphic(@SInvalidPixelFormat);
else
FillChar(DIB,sizeof(DIB), 0);

DIB.dsbm := FImage.FDIB.dsbm;
KillPal := False;
With DIB, dsbm,dsbmih do
Begin
bmBits := nil;
biSize := SizeOf(DIB.dsbmih);
biWidth := bmWidth;
biHeight := bmHeight;
biPlanes := 1;
biBitCount := BitCounts[Value];
Pal := FImage.FPalette;
Case Value of
pf4Bit  : Pal := SystemPalette16;
pf8Bit  : Begin
DC := GDICheck(GetDC(0));
Pal := CreateHalftonePalette(DC);
KillPal := True;
ReleaseDC(0, DC);
End;
pf16Bit : Begin
biCompression := BI_BITFIELDS;
dsBitFields[0] := \$F800;
dsBitFields[1] := \$07E0;
dsBitFields[2] := \$001F;
End;
End; // of Case
Try
CopyImage(Handle, Pal, DIB);
PaletteModified := (Pal <> 0);
Finally
if KillPal then
DeleteObject(Pal);
End; // of Try
Changed(Self);
End; // of With
End; // of Case
End; // of Procedure
*)
//---------------------------------------------------------------------

procedure TPCXImage.fSetPalette(const wNumColors: WORD);

(* From Delphi 5.0, graphics.pas

Type
TPalEntry = packed record
peRed     : BYTE;
peGreen   : BYTE;
peBlue    : BYTE;
End;

Type
tagLOGPALETTE = packed record
palVersion     : WORD;
palNumEntries  : WORD;
palPalEntry    : Array[0..255] of TPalEntry
End;

Type
TMAXLogPalette = tagLOGPALETTE;
PMAXLogPalette = ^TMAXLogPalette;

Type

Type
*)

var
pal: TMaxLogPalette;
W: WORD;

begin
pal.palVersion := \$300; // The "Magic" number
pal.palNumEntries := wNumColors;
for W := 0 to 255 do
begin
pal.palPalEntry[W].peRed :=
fPCXFile.fPCXPalette.fPalette[W].ceRed;
pal.palPalEntry[W].peGreen :=
fPCXFile.fPCXPalette.fPalette[W].ceGreen;
pal.palPalEntry[W].peBlue :=
fPCXFile.fPCXPalette.fPalette[W].ceBlue;
pal.palPalEntry[W].peFlags := 0;
end;

(* Must we delete the old palette first here? I don't know.
If fhPAL <> 0 then
DeleteObject(fhPAL);
*)

fhPAL := CreatePalette(PLogPalette(@pal)^);
if fhPAL <> 0 then
fBitmap.Palette := fhPAL;
end;
//---------------------------------------------------------------------

function TPCXImage.fGetPixelFormat: TPixelFormat;

// Only pf1bit, pf4bit and pf8bit images have a palette.
// pf15bit, pf16bit, pf24bit and pf32bit images have no palette.
// You can change the palette of pf1bit images in windows.
// The foreground color and the background color of pf1bit images
// do not have to be black and white. You can choose any tow colors.
// The palette of pf4bit images is fixed.
// The palette entries 0..9 and 240..255 of pf8bit images are reserved
// in windows.
begin
Result := pfDevice;
case fPCXFile.fPixelFormat of
01: Result := pf1bit; // Implemented WITH palette.
// 04 : Result :=  pf4bit; // Not yet implemented in this component,
// is however implemented in PCX format.
08: Result := pf8bit; // Implemented WITH palette.
// 15 : Result := pf15bit; // Not implemented in PCX format?
// 16 : Result := pf16bit; // Not implemented in PCX format?
24: Result := pf24bit; // Implemented, has no palette.
// 32 : Result := pf32bit; // Not implemented in PCX format.
end;
end;
//---------------------------------------------------------------------

procedure TPCXImage.fGetPalette(const wNumColors: WORD);

var
pal: TMaxLogPalette;
W: WORD;

begin
fPCXFile.fPCXPalette.fSignature := \$0C;

pal.palVersion := \$300; // The "Magic" number
pal.palNumEntries := wNumColors;
GetPaletteEntries(CopyPalette(fBitmap.Palette), 0, wNumColors,
pal.palPalEntry);
for W := 0 to 255 do
if W < wNumColors then
begin
fPCXFile.fPCXPalette.fPalette[W].ceRed :=
pal.palPalEntry[W].peRed;
fPCXFile.fPCXPalette.fPalette[W].ceGreen :=
pal.palPalEntry[W].peGreen;
fPCXFile.fPCXPalette.fPalette[W].ceBlue :=
pal.palPalEntry[W].peBlue;
end
else
begin
fPCXFile.fPCXPalette.fPalette[W].ceRed := 0;
fPCXFile.fPCXPalette.fPalette[W].ceGreen := 0;
fPCXFile.fPCXPalette.fPalette[W].ceBlue := 0;
end;
end;
//=====================================================================

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                         TPCXFile                                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////

constructor TPCXFile.Create;

begin
inherited Create;
fHeight := 0;
fWidth := 0;
fCurrentPos := 0;
end;
//---------------------------------------------------------------------

destructor TPCXFile.Destroy;

begin
SetLength(fPCXData.fData, 0);
inherited Destroy;
end;
//---------------------------------------------------------------------

var
fPCXStream: TFileStream;

begin
try
fPCXStream.Position := 0;
finally
fPCXStream.Free;
end;
end;
//---------------------------------------------------------------------

procedure TPCXFile.SaveToFile(const Filename: string);

var
fPCXStream: TFileStream;

begin
fPCXStream := TFileStream.Create(Filename, fmCreate);
try
fPCXStream.Position := 0;
SaveToStream(fPCXStream);
finally
fPCXStream.Free;
end;
end;
//---------------------------------------------------------------------

var
fFileLength: Cardinal;

begin

// Check the ID byte
raise Exception.Create(FORMAT_ERROR);

(*
Check PCX version byte
======================
Versionbyte = 0 => PC PaintBrush V2.5
Versionbyte = 2 => PC Paintbrush V2.8 with palette information
Versionbyte = 3 => PC Paintbrush V2.8 without palette information
Versionbyte = 4 => PC Paintbrush for Windows
Versionbyte = 5 => PC Paintbrush V3 and up, and PC Paintbrush Plus
with 24 bit image support
*)
// Check the PCX version
raise Exception.Create(VERSION_ERROR);

// Calculate width
if fWidth < 0 then
raise Exception.Create(WIDTH_OUT_OF_RANGE);

// Calculate height
if fHeight < 0 then
raise Exception.Create(HEIGHT_OUT_OF_RANGE);

// Is it too large?
if fWidth > fMaxImageWidth then
raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);

// Calculate pixelformat

// Calculate number of colors
fColorDepth := 1 shl fPixelFormat;

// Is this image supported?
if not (fPixelFormat in [1, 8, 24]) then
raise Exception.Create(ERROR_UNSUPPORTED);

// The lines following are NOT tested!!!
(*
If fColorDepth <= 16 then
For I := 0 to fColorDepth - 1 do
Begin
Begin
End
else
Begin
End;
End;
*)

// Calculate number of data bytes

// If fFileLength > fMaxDataFileLength then
//    Raise Exception.Create(INPUT_FILE_TOO_LARGE);

if fPixelFormat = 24 then
begin
fFileLength := Stream.Size - Stream.Position;
SetLength(fPCXData.fData, fFileLength);
fHasPalette := False;
end;

if fPixelFormat in [1, 8] then
begin
fFileLength := Stream.Size - Stream.Position - 769;
SetLength(fPCXData.fData, fFileLength);
// Correct number of data bytes
fHasPalette := True;
// Check palette signature byte
if fPCXPalette.fSignature <> \$0C then
raise Exception.Create(PALETTE_ERROR);
end;

end;
//---------------------------------------------------------------------

procedure TPCXFile.SaveToStream(Stream: TStream);

begin
fHasPalette := False;
Stream.Write(fPCXData.fData[0], fCurrentPos);
if fPixelFormat in [1, 8] then
begin
Stream.Write(fPCXPalette, SizeOf(fPCXPalette));
fHasPalette := True;
end;
end;
//---------------------------------------------------------------------
// Register PCX format
initialization
TPicture.RegisterFileFormat('PCX', sPCXImageFile, TPCXImage);
CF_PCX := RegisterClipBoardFormat('PCX Image');
TPicture.RegisterClipBoardFormat(CF_PCX, TPCXImage);
//---------------------------------------------------------------------
// Unregister PCX format
finalization
TPicture.UnRegisterGraphicClass(TPCXImage);
//---------------------------------------------------------------------
end.
//=====================================================================