How to create a random string

Problem/Question/Abstract:

How to create a random string

Answer:

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
  {Check the maximum password length}
  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
      inc(N); {Not found }
      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;

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

Answer:

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.

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... ?

Answer:

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;

Fix a small bug in TLabel.AutoSize

Problem/Question/Abstract:

Fix a small bug in TLabel.AutoSize

Answer:

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;

How to draw checkboxes in a TDBGrid

Problem/Question/Abstract:

How to draw checkboxes in a TDBGrid

Answer:

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;

How to display memo fields in a TDBGrid

Problem/Question/Abstract:

How to display memo fields in a TDBGrid

Answer:

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
      BS := tBlobStream.Create(TBlobField(Field), bmRead);
      FillChar(P, SizeOf(P), #0); {terminate the null string}
      BS.Read(P, 50); {read 50 chars from memo into blobStream}
      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.

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.

Answer:

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;

Application Settings (article 2)

Problem/Question/Abstract:

Managing Application Settings

Answer:

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:

procedure TForm1.LoadSettings;
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);
      RichEditSettings.UpdateSettings(Editor);
      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

Download the code from this article here. Please be sure to read Install.txt included in the zip file before opening the project in Delphi.

How to get the number of files in a folder

Problem/Question/Abstract:

How to get the number of files in a folder

Answer:

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;

Get a name of enum value

Problem/Question/Abstract:

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

Answer:

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
    Combobox1.Items.Add(GetEnumName(TypeInfo(TyourEnumType), i));
end;

How to minimize a secondary-form to the taskbar

Problem/Question/Abstract:

How to minimize a secondary-form to the taskbar        

Answer:

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;

Sending e-mail with attachment using MS Outlook

Problem/Question/Abstract:

How to send e-mail with attachment using MS outlook

