2005. február 13., vasárnap
Retrieve a folder list from MS Outlook
Problem/Question/Abstract:
Do you want to use the MS Outlook from Delphi application?
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.
2005. február 12., szombat
How to embed binary data in an executable
Problem/Question/Abstract:
I have a very specialized script language which requires an executable program (The Engine) to load and process scripts. This works on the basis that each script requires its own copy of the executable processing engine (for reasons about to be explained). I want to take this a step further by embedding a script inside the executable at runtime. This will be done from my existing script editor. Something like a compile script function. How can I open an executable file, safely add a block of binary data which can then be read when the executable is running? I know this can be done. If virus writers can put additional executable code into an *.exe file, then I must be able to put binary data in.
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.
2005. február 11., péntek
How to resize controls according to the users font settings
Problem/Question/Abstract:
How to resize controls according to the users font settings
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.
2005. február 10., csütörtök
Make my program open a file specified as a command line parameter?
Problem/Question/Abstract:
How do I make my program open a file specified as a command line parameter?
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.
2005. február 9., szerda
How to save a metafile displayed in a TImage as a bitmap
Problem/Question/Abstract:
How to save a metafile displayed in a TImage as a bitmap
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;
2005. február 8., kedd
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 “ProxyEnable” 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 – 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);
… 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;
2005. február 7., hétfő
How to get a list of all published methods for a given class
Problem/Question/Abstract:
Is there a way to get a list of all published methods for a given class? Preferably, I'd like to fill a TList with references to them, but even the text representation would work.
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;
2005. február 6., vasárnap
How to compare the contents of folders including subdirectories
Problem/Question/Abstract:
I need to compare the file contents of a folder and its subfolders on all Win98 machines at my client's site (each machine was setup differently but, over time, has had different patches applied to the program in question). I need to report back only the differences found in files based upon Time/ Date stamp. Is there a good way to do this?
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;
2005. február 5., szombat
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;
2005. február 4., péntek
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;
2005. február 3., csütörtök
PCX Image Component
Problem/Question/Abstract:
PCX image component. Fully supports reading and writing of: 1, 8 and 24 bit PCX images.
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.
//=====================================================================
2005. február 2., szerda
Link Label Component
Problem/Question/Abstract:
I have seen many tips on how to call the default browser and open a web page, yet no component in DKB that allows to simply be placed on a form at design time.
Answer:
This component was developed for the German-language forum Delphi-PRAXiS by myself. There is not much to say about it. Simply copy the source code into a new Delphi unit save it and install the component in Delphi.
Afterwards you may place it on your form, set link and caption, adjust the colors for Hot-Link, Visited and Unvisited. Just like a link within your HTML. You may place a link to an e-mail address also, by simply preceding the email address with a mailto:.
======================== CODE START ========================
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uDPLinkLabel
* Copyright : Copyright © 2001, 2002 by gate(n)etwork. All Rights Reserved.
* Author : Daniel Wischnewski
* Freeware : This source is released under the Mozilla Public License. It may
* be reproduced, as long as all references to its original source
* are maintained.
* The most recent version is publicly available at
* http://www.Delphi-PRAXiS.net
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
//: Enth�lt eine Internetlink-Label-Komponente f�r die Mitglieder der Delphi-PRAXiS.
unit uDPLinkLabel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
//: Komponente zur Bereitstellung von Links innerhalb von Delphi-Anwendungen
TDPLinkLabel = class(TCustomLabel)
private
FHoverLinkFont: TFont;
FHyperLink: string;
FLinkFont: TFont;
FMouseHover: Boolean;
FVisited: Boolean;
FVisitedLinkFont: TFont;
procedure FontChanged(Sender: TObject);
procedure SetHoverLinkFont(Value: TFont);
procedure SetHyperLink(Value: string);
procedure SetLinkFont(Value: TFont);
procedure SetVisited(Value: Boolean);
procedure SetVisitedLinkFont(Value: TFont);
procedure UpdateLinkFont;
protected
procedure Click; override;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ExecuteHyperLink(aLink: string = '');
published
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BiDiMode;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property HoverLinkFont: TFont read FHoverLinkFont write SetHoverLinkFont;
property HyperLink: string read FHyperLink write SetHyperLink;
property Layout;
property LinkFont: TFont read FLinkFont write SetLinkFont;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property ParentBiDiMode;
property ParentColor;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Visible;
property Visited: Boolean read FVisited write SetVisited;
property VisitedLinkFont: TFont read FVisitedLinkFont write
SetVisitedLinkFont;
property WordWrap;
end;
procedure Register;
implementation
uses
ShellAPI;
procedure Register;
begin
RegisterComponents('Delphi-PRAXiS', [TDPLinkLabel]);
end;
{ TDPLinkLabel }
constructor TDPLinkLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// create default link font object
FLinkFont := TFont.Create;
FLinkFont.OnChange := FontChanged;
FLinkFont.Color := clBlue;
FLinkFont.Style := [fsUnderline];
// set inherited font
Font := LinkFont;
// create visit link font object
FVisitedLinkFont := TFont.Create;
FVisitedLinkFont.OnChange := FontChanged;
FVisitedLinkFont.Color := clPurple;
FVisitedLinkFont.Style := [fsUnderline];
// create hover link font object
FHoverLinkFont := TFont.Create;
FHoverLinkFont.OnChange := FontChanged;
FHoverLinkFont.Color := clRed;
FHoverLinkFont.Style := [fsUnderline];
// initialize vars
FMouseHover := False;
FVisited := False;
Caption := 'Delphi-PRAXiS';
FHyperLink := 'http://www.Delphi-PRAXiS.net';
// override initialization of previous vars
Cursor := crHandPoint;
end;
destructor TDPLinkLabel.Destroy;
begin
inherited Destroy;
// free link font objects
FLinkFont.Free;
FHoverLinkFont.Free;
FVisitedLinkFont.Free;
end;
procedure TDPLinkLabel.Click;
begin
// the onClick method will be overriden only, if a link is assigned to the
// Link property of the component and no custom on-click handler is assigned
if (not Assigned(OnClick)) and (Action = nil) and (ActionLink = nil) and (
HyperLink <> '') then
// call link
ExecuteHyperLink
else
// work standard control click routine
inherited;
end;
procedure TDPLinkLabel.CMMouseEnter(var Message: TMessage);
begin
inherited;
// mouse enters link - hover color effective
FMouseHover := True;
UpdateLinkFont;
end;
procedure TDPLinkLabel.CMMouseLeave(var Message: TMessage);
begin
inherited;
// mouse leaves link - hover color not effective anymore
FMouseHover := False;
UpdateLinkFont;
end;
procedure TDPLinkLabel.ExecuteHyperLink(aLink: string = '');
var
UseLink: string;
begin
// set link for execution
if Trim(aLink) = '' then
UseLink := Trim(HyperLink)
else
UseLink := Trim(aLink);
// check link data
if Trim(UseLink) = '' then
// raise exception on empty link
raise Exception.Create('No link for launching web browser.');
// load default browser with link
ShellExecute(0, nil, PChar(HyperLink), nil, nil, SW_SHOW);
// HyperLink was visited, no special link passed
if Trim(aLink) <> '' then
Visited := True;
end;
procedure TDPLinkLabel.FontChanged(Sender: TObject);
begin
// need to inform preceding class of possible changes in font
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetHoverLinkFont(Value: TFont);
begin
FHoverLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetHyperLink(Value: string);
begin
if FHyperLink <> Value then
begin
FHyperLink := Value;
Visited := False;
if Caption = '' then
Caption := HyperLink;
end;
end;
procedure TDPLinkLabel.SetLinkFont(Value: TFont);
begin
FLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.SetVisited(Value: Boolean);
begin
if FVisited <> Value then
begin
FVisited := Value;
UpdateLinkFont;
end;
end;
procedure TDPLinkLabel.SetVisitedLinkFont(Value: TFont);
begin
FVisitedLinkFont.Assign(Value);
UpdateLinkFont;
end;
procedure TDPLinkLabel.UpdateLinkFont;
begin
// assign font property the appropriate font data
if FMouseHover then
Font := HoverLinkFont
else if Visited then
Font := VisitedLinkFont
else
Font := LinkFont;
end;
end.
========================= CODE END =========================
2005. február 1., kedd
Moveable/Sizable TPanel with standard or color SizeGrip
Problem/Question/Abstract:
How can I move/resize a TPanel at runtime. Also can I place a sizegrip on the panel and make it a different color then Grey?
Answer:
Many times an application may need to move or resize items on a form. The custom panel presented here provides the ability to move the panel by holding down the left mouse button and dragging the panel to a new location. The size can be adjusted by holding the left mouse button down in the lower right hand corner of the panel as done when resizing a form. There is a property to show/hide the SizeGrip and even change the style of the SizeGrip so that the color can be changed in the event the panel needs to be different then battleship grey. There is two unusual properties FreezeTopAt and FreezeTop which allow you to restrict how far the top can be moved on the parent form. It has been tested with D5 but not D6, see comments inside concerning D6.
unit SizeGripPanel;
{
Description:
This component, a decendent of TPanel provides methods to size and move
the panel by using the mouse. The only restriction for sizing the panel
is that is must be done using the SizeGrip located at the bottom right
part of the panel.
There are two additional events, OnMove and OnSize. Yes you guessed
correct, the are hooked into when a user moves or resizes the panel.
ColoredGrip when True allows the grip to be colored unlike the default
style grip.
Author:
Kevin S. Gallagher
gallaghe@teleport.com
Version
1.0.2
Copyrights:
This is a freeware component. Use at your own risk. You may not sell
or distruibute the component for profit.
Notes:
Originally created in D4, ported to D5.
I am not sure what all needs to change for D6 since I don't have it yet.
It will work as reported from one programmer by hacking some code i.e.
Changing the USES clause and removing the "About" code. There should be
away to make the "About" code work, will fix it once I get D6.
Limitations:
The Grip as is can not assume the color of the panel, for a quick
solution I added the property . For myself it doesn't matter
since I am always using drab grey. If anyone wants to change this, feel
free, just email me the changes.
IF YOU GET THIS TO WORK UNDER D6 SEND ME THE CHANGES PLEASE SO I CAN POST
THE CHANGES.
Revisions
KSG 02.08.01
Added the property "FreezeTop" which when set will not allow vertical
movement of the panel. "FreezeTopAt" control the topmost point the
panel can move too.
KSG 09.10.01
Found flaw in code to set Grip visible, fixed.
Attempted to make work under D6 w/o D6 available.
}
interface
{$IFDEF VER140}
uses
Windows, Messages, Classes, ExtCtrls, Controls, ToolsAPI, DesignIntf,
DesignEditors;
{$ELSE}
uses
Windows, Messages, Classes, ExtCtrls, Controls, DsgnIntf, Commctrl;
{$ENDIF}
type
TAbout = class(TPropertyEditor)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
function GetValue: string; override;
end;
TSizeGripPanel = class(TPanel)
private
FAbout: TAbout;
FUseGrip: Boolean;
FMoving: Boolean;
FSizing: Boolean;
FColorGrip: Boolean;
FOnMove: TNotifyEvent;
FOnSize: TNotifyEvent;
FTop: Integer; { to prevent vertical movement KSG 02.08.01 }
FFreeze: Boolean;
function GetGripRect: TRect;
procedure WMExitSizeMove(var Msg: TMessage); message WM_EXITSIZEMOVE;
procedure SetGripColorStyle(Value: Boolean);
procedure SetGripVisability(Value: Boolean); { KSG 09.10.2001 }
protected
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property About: TAbout read FAbout write FAbout;
property FreezeTopAt: Integer read FTop write FTop;
property FreezeTop: boolean read FFreeze write FFreeze;
property ShowGrip: Boolean read FUseGrip write SetGripVisability;
property ColoredGrip: Boolean read FColorGrip write SetGripColorStyle;
property OnMove: TNotifyEvent read FOnMove write FOnMove;
property OnSize: TNotifyEvent read FOnSize write FOnSize;
end;
procedure Register;
implementation
uses Dialogs, SysUtils, Graphics;
procedure TAbout.Edit;
begin
MessageDlg('SizeMovePanel component v1.0.2'#13'by Kevin S. Gallagher',
mtInformation, [mbOK], 0);
end;
function TAbout.GetAttributes: TPropertyAttributes;
begin
Result := [paMultiSelect, paDialog, paReadOnly];
end;
function TAbout.GetValue: string;
begin
Result := '(about)';
end;
constructor TSizeGripPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ Don't care for a caption at all }
ControlStyle := ControlStyle - [csSetCaption];
ShowGrip := True;
FreezeTop := False;
FColorGrip := False;
end;
procedure TSizeGripPanel.WMExitSizeMove(var Msg: TMessage);
begin
inherited;
if FreezeTop then
Top := FTop;
Msg.Result := 0;
end;
procedure TSizeGripPanel.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
const
SC_DRAGMOVE: Longint = $F012;
begin
{ Might also want to check for Client alignment too. }
if (Align = alNone) then
begin
FMoving := True;
ReleaseCapture;
SendMessage(Handle, WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end
else
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TSizeGripPanel.WMMove(var Message: TWMMove);
begin
inherited;
if FMoving then
begin
FMoving := False;
Parent.Realign;
if Assigned(FOnMove) then
FOnMove(Self);
end;
end;
procedure TSizeGripPanel.WMSize(var Message: TWMSize);
begin
inherited;
if FSizing then
begin
FSizing := False;
Parent.Realign;
if Assigned(FOnSize) then
FOnSize(Self);
end;
end;
function TSizeGripPanel.GetGripRect: TRect;
var
GripWidth: integer;
GripHeight: integer;
begin
GripWidth := GetSystemMetrics(SM_CXHSCROLL);
GripHeight := GetSystemMetrics(SM_CYVSCROLL);
Result := GetClientRect();
Result.Left := Result.Right - GripWidth;
Result.Top := Result.Bottom - GripHeight;
end;
procedure TSizeGripPanel.WMNCHitTest(var Msg: TWMNCHitTest);
var
ScreenPt: TPoint;
begin
inherited;
if not (csDesigning in ComponentState) and (Msg.Result = HTCLIENT) then
begin
ScreenPt := ScreenToClient(Point(Msg.Xpos, Msg.Ypos));
if (ScreenPt.x >= GetGripRect.Left) and (ScreenPt.y >= GetGripRect.Top) then
Msg.Result := HTBOTTOMRIGHT;
{ Used to trigger OnSize }
with Msg do
if Result in [Windows.HTLEFT..Windows.HTBOTTOMRIGHT] then
FSizing := True;
end;
end;
procedure TSizeGripPanel.Paint;
var
Rect: TRect;
begin
inherited Paint;
if not FUseGrip then
exit;
Rect := GetGripRect;
if not FColorGrip then
DrawFrameControl(Canvas.Handle, Rect, DFC_SCROLL, DFCS_SCROLLSIZEGRIP)
else
with Self.Canvas do
begin
Brush.Style := bsClear;
Font.Name := 'Marlett';
Font.Size := 8;
Font.Color := clGray;
TextOut(rect.left, rect.top, 'o');
Font.Color := clWhite;
TextOut(rect.left, rect.top, 'p');
end;
end;
procedure TSizeGripPanel.SetGripColorStyle(Value: Boolean);
begin
if Value <> FColorGrip then
begin
FColorGrip := Value;
Repaint;
end;
end;
procedure TSizeGripPanel.SetGripVisability(Value: Boolean);
begin
if Value <> FUseGrip then
begin
FUsegrip := Value;
Repaint;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TSizeGripPanel]);
RegisterPropertyEditor(TypeInfo(TAbout), TSizeGripPanel, 'ABOUT', TAbout);
end;
end.
Feliratkozás:
Bejegyzések (Atom)