Answer:

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
    CurrentMailItem.Attachments.Add(MailDetail.FileToAttach, EmptyParam, EmptyParam,
      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.


Component Download: MailDemo.zip


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.Subject := 'Add Subject Here';
    OleItem.Recipients.Add('Recipients Here');
    OleItem.Attachments.Add('File Attachments Here');
    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;

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

Answer:

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
        ListBox1.Items.Add('Keypad Return pressed')
      else
        ListBox1.Items.Add('Regular Return pressed')
    end;
  end;
end;

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?

Answer:

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.

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!

Answer:

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    *}
{******************************************************}
{* Last Modified : 12-Nov-2000                        *}
{* 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;

  //Remove all adjacent duplicates
  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.

Retrieve a folder list from MS Outlook

Problem/Question/Abstract:

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

Answer:

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

procedure RetrieveOutlookFolders(tvFolders: TTreeView);

  procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
  var
    i: Integer;
    node: TTreeNode;
  begin
    for i := 1 to Folder.Count do
    begin
      node := tvFolders.Items.AddChild(ParentNode,
        Folder.Item[i].Name;

        LoadFolder(node, Folder.Item[i].Folders);
    end;
  end;

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

  LoadFolder(nil, NameSpace.Folders);

  outlook := UnAssigned;
end;

A few comments:

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.

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.

Answer:

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 ReadData(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;
  Filer.DefineBinaryProperty('TheData', ReadData, WriteData, true);
end;

procedure TBinaryData.ReadData;
var
  ASize: Longint;
begin
  Stream.Read(ASize, sizeof(ASize));
  if ASize > 0 then
  begin
    (MemStream as TMemoryStream).SetSize(ASize);
    Stream.Read((MemStream as TMemoryStream).Memory^, 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
    (MemStream as TMemoryStream).LoadFromStream(Stream)
  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
  Result := 'Load File...';
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
        FileStream := TFileStream.Create(OpenDialog.Filename, fmOpenRead);
        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.

How to resize controls according to the users font settings

Problem/Question/Abstract:

How to resize controls according to the users font settings

Answer:

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.

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?

Answer:

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
��  ����1: Memo1.Lines.LoadFromFile(Paramstr(1));
��  ����// 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.

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

Answer:

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;

Pitfalls reading from the Registry (ProxyEnable)

Problem/Question/Abstract:

Pitfalls reading from the Registry (ProxyEnable)

Answer:

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

ReadBinaryData("MyKey", myBooleanVar, 1);

&#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

ProxyEnabled := ReadBool(sProxyEnable);

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

case GetDataType(sProxyEnable) of
  rdInteger:
    ProxyEnabled := ReadBool(sProxyEnable);
  rdBinary:
    ReadBinaryData(sProxyEnable, ProxyEnabled, 1);
  // other types..
end;

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

case GetDataType(sProxyEnable) of
  rdInteger:
    ProxyEnabled := ReadBool(sProxyEnable);
  rdBinary:
    ReadBinaryData(sProxyEnable, ProxyEnabled, GetDataSize(sProxyEnable));
  // other types..
end;

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.

Answer:

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

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

type
  TMethodtableEntry = packed record
    len: Word;
    adr: Pointer;
    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)^;
    lines.Add(format('  %d published methods', [numEntries]));
    {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
        lines.Add(format('  %d: len: %d, adr: %p, name: %s', [i, len, adr, name]));
      {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;

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?

Answer:

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
      ReadLn(f, S);
      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;

How to autosize columns in a TDBGrid

Problem/Question/Abstract:

How to autosize columns in a TDBGrid

Answer:

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.


unit AdjustGrid;

interface

uses
  Windows, Forms, DBGrids;

procedure AdjustColumnWidths(DBGrid: TDBGrid);

implementation

procedure AdjustColumnWidths(DBGrid: TDBGrid);
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;
  {adjust column widths}
  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;

Determine your LOCAL IP

Problem/Question/Abstract:

Determine your LOCAL IP

Answer:

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
        A := h.h_addr_list^;
        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;

PCX Image Component

Problem/Question/Abstract:

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

Answer:

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           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.)  //
// Added:     SaveToClipboardFormat, LoadFromClipboardFormat,        //
//            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.        //
// Added:     1 bit PCX support in reading.                          //
// Added:     Procedure Convert1BitPCXDataToImage.                   //
// 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.                          //
// Added:     Procedure ConvertImageTo1bitPCXData.                   //
// Changed:   Procedure CreatePCXHeader.                             //
// 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.                                            //
// Added:     8 bit PCX support in reading and writing.              //
// 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                //
//                        Trademarks: N/A                            //
//                       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' +
    ' header';
  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';
  // added 19/08/2001
  CLIPBOARD_LOAD_ERROR = 'Loading from clipboard failed';
  // added 19/08/2001
  CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
  // added 14/10/2001
  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';
  // added 5/4/2002
  ERROR_UNSUPPORTED = 'Unsupported PCX format';

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

  // added 19/08/2001
var
  CF_PCX: WORD;

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                            PCXHeader                              //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

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

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

type
  TPCXImageHeader = packed record
    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;
    fPCXHeader: TPCXImageHeader;
    fPCXData: TPCXData;
    fPCXPalette: TPCXPalette;
    fColorDepth: QWORD;
    fPixelFormat: BYTE; // added 5/4/2002
    fCurrentPos: QWORD;
    fHasPalette: Boolean; // added 7/5/2002

  protected
    // Protected declarations

  public
    // Public declarations
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromFile(const Filename: string);
    procedure LoadFromStream(Stream: TStream);
    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);
    procedure fCreatePCXHeader(const byBitsPerPixel: 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 LoadFromFile(const Filename: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToFile(const Filename: string); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromClipboardFormat(AFormat: WORD;
      AData: THandle; APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: WORD;
      var AData: THandle; var APalette: HPALETTE); override;

  published
    // Published declarations
    property Height: Integer
      read GetHeight write SetHeight;
    property Width: Integer
      read GetWidth write SetWidth;
    property PixelFormat: TPixelFormat
      read fGetPixelFormat;
    property Bitmap: TBitmap
      read fGetBitmap; // Added 7/5/2002

  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                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// NOT TESTED!

procedure TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
  ADAta: THandle; APalette: HPALETTE);

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

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

      GlobalUnlock(AData);
    end;
  end
  else if (AData <> 0) and (AFormat = CF_BITMAP) then
  begin
    BMP := TBitmap.Create;
    try
      BMP.LoadFromClipboardFormat(AFormat, AData, APalette);
      Self.Assign(BMP);
    finally
      BMP.Free;
    end;
  end
  else
    raise Exception.Create(CLIPBOARD_LOAD_ERROR);
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// 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
  fBitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  // 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
        fCreatePCXHeader(1, 1, WW);
        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
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf8bit:
      begin
        // Fully supported by PCX and by this component
        fCreatePCXHeader(8, 1, W);
        fConvertImageTo1And8BitPCXData(W);
        fGetPalette(256);
      end;
    pf15bit:
      begin
        // Is this supported in PCX?
        // It will be treated as a 24 bit image
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf16bit:
      begin
        // Is this supported in PCX?
        // It will be treated as a 24 bit image
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf24bit:
      begin
        // Fully supported by PCX and by this component
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf32bit:
      begin
        // Not supported by PCX
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
  else
    begin
      fCreatePCXHeader(8, 3, W);
      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;
//---------------------------------------------------------------------

procedure TPCXImage.LoadFromFile(const Filename: string);

begin
  fPCXFile.LoadFromFile(Filename);
  // added 5/4/2002
  case fPCXFile.fPixelFormat of
    1: fConvert1And8BitPCXDataToImage;
    8: fConvert1And8BitPCXDataToImage;
    24: fConvert24BitPCXDataToImage;
  end;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SaveToStream(Stream: TStream);

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

procedure TPCXImage.LoadFromStream(Stream: TStream);

begin
  fPCXFile.LoadFromStream(Stream);
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
  H := fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile.fPCXHeader.fWindow.wTop + 1;
  W := fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile.fPCXHeader.fWindow.wLeft + 1;
  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;
//-------------------------------------------------------------------//

procedure TPCXImage.fConvert1And8BitPCXDataToImage; // added 5/4/2002

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

begin
  H := fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile.fPCXHeader.fWindow.wTop + 1;
  W := fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile.fPCXHeader.fWindow.wLeft + 1;
  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;
//---------------------------------------------------------------------

procedure TPCXImage.fCreatePCXHeader(const byBitsPerPixel: BYTE;
  const byPlanes: BYTE; const wBytesPerLine: DWORD);

var
  H, W: WORD;

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

  // PCX header
  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
  fPCXFile.fPCXHeader.fBitsPerPixel := BYTE(byBitsPerPixel);
  // 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)
  fPCXFile.fPCXHeader.fPlanes := BYTE(byPlanes);
  // BYTE (66)
  fPCXFile.fPCXHeader.fBytesPerLine := WORD(wBytesPerLine);
  // 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.fPixelFormat := fPCXFile.fPCXHeader.fPlanes *
    fPCXFile.fPCXHeader.fBitsPerPixel;
  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
   PRGBQuadArray = ^TRGBQuadArray;
   TRGBQuadArray = Array[BYTE] of TRGBQuad;

Type
   PRGBQuadArray = ^TRGBQuadArray;
   TRGBQuadArray = Array[BYTE] of TRGBQuad;
*)

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;
//---------------------------------------------------------------------

procedure TPCXFile.LoadFromFile(const Filename: string);

var
  fPCXStream: TFileStream;

begin
  fPCXStream := TFileStream.Create(Filename, fmOpenRead);
  try
    fPCXStream.Position := 0;
    LoadFromStream(fPCXStream);
  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;
//---------------------------------------------------------------------

procedure TPCXFile.LoadFromStream(Stream: TStream);

var
  fFileLength: Cardinal;

begin
  // Read the PCX header
  Stream.Read(fPCXHeader, SizeOf(fPCXHeader));

  // Check the ID byte
  if fPCXHeader.fID <> $0A then
    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
  if fPCXHeader.fVersion <> 5 then
    raise Exception.Create(VERSION_ERROR);

  // Calculate width
  fWidth := fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;
  if fWidth < 0 then
    raise Exception.Create(WIDTH_OUT_OF_RANGE);

  // Calculate height
  fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
  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
  fPixelFormat := fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel;

  // 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
        If fPCXHeader.fVersion = 3 then
           Begin
           fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R shl 2;
           fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G shl 2;
           fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B shl 2;
           End
        else
           Begin
           fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R;
           fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G;
           fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B;
           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);
    // Read the data
    Stream.Read(fPCXData.fData[0], 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
    Stream.Read(fPCXData.fData[0], fFilelength);
    // Read the palette
    Stream.Read(fPCXPalette, SizeOf(fPCXPalette));
    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(fPCXHeader, SizeOf(fPCXHeader));
  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.
//=====================================================================