## 2007. június 30., szombat

### Converting Numbers to words

Problem/Question/Abstract:

How to convert numbers like 2345697.347 to "two billion, three hundred and forty-five thousand, six hundred and ninety seven decimal three four seven."

unit Inwordsu;

interface
uses SysUtils, Dialogs;

function InWords(const nNumber: Extended): string;

implementation

function InWords(const nNumber: Extended): string;
const
aUnits: array[0..9] of string = ('', 'one ', 'two ', 'three ', 'four ', 'five ',
'six ', 'seven ', 'eight ', 'nine ');
//Local function to convert decimal portion
function cDecimal(const cDecDitxt: string): string;
var
len, x, n: Integer;
nNumber: string[17];
begin
result := '';
nNumber := cDecDitxt;
//cut off Zeros to the right
while copy(nNumber, length(nNumber), 1) = '0' do
delete(nNumber, length(nNumber), 1);
len := length(nNumber);
//No need to convert if it is all zeros
if len = 0 then
exit;
//Start conversion !
for x := 1 to len do
begin
n := strToint(copy(nNumber, x, 1));
if n = 0 then
result := result + 'zero '
else
result := result + aUnits[n];
end;
if result <> '' then
result := ' decimal ' + trim(result);
end;

//Local function to convert the whole number portion
function Num2EngWords(const nNumber, nWordIndex: integer): string;
const
aLargeNumWords: array[0..5] of string = ('', 'thousand, ', 'million, ',
'billion, ', 'trillion, ', 'quadrillion, ');
aTens: array[0..8] of string = ('', 'twenty', 'thirty', 'forty', 'fifty', 'sixty',
'seventy', 'eighty', 'ninety');
aTwenties: array[10..19] of string = ('ten ', 'eleven ', 'twelve ', 'thirteen ',
'fourteen ', 'fifteen ', 'sixteen ', 'seventeen ', 'eighteen ', 'nineteen ');
var
nQtnt, nNum, nMod: Integer;
begin
result := '';
if nNumber < 1 then
exit;
nNum := nNumber;

if nNumber > 99 then
begin
//Pick up hundreds and leave others
nQtnt := nNum div 100;
nNum := nNum mod 100;
result := aUnits[nQtnt] + 'hundred and ';
end;
case nNum of
1..9: result := result + aUnits[nNum]; {one to nine}
10..19: result := result + aTwenties[nNum]; {ten to nineteen}
20..99:
begin
nQtnt := nNum div 10;
nMod := nNum mod 10;
result := result + aTens[nQtnt - 1]; {digit at tenth place}
if nMod <> 0 then
result := result + '-' + aUnits[nMod] {digit at unit place}
else
result := result + ' ';
end
else
if result <> '' then
result := copy(result, 1, length(result) - 4);
end;
result := result + aLargeNumWords[nWordIndex]; {add thousand, million etc...}
end;
var
nNum, nIndex: Integer;
cStr, cDec: string;
lNegative: Boolean;
begin
result := '';
if (nNumber > 999999999999999999.0) then
begin
showmessage('Sorry this is too large ! larger than the budget of the whole world !!');
exit;
end;
str(nNumber: 34: 15, cStr);
lNegative := False;
nIndex := pos('-', cStr); {having - sign is negative}
if nIndex > 0 then
begin
lNegative := True;
cStr := copy(cStr, nIndex + 1, length(cStr) - nIndex); {trim off minus sign}
end;
while cStr[1] = ' ' do {trim of spaces}
delete(cStr, 1, 1);
nIndex := pos('.', cStr); {decimal position}
if nIndex = 0 then
nIndex := length(cStr) + 1; {if no decimal it must be at the far right}
cDec := copy(cStr, nIndex + 1, length(cStr) - nIndex); {digits after decimal point}
cStr := copy(cStr, 1, nIndex - 1); {digits before decimal point}
nIndex := 0; {index to point the words thousand, million etc.}
nNum := length(cStr); {count of digits}
while nNum > 0 do
begin
if nNum < 3 then
begin
result := Num2EngWords(strToInt(copy(cStr, 1, nNum)), nIndex) + result;
cstr := ''; {less than 3 digits means finished}
end
else
begin
result := Num2EngWords(strToInt(copy(cStr, nNum - 2, 3)), nIndex) + result;
cStr := copy(cStr, 1, nNum - 3); {cut off three rightmost digits}
end;
nNum := length(cStr); {remaining number of digits}
inc(nIndex); {increase the large number's word index}
end;
result := trim(result) + cDecimal(cDec) + '.'; {finished, add a full stop}
if lNegative then
result := 'minus ' + result; {if the number is negative add "minus" at first}
end;

//Thanks Mr. KRISHNA SAPKOTA
//E-Mail: krishna_sapkota@hotmail.com
//for pointing out the misspelled function name in the calling example
//below !

//Calling examples:
{nNum:extended or nNum:Double}
//nNum:=24693456799398.6078;
{Corrected calling function name on Monday May 21, 2001}
//label1.caption:=InWords(nNum);
{nInt:Integer or nInt:longint}
//nInt:=23456
//label2.caption:=InWords(nint);
//label3.caption:=InWords(2345678965432.30045);
//label4.caption:=InWords(896867);

end.

## 2007. június 29., péntek

### How to tell what kind of drive is used

Problem/Question/Abstract:

How to tell what kind of drive is used

When dealing with multiple drives, it is helpful to know whether a drive is associated with A:\ is attached to a letter (A, B, C, etc), and what its type is. This code uses the API GetDriveType function to do that.

function ShowDriveType(DriveLetter: char): string;
var
i: word;
begin
if DriveLetter in ['A'..'Z'] then
{Make it lower case}
DriveLetter := chr(ord(DriveLetter) + \$20);
i := GetDriveType(ord(DriveLetter) - ord('a'));
case i of
DRIVE_REMOVABLE: result := 'floppy';
DRIVE_FIXED: result := 'hard disk';
DRIVE_REMOTE: result := 'network drive';
else
result := 'does not exist';
end;
end;

## 2007. június 28., csütörtök

### Search for a substring in a registry tree

Problem/Question/Abstract:

How do I iterate through the entries of HKLM and look for a particular string?

Searching for a substring in a registry tree:

procedure SearchRegistry(aRoot: HKEY; searchfor: string; resultlist: TStrings);

procedure EnumKey(const keyname: string);

function VName(const valuename: string): string;
begin
if Length(valuename) = 0 then
Result := '@'
else
Result := valuename;
end;

var
reg: TRegistry;
temp: TStringList;
S: string;
i: Integer;
begin
reg := TRegistry.Create;
try
reg.Rootkey := aRoot;
begin
{Enumerate the values}
temp := TStringList.Create;
try
reg.GetValueNames(temp);
for i := 0 to temp.Count - 1 do
begin
if reg.GetDatatype(temp[i]) = rdString then
begin
if Length(S) > 0 then
begin
if Pos(searchfor, AnsiUpperCase(S)) > 0 then
resultlist.add(Format('%s %s ="%s"', [keyname, Vname(temp[i]), S]));
end;
end;
end;
temp.Clear;
{Enumerate the subkeys}
if reg.HasSubKeys then
begin
reg.GetKeyNames(temp);
for i := 0 to temp.count - 1 do
EnumKey(keyname + '\' + temp[i]);
end;
finally
temp.free;
end;
end;
reg.CloseKey;
finally
reg.free;
end;
end;

begin
searchfor := AnsiUpperCase(searchfor);
EnumKey(EmptyStr);
end;

Used like this:

procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.clear;
Screen.Cursor := crHourglass;
try
SearchRegistry(HKEY_CLASSES_ROOT, 'internet', memo1.lines);
finally
Screen.Cursor := crDefault;
end;
end;

## 2007. június 27., szerda

### Cross Debug Delphi 6 and CBuilder 5 Failure

Problem/Question/Abstract:

In Delphi 5 im able to 'debug' step into the cpp code of a dll created with cbuilder. In Delphi 6 this doesnt work. The CPP DLL contains TD32 Debug info. In Delphi set breakpoint on DLL entrance. Press F7 and CPP code is entered. This works in D5 but not in D6. Why?

First of all, it is never guaranteed that you can mix versions of the Delphi and BCB products and get the results that you desire. Normally, you'd have to wait for the release of BCB that matches the Delphi version. If you have both, then the installer will set up everything for you. However, in the case of Delphi6 and BCB5, it should work with a little tweaking. You'll need to manually edit your registry in order to make Delphi aware of you C++ evaluator.

Under:

[HKEY_CURRENT_USER]
Software
Borland
Debugging
6.0
Evaluators

Add a new string value called "comp32p.dll". Give it a value of '1'.

You'll need to copy your comp32p.dll from your BCB5 bin directory into you Delphi6 bin directory.

## 2007. június 26., kedd

### How to grey-out enabled or disabled data-aware controls

Problem/Question/Abstract:

How to grey-out enabled or disabled data-aware controls

Most data aware components are capable of visually showing that they are disabled (by changing the text color to gray) or enabled (by setting the color to a user-defined windows text color). Some data aware controls such as TDBGrid, TDBRichEdit (in Delphi 3.0) and also TDBEdit (when connected to a numeric or date field) do not display this behavior.

The code below uses RTTI (Run Time Type Information) to extract property information and use that information to set the font color to gray if the control is disabled. If the control is enabled, the text color is set to the standard windows text color.

What follows is the step by step creation of a simple example which consists of a TForm with a TButton and a TDBRichEdit that demonstrates this behavior.

Select File|New Application from the Delphi menu bar.
Drop a TDataSource, a TTable, a TButton and a TDBEdit onto the form.
Set the DatabaseName property of the table to 'DBDEMOS'.
Set the TableName property of the table to 'ORDERS.DB'.
Set the DataSet property of the datasource to 'Table1'.
Set the DataSource property of the DBEdit to 'DataSource1'.
Set the DataField property of the DBEdit to 'CustNo'.
Set the Active property of the DBEdit to 'False'.
Add 'TypInfo' to the uses clause of the form.

Below is the actual procedure to put in the implementation section of your unit:

{This procedure will either set the text color of a dataware control to gray or the
user defined color constant in clInfoText}

procedure SetDBControlColor(aControl: TControl);
var
FontPropInfo: PPropInfo;
begin
{Check to see if the control is a dataware control}
if (GetPropInfo(aControl.ClassInfo, 'DataSource') = nil) then
exit
else
begin
{Extract the front property}
FontPropInfo := GetPropInfo(aControl.ClassInfo, 'Font');
{Check if the control is enabled/disabled}
if (aControl.Enabled = false) then
{If disabled, set the font color to grey}
TFont(GetOrdProp(aControl, FontPropInfo)).Color := clGrayText
else
{If enabled, set the font color to clInfoText}
TFont(GetOrdProp(aControl, FontPropInfo)).Color := clInfoText;
end;
end;

The code for the buttonclick event handler should contain:

{This code will cycle through the Controls array and call SetDbControlColor
for each control on your form making sure the font text color is set to what
it should be}

procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
{Loop through the control array}
for i := 0 to ControlCount - 1 do
SetDBControlColor(Controls[i]);
end;

## 2007. június 25., hétfő

### How to create a function which returns a value from a form

Problem/Question/Abstract:

I need a function to show a form and getting back a value, like InputBox or similar. How can I do this?

type
TMyForm {set positions and captions as you desire}
Edit1: TEdit;
ButtonOK: TBitBtn; {set Kind property to bkOK}
ButtonCancel: TBitBtn; {set Kind property to bkCancel}
private
public
end;

{var MyForm:TMyForm; I do not use it, so I get rid of it}

function GetMyValue: string;

implementation

function GetMyValue(DefaultValue: string): string;
{not part of the TMyForm class}
begin
with TMyForm.Create(Application) do
try
result := TMyValue.Create;
result := DefaultValue;
Edit1.Text := DefaultValue;
if ShowModal = mrOK then
result := Edit1.Text;
finally
Release;
end;
end;

## 2007. június 24., vasárnap

### How to display a 24 bit True Color bitmap image on a 256 color display

Problem/Question/Abstract:

How to display a 24 bit True Color bitmap image on a 256 color display

You can take advantage of the new graphics capabilities of the TBitmap and TJPEGImage components of Delphi 3/4. When Delphi 3/4 loads a bitmap image, it keeps a copy of the device independent bitmap image it loads from a file in the background. The TJPEGImage component is very good at color reducing a full color image down to 256 colors. By Loading the bitmap, then assigning the image to a Jpeg and saving it to a temporary ".JPG" file, you can then load the temporary file back into a TImage with much better results than simply loading the bitmap file unconverted. The following example demonstrates the necessary steps to achieve these results.

uses
JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
JP: TJPEGImage;
IM: TImage;
TempFileName: string;
begin
{Pop up an Open Dialog}
OpenDialog1.Options := [ofNoChangeDir, ofFileMustExist];
OpenDialog1.Filter := 'Bitmap Files (*.bmp)|*.bmp';
if OpenDialog1.Execute then
begin
{Create a temporary TImage}
IM := TImage.Create(nil);
{Create a temporary TJPEGImage}
JP := TJPEGImage.Create;
{Priority on quality}
JP.Performance := jpBestQuality;
{Assign the bitmap to the JPEG}
JP.Assign(IM.Picture.Graphic);
{Free the temp image}
IM.Free;
{Make a temp file name with the extension of .jpg}
TempFileName := 'test.jpg';
{Save the JPEG to a temp file}
JP.SaveToFile(TempFileName);
{Free the JPEG}
JP.Free;
{Load the temp file to an image on the form}
{Delete the temp file}
DeleteFile(TempFileName);
end;
end;

## 2007. június 23., szombat

### ISAPI FILTER* LOADER - On the fly updating of your ISAPI filter without restarting web services

Problem/Question/Abstract:

Writing Filters and updating them on the server is even more a pain in the butt than ISAPI extensions. If you are using Personal web server then that means you have to reboot your machine for every update. For IIS you have to go into config (on win2K) and restart web services. Doing so will first take too much of your time, and also will stop web traffic and visitors get an error trying to connect to your site. The main deal though is the pain of updating an ISAPI filter during development.

My solution is identical in concept as my ISAPI extension loader. This isapi filter loader is an isapi filter that loads and calls your isapi filer. When you have an update, your isapi filter will be unloaded and the new one will be loaded... all on the fly without interupting your users.

How to use:

Compile or use the already compiled version of this DLL and rename it to the same name as your existing filter.

Now - rename your existing filter with a .run extension. The loader will look for this file and will load it.

Thats all, but now for the update part. When you have an update, you change the extension of your new filter to .update. The loader will look for this file and if it is found, then will unload the .run file, rename it to .backup then rename the .update to .run then load the new .run filter.

If you need to revert back for some reason then simply rename the .backup to .update.

The performance hit of this loader is very small I think.

One thing this loader does do, it registers most all events with the server then calls your filter only with the events you specified.

Source Listing
3 units.

Fn_GetModuleName.pas - Utility to return the name of the module.

{
Author
William Egge
egge@eggcentric.com

Version 1.0
Date: Sep 9, 2001
This source code is free to distribute and modify.

This is the Filter Loader DLL main project file.  The applications
intention is to be a loader for ISAPI filters to reduce development time

}

uses
ISAPI2,
Windows,

{\$R *.RES}
var

function GetFilterVersion(var pVer: HTTP_FILTER_VERSION): BOOL; export; stdcall;
begin
try
GEggFilterLoader := nil; // Free prev if any
except // Dont crash IIS
Result := False;
end;
end;

function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
begin
try
except // Dont crash IIS
end;
end;

exports
GetFilterVersion,
HttpFilterProc;

begin
end.

{
Author
William Egge
egge@eggcentric.com

Version 1.0
Date: Sep 9, 2001
This source code is free to distribute and modify.

This is the core updating part of my isapi filter loader.  Its purpose
is to check for updates of a new isapi filter then unload the current
one and load the new one.  To use, simply Create it by calling the
application should forward all extension calls to the object.
}

interface
uses
ISAPI2,
Fn_GetModuleName,
SysUtils,
Windows;

type
function GetFilterVersion(var pVer: HTTP_FILTER_VERSION): BOOL;
function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
end;

implementation
const
// This is the time that must pass between update checks
WAIT_BEFORE_CHECK = 10000; // 10 seconds

SF_NOTIFY_SEND_RESPONSE = \$00000040;
SF_NOTIFY_END_OF_REQUEST = \$00000080;
ALL_FLAGS =
or SF_NOTIFY_URL_MAP
or SF_NOTIFY_AUTHENTICATION
or SF_NOTIFY_ACCESS_DENIED
or SF_NOTIFY_SEND_RESPONSE
//    or SF_NOTIFY_SEND_RAW_DATA
or SF_NOTIFY_END_OF_REQUEST
or SF_NOTIFY_LOG
or SF_NOTIFY_END_OF_NET_SESSION
or SF_NOTIFY_ORDER_DEFAULT
or SF_NOTIFY_SECURE_PORT
or SF_NOTIFY_NONSECURE_PORT;

type
private
FLastTimeCheck: LongWord;
FDLL: HModule;
FCallbackVersion: TGetFilterVersion;
FCallbackProc: THttpFilterProc;
FBackupDLLName, FRunDLLName, FUpdateDLLName: string;
FFilterFlags: DWord;
procedure DoUpdateIfNeeded;
public
constructor Create;
destructor Destroy; override;
function GetFilterVersion(var pVer: HTTP_FILTER_VERSION): BOOL;
function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
end;

begin
end;

var
ThisModule: string;
begin
inherited Create;
ThisModule := GetModuleName;
FBackupDLLName := ChangeFileExt(ThisModule, '.backup');
FRunDLLName := ChangeFileExt(ThisModule, '.run');
FUpdateDLLName := ChangeFileExt(ThisModule, '.update');
end;

begin
if FDLL <> 0 then
FreeLibrary(FDLL);
FDLLSync.Free;
FCheckSync.Free;
inherited;
end;

var
begin
// Quick Check
try
NeedCheck := (GetTickCount - FLastTimeCheck) >= WAIT_BEFORE_CHECK;
finally
end;

if NeedCheck then
begin
FCheckSync.BeginWrite;
try
// Recheck in case another thread has updated
try
NeedCheck := (FDLL = 0) or ((GetTickCount - FLastTimeCheck) >=
WAIT_BEFORE_CHECK);
finally
end;

if NeedCheck then
begin
FLastTimeCheck := GetTickCount;
try
NeedLoad := (FDLL = 0) or FileExists(FUpdateDLLName);
finally
end;
end;
finally
FCheckSync.EndWrite;
end;
end;
end;

var pVer: HTTP_FILTER_VERSION): BOOL;
begin
DoUpdateIfNeeded;
try
pVer.dwFilterVersion := MakeLong(0, 1);
pVer.dwFlags := ALL_FLAGS;
Result := True;
finally
end;
end;

begin
DoUpdateIfNeeded;
try
// Check Notification bit to make sure the DLL should be called
if Assigned(FCallbackProc) and ((NotificationType and FFilterFlags) <> 0) then
else
finally
end;
end;

var
pVer: THTTP_FILTER_VERSION;
begin
FDLLSync.BeginWrite;
try
// First Determine if we really should
ShouldReload := (FDLL = 0) or FileExists(FUpdateDLLName);
begin
if FDLL <> 0 then
begin
FreeLibrary(FDLL);
FDLL := 0;
FCallbackVersion := nil;
FCallbackProc := nil;
end;

// check for update file, if exists then rename things;
if FileExists(FUpdateDLLName) then
begin
SysUtils.DeleteFile(FBackupDLLName);
RenameFile(FRunDLLName, FBackupDLLName);
RenameFile(FUpdateDLLName, FRunDLLName);
end;

// Now load the .run file if it exists
if FileExists(FRunDLLName) then
begin
if FDLL <> 0 then
begin
if Assigned(FCallbackVersion) then
begin
FCallbackVersion(pVer);
FFilterFlags := pVer.dwFlags;
end
else
FFilterFlags := 0;
end;
end;
end;
finally
FDLLSync.EndWrite;
end;
end;

end.

Fn_GetModuleName.pas

unit Fn_GetModuleName;
{
Author
William Egge
egge@eggcentric.com

Version 1.0
Original FileName Fn_GetModuleName.pas
Date: Sep 9, 2001
Website http://www.eggcentric.com
This source code is free to distribute and modify.

Very simple function, it returns the full path and file name of the module
it is running in.
}

interface
uses
Windows;

function GetModuleName: string;

implementation

function GetModuleName: string;
var
FileName: array[0..MAX_PATH] of char;
begin
FillChar(FileName, SizeOf(FileName), #0);
GetModuleFileName(HInstance, FileName, SizeOf(FileName));
Result := FileName;
end;

end.

## 2007. június 22., péntek

### Using a Common Include File

Problem/Question/Abstract:

If you develop third-party components and you plan to include the source code. You can not be certain how Delphi is configured for each user, how can you asure that your component�s code compile correctly?

You can use a common include file in all your components unit, so you can set compiler directives and conditional defines that govern the way the components are compiled.

If the user recompiles your code, its naive to think that his compilers directives are the same as the ones you used to develop the components. So creating a common include file, you can override the user�s directives. For example you can use the following:

// DCDC Include File
// You must include a similar file into each component unit so it can
// serve as a common place to add conditional defines and compiler
// directives.

// Code Generation Directives

{\$O+} //Optimizations
{\$F-} //Force Far Calls
{\$A+} //Word Align Data
{\$U-} //Pentium-Safe FDIV
{\$K-} //Smart Callbacks
{\$W-} //Windows Stack Frame

// Runtime Errors
{\$IFOPT D+}
{\$R+} //Range Checking - On - If compiled with Debug Information
{\$ELSE}
{\$R-} //Range Checking - Off - If compiled without Debug Information
{\$ENDIF}

{\$S+} //Stack Checking
{\$I+} //I/O Checking
{\$Q-} //Overflow Checking

// Syntax Options
{\$V-} //Strict Var-Strings
{\$B-} //Complete Boolean Evaluation
{\$X+} //Extended Syntax
{\$T-} //Typed @ Operator
{\$P+} //Open Parameters
{4H+}//Huge Strings

// Miscellaneus Directives
{\$Z-} //Word Size Enumerated Types

Because this is an include file you must use the \$I directive to embed its contents in your component�s unit files.

{\$I CIF.INC}

unit mcEdit;

interface

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

type
TmcEdit = class(TCustomEdit)
private
{ Private declarations }
public
{ Public declarations }
end;

But, what if you create a component that uses a diferent compiler directive?, Just specify the new directive after the include file statements, this overrides the include file�s directives.

## 2007. június 21., csütörtök

### Change keys pressed in a TMemo

Problem/Question/Abstract:

When you insert an accented letter into a HTML it should be converted into an extended code for international use.
That will help everyone who will build an HTML editor.

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
const
UnSup =
#171#187#193#225#194#226#198#230#192#197#229#195#227#196#228#199#231#162#169#20 +
#233#202#234#200#232#203#235#205#237#206#238#204#236#207#239#60#209#241#211#243 +
#212#244#210#242#216#248#213#245#214#246#34#174#223#218#250#219#251#217#249#220 +
#252#255;
Supported: array[0..61] of string =
(
'&laquo;', '&raquo;', '&Aacute;', '&aacute;',
'&Acirc;', '&acirc;', '&AElig;', '&aelig;',
'&Agrave;', '&Aring;', '&aring;', '&Atilde;',
'&atilde;', '&Auml;', '&auml;', '&Ccedil;',
'&ccedil;', '&cent;', '&copy;', '&Eacute;',
'&eacute;', '&Ecirc;', '&ecirc;', '&Egrave;',
'&egrave;', '&Euml;', '&euml;', '&Iacute;',
'&iacute;', '&Icirc;', '&icirc;', '&Igrave;',
'&igrave;', '&Iuml;', '&iuml;', '&lt;',
'&Ntilde;', '&ntilde;', '&Oacute;', '&oacute;',
'&Ocirc;', '&ocirc;', '&Ograve;', '&ograve;',
'&Oslash;', '&oslash;', '&Otilde;', '&otilde;',
'&Ouml;', '&ouml;', '&quot;', '&reg;',
'&szlig;', '&Uacute;', '&uacute;', '&Ucirc;',
'&ucirc;', '&Ugrave;', '&ugrave;', '&Uuml;',
'&uuml;', '&yuml;'
);
var
P: Integer;
begin
P := Pos(Key, UnSup);
if (P > 0) then
begin
Memo1.SetSelTextBuf(PChar(Supported[P - 1]));
Key := #0;
end;
end;

Obviously this can be ported to every type of char substitution.

If you really use it I raccomend that you insert into the array all special symbols!

## 2007. június 20., szerda

### Parsing strings

Problem/Question/Abstract:

How can I extract the tokens (parse) from a given string?

{
With this code you can extract tokens from a string.
I've provided sets for Comma Seperated fields (CS_CSV), Tab (CS_Tab) and ofcource for spaces (CS_SPACE).
Warning: This code does not support "quoted strings" tokens.
}

type
CharSet = set of char;
const
CS_Space: CharSet = [' '];
const
CS_CSV: CharSet = [',', ' '];
const
CS_STab: CharSet = [#9, ' '];

function GetToken(var InTxt: string; SpaceChar: CharSet): string;
var
i: Integer;
begin
{ Find first SpaceCharacter }
i := 1;
while (i <= length(InTxt)) and not (InTxt[i] in SpaceChar) do
inc(i);
{ Get text upto that spacechar }
Result := Copy(InTxt, 1, i - 1);
{ Remove fetched part from InTxt }
Delete(InTxt, 1, i);
{ Delete SpaceChars in front of InTxt }
i := 1;
while (i <= length(InTxt)) and (InTxt[i] in SpaceChar) do
inc(i);
Delete(InTxt, 1, i - 1);
end;

Usage example:

var
s: string;
begin
s := 'Money, 600, Box, Walk_On_Moon';
Memo1.Lines.Add('"' + GetToken(s, CS_CSV) + '"');
Memo1.Lines.Add('"' + GetToken(s, CS_CSV) + '"');
Memo1.Lines.Add('"' + GetToken(s, CS_CSV) + '"');
Memo1.Lines.Add('"' + GetToken(s, CS_CSV) + '"');
end;

## 2007. június 19., kedd

### First visible line in a Memo/RichEdit

Problem/Question/Abstract:

Ok, I have a Memo with a bunch of lines, but how do I know the first visible line of it?

this is very simple

FirstLine := Memo1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);

The return value is the zero-based index of the uppermost visible line in a multiline edit control. For single-line edit controls, the return value is the zero-based index of the first visible character.

## 2007. június 18., hétfő

### Posting a web-form using TClientSocket. And how to use a web proxy-server

Problem/Question/Abstract:

Posting a web form using TClientSocket. This code snipset demonstrates posting directly and thru a web proxy-server. The result returned by the server is put into a string variable (FResult).

{

This is a code snipset showing you how to
post a form to a webserver. Look at the comments
in the source for more details.

Connect the following events to your ClientSocket:
procedure T...Form.ClientSocket1Write;
procedure T...Form.ClientSocket1Disconnect;
procedure T...Form.ClientSocket1Error;

It also shows how to route the transmission
thru a web proxy-server.

This is the format used to send to the webserver:
Normal: 'POST ' + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
PROXY:  'POST http://' Webserver + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
}

const
WebServer = 'www.somehost.com';
WebPort = 80;

{ Proxy stuff is only needed if you use a proxy: }
ProxyServer = 'proxy.somewhere.com';
ProxyPort = 3128;

// Some data needed in the post heading
HTTP_Data =
'Content-Type: application/x-www-form-urlencoded'#10 +
'User-Agent: Delphi/5.0 ()'#10 + { Yes! Promote Delphi 5! }
'Host: somewhere.com'#10 +
'Connection: Keep-Alive'#10;

type
T...Form = class(TForm)
...
private
{ Private declarations }
HTTP_POST: string;
FContent: string;
FResult: string; // This will hold the server responce
public
{ Public declarations }
end;

{ This functions does some url-encoding on St }
{ Eg.   'John Smith' => 'John+Smith'  }

function HTTPTran(St: string): string;
var
i: Integer;
begin
Result := '';
for i := 1 to length(St) do
if St[i] in ['a'..'z', 'A'..'Z', '0', '1'..'9'] then
Result := Result + St[i]
else if St[i] = ' ' then
Result := Result + '+'
else
Result := Result + '%' + IntToHex(Byte(St[i]), 2);
end;

procedure T...Form.ClientSocket1Write(Sender: TObject;
Socket: TCustomWinSocket);
begin
// Post the data
Socket.SendText(HTTP_POST + FContent);
end;

Socket: TCustomWinSocket);
begin
// Incoming result data
end;

procedure T...Form.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
// YOU CAN PROCESS FResult HERE //
end;

procedure T...Form.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode := 0; // Ignore Errors
end;

{
And here is the routine you can call to post your form data.
}

procedure T...Form.PostTheForm;
begin
// Clear result
FResult := '';

// You can enter whatever fields you want
// These are some examples:
FContent :=
'Name=' + HTTPTran('John Smith') + '&' +
'Address=' + HTTPTran('1 Waystreet') + '&' +
'Email=' + HTTPTran('jsmith@somewhere.com') + '&' +
'B1=Submit' +
#10;

// Calculate the contents length
FContent :=
'Content-Length: ' + IntToStr(Length(FContent)) + #10 + #10 + FContent;

{-- Start proxy ---}
{ uncomment this code if you are using a proxy
ClientSocket1.Host := ProxyServer;
ClientSocket1.Port := ProxyPort;
{--- End proxy ---}

{--- Start normal connection --- }
{ remove this code if you are using a proxy }
ClientSocket1.Host := WebServer;
ClientSocket1.Port := WebPort;
HTTP_POST := 'POST ' + PostAddr + ' HTTP/1.0'#10;
{--- End normal ---}

HTTP_Post := HTTP_Post + HTTP_Data;

// Try to open connection
ClientSocket1.Open;
end;

## 2007. június 17., vasárnap

### Turn off NumLock

Problem/Question/Abstract:

Using Delphi 5, I'm trying to setup a routine that would automatically turn off the NUMLOCK key when loaded. Assume that I am writing a standalone utility that could be loaded in the startup folder to do this function.

Solve 1:

procedure SwitchToggleKey(Key: byte; State: boolean);
var
ks: TKeyboardState;
ScanCode: integer;
begin
if not key in [VK_CAPITAL, VK_NUMLOCK, VK_SCROLL, VK_INSERT] then
exit;
if (key = VK_NUMLOCK) and (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then
begin
GetKeyboardState(ks); {for Win95/98}
if state then
ks[key] := ks[key] or 1
else
ks[key] := ks[key] and 254;
SetKeyboardState(ks);
end
else if odd(GetKeyState(key)) <> state then
begin
ScanCode := MapVirtualKey(key, 0);
keybd_event(key, ScanCode, {KEYEVENTF_EXTENDEDKEY} 0, 0);
{Simulate a key release}
keybd_event(key, ScanCode, {KEYEVENTF_EXTENDEDKEY or } KEYEVENTF_KEYUP, 0);
end;
end;

Note that not all controls "honor" the INSERT key, and others will only respond to the INSERT key while they have focus. I'm surprised that the Extended Key "attribute" works for the non-extended keys. Strangely enough, it works as well without KEYEVENTF_EXTENDEDKEY.

Solve 2:

procedure SimulateKeystroke(Key: byte; extra: DWORD);
begin
keybd_event(Key, extra, 0, 0);
keybd_event(Key, extra, KEYEVENTF_KEYUP, 0);
end;

function IsKeyToggled(key: byte): boolean;
var
state: word;
begin
state := windows.GetKeyState(key);
result := (state mod 128) = 1;
end;

function CapsLockStatus: boolean;
begin
result := IsKeyToggled(VK_CAPITAL);
end;

function NumLockStatus: boolean;
begin
result := IsKeyToggled(VK_NUMLOCK);
end;

procedure ToggleCapsLock;
begin
SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure ToggleNumLock;
begin
SimulateKeystroke(VK_NUMLOCK, 0);
end;

procedure TForm1.btnOnClick(Sender: TObject);
begin
if not NumLockStatus then
ToggleNumLock;
end;

procedure TForm1.btnOffClick(Sender: TObject);
begin
if NumLockStatus then
ToggleNumLock;
end;

Solve 3:

I want to determine the state of the Num lock key on the keyboard and set it to on when my application begins or opens a specific form.

Note that the keyboard LED may not reflect the keys state correctly on all Windows platforms if you set it this way in code.

procedure SetLockKey(vcode: Integer; down: Boolean);
begin
if Odd(GetAsyncKeyState(vcode)) <> down then
begin
keybd_event(vcode, MapVirtualkey(vcode, 0), KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(vcode, MapVirtualkey(vcode, 0), KEYEVENTF_EXTENDEDKEY or
KEYEVENTF_KEYUP, 0);
end;
end;

SetLockKey(VK_NUMLOCK, True); {num lock down}

## 2007. június 16., szombat

### Customize the Open Dialog

Problem/Question/Abstract:

How can I customize the open dialog by adding any control to it.

I have created a component that lets you do just this.

Here is the code.

unit CusOpen;
interface

uses
classes, forms, sysutils, messages, windows, controls, dialogs, extctrls;

type
TOnPaint = procedure(sender: TObject) of object;
TControlInfo = record
control: Tcontrol;
parent: tWincontrol;
end;
PControlInfo = ^TControlInfo;
type
TCustomOpenDialog = class(TOpenDialog)
private
cpanel: Tpanel;
Controls: Tlist;
fOnResize: TNotifyEvent;
fOnPaint: TOnPaint;
fdwidth: integer;
fdheight: integer;
fexecute: boolean;
fdefproc: TFarProc;
fcurproc: TFarProc;
procedure SetHeight(aheight: integer);
procedure SetWidth(awidth: integer);
protected
procedure WndProc(var msg: TMessage); override;
procedure DlgProc(var msg: TMessage);
public
constructor Create(Aowner: Tcomponent); override;
destructor destroy; override;
procedure SetDialogSize(awidth: integer; aheight: integer);
function RemoveControl(AControl: TControl): boolean;
function Execute: boolean; override;
property DialogWidth: integer read fdwidth write SetWidth;
property DialogHeight: integer read fdheight write SetHeight;
published
property OnResize: TNotifyEvent read fOnresize write fonresize;
property OnPaint: TOnPaint read fOnpaint write fonpaint;
end;

procedure Register;
implementation

constructor TCustomOpenDialog.Create(Aowner: Tcomponent);
begin
fdheight := 0;
fdwidth := 0;
fexecute := false;
cpanel := Tpanel.create(self);
cpanel.Caption := '';
cpanel.BevelInner := bvnone;
cpanel.BevelOuter := bvnone;
controls := Tlist.Create;
inherited Create(Aowner);
end;

destructor TCustomOpenDialog.destroy;
var
i: integer;
pcinfo: PControlInfo;
begin
for i := 0 to controls.count - 1 do
begin
pcinfo := controls.Items[i];
dispose(pcinfo);
end;
freeandnil(controls);
freeandnil(cpanel);
FreeObjectInstance(fcurproc);
inherited;
end;

procedure TCustomOpenDialog.SetHeight(aheight: integer);
begin
if (aheight >= 0) then
begin
fdheight := aheight;
if fexecute then
begin
setwindowpos(getparent(handle), 0, 0, 0, fdwidth, fdheight, SWP_NOMOVE or
SWP_NOREPOSITION);
cpanel.SetBounds(0, 0, fdwidth, fdheight);
end;
end;
end;

procedure TCustomOpenDialog.SetWidth(awidth: integer);
begin
if (awidth >= 0) then
begin
fdwidth := awidth;
if fexecute then
begin
setwindowpos(getparent(handle), 0, 0, 0, fdwidth, fdheight, SWP_NOMOVE or
SWP_NOREPOSITION);
cpanel.SetBounds(0, 0, fdwidth, fdheight);
end;
end;
end;

procedure TCustomOpenDialog.SetDialogSize(awidth: integer; aheight: integer);
begin
if (awidth >= 0) and (aheight >= 0) then
begin
fdwidth := awidth;
fdheight := aheight;
if fexecute then
begin
setwindowpos(getparent(handle), 0, 0, 0, fdwidth, fdheight, SWP_NOMOVE or
SWP_NOREPOSITION);
cpanel.SetBounds(0, 0, fdwidth, fdheight);
end;
end;
end;

procedure TCustomOpenDialog.WndProc(var Msg: TMessage);
var
i: integer;
rct: Trect;
begin
inherited WndProc(msg);
if msg.Msg = WM_INITDIALOG then
begin
fdefproc := TFarProc(GetWindowLong(getparent(handle), GWL_WNDPROC));
fcurproc := MakeObjectInstance(DlgProc);
SetWindowlong(getparent(handle), GWL_WNDPROC, longword(fcurProc));
if (fdwidth > 0) and (fdheight > 0) then
setwindowpos(getparent(handle), 0, 0, 0, fdwidth, fdheight, SWP_NOREPOSITION or
SWP_NOMOVE)
else
begin
getclientrect(getparent(handle), rct);
fdwidth := rct.right;
fdheight := rct.bottom;
end;
cpanel.parentwindow := getparent(handle);
setparent(cpanel.handle, getparent(handle));
cpanel.SetBounds(0, 0, fdwidth, fdheight);
setwindowpos(cpanel.handle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE);
cpanel.visible := true;
cpanel.enabled := true;
for i := 0 to controls.count - 1 do
PControlInfo(controls[i]).control.Parent := cpanel;
end;
end;

var
pcinfo: pcontrolinfo;
begin
result := false;
if (acontrol is TControl) then
begin
new(pcinfo);
pcinfo.control := acontrol;
pcinfo.parent := TControl(acontrol).parent;
result := true;
end;
end;

function TCustomOpenDialog.RemoveControl(AControl: TControl): boolean;
var
i: integer;
pcinfo: PControlInfo;
begin
result := false;
if (acontrol is TControl) then
begin
for i := 0 to controls.count - 1 do
begin
pcinfo := controls.Items[i];
if pcinfo.control = acontrol then
begin
Tcontrol(acontrol).Parent := pcinfo.parent;
Controls.Remove(pcinfo);
dispose(pcinfo);
result := true;
break;
end;
end;
end;
end;

function TCustomOpenDialog.Execute: boolean;
begin
fexecute := true;
result := inherited Execute;
end;

procedure TCustomOpenDialog.DlgProc(var msg: Tmessage);
var
rct: TRect;
pcinfo: PControlInfo;
fcallinherited: boolean;
i: integer;
begin
fcallinherited := true;
case msg.msg of
WM_SIZE:
begin
getclientrect(getparent(handle), rct);
fdheight := rct.Bottom;
fdwidth := rct.Right;
cpanel.SetBounds(0, 0, fdwidth, fdheight);
if assigned(fOnResize) then
fOnresize(self);
end;
WM_PAINT:
begin
if assigned(fonpaint) then
fonpaint(self);
end;
WM_CLOSE:
begin
for i := 0 to controls.count - 1 do
begin
pcinfo := controls.Items[i];
Tcontrol(pcinfo.control).Parent := pcinfo.parent;
Controls.Remove(pcinfo);
dispose(pcinfo);
end;
end;
end;
if fcallinherited then
msg.result := CallWindowProc(fdefproc, getparent(handle), msg.msg, msg.wparam,
msg.lparam);
end;

procedure Register;
begin
RegisterComponents('My Components', [TCustomOpenDialog]);
end;

end.

save it into a .pas file and register the component.

This component implements three functions

procedure SetDialogSize(width: integer; height: integer);

This procedure lets you set the mount of space you want to leave for your controls.

This function is used to add an already created control to open dialog

function RemoveControl(AControl: TControl): boolean;

This function is used to remove a control from the dialog.

Note that when the opendialogbox is closed all controls added to the dialog are automatically destroyed. So these components cannot be used after the dialog is closed.

An example of how to use the component is  shown below

unit test;

interface

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

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

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
CustomOpenDialog1.SetDialogSize(600, 325);
image1.left := 430;
image1.top := 35;
CustomOpenDialog1.execute;
end;

procedure TForm1.CustomOpenDialog1SelectionChange(Sender: TObject);
begin
try
except
end;
end;

end.

## 2007. június 15., péntek

### Auto-search in ComboBox or ListBox

Problem/Question/Abstract:

How to realise automatic search feature in ComboBox?

For including this functionality we shall just handle KeyPress event of ListBox or ComboBox.
Below is demonstartion of this realisation:

type
TForm = class(TForm)
{....... }
private
FSearchStr: string;
end;

2. Add initialisation of this string variable in Form's OnCreate event:

FSearchStr := '';

3. Type the following code in OnKeyPress event of ListBox or ComboBox:

procedure TForm1.ListBox1KeyPress(Sender: TObject; var Key: Char);
var
i: Integer;
begin
case Key of
#27:
begin
// Escape key, clear search string
FSearchStr := EmptyStr;
end; { Case Esc }
#8:
begin
// backspace, erase last key from search string
if Length(FSearchStr) > 0 then
Delete(FSearchStr, Length(FSearchStr), 1);
end; { Case backspace }
else
FSearchStr := FSearchStr + Key;
end; { Case }
if Length(FSearchStr) > 0 then
if Sender is TListbox then
begin
i := SendMessage(TListbox(Sender).handle, LB_FINDSTRING,
TListbox(Sender).ItemIndex, longint(@FSearchStr[1]));
if i <> LB_ERR then
TListbox(Sender).ItemIndex := i;
end
else if Sender is TCombobox then
begin
i := SendMessage(TCombobox(Sender).handle, CB_FINDSTRING,
TCombobox(Sender).ItemIndex, longint(@FSearchStr[1]));
if i <> LB_ERR then
TCombobox(Sender).ItemIndex := i;
end;
Key := #0;
end;

Now you'll see how it will work.

## 2007. június 14., csütörtök

### Function to work with icons in DLL, EXE and ICO files

Problem/Question/Abstract:

There are a list of solution, but those are what i personally use for that work.

You need to include the ShellAPI unit in your uses clausole!

// This returns how many icons are in a file.

function DLLIconsCount(FileName: string): Integer;
var
IconaGrande: HIcon;
IconaPiccola: HIcon;
begin
Result := 0;
if (FileExists(FileName)) then
begin
Result := ExtractIconEx(PChar(FileName), -1, IconaGrande, IconaPiccola, 0);
end;
end;

// This returns if there're icons in a file

function DLLHasIcons(FileName: string): Boolean;
begin
Result := (DLLIconsCount(FileName) > 0);
end;

// This returns a TIcon for a given file and index.

function GetDLLIcon(FileName: string; Index: Integer = 0): TIcon;
begin
Result := TIcon.Create;
Result.Handle := 0;
if (DLLHasIcons(FileName)) then
begin
try
if (Index < 0) then
Index := 0;
if (Index > DLLIconsCount(FileName)) then
Index := DLLIconsCount(FileName);
Result.Handle := ExtractIcon(0, PChar(FileName), Index);
finally
end;
end;
end;

// This saves an icon from a DLL (EXE or ICO) to a ICO file.

function ExportDLLIcon(OutputFile, InputFile: string; Index: Integer = 0): Boolean;
var
Icona: TIcon;
begin
Result := False;
Icona := GetDLLIcon(InputFile, Index);
if (not (Icona.Handle = 0)) then
try
Icona.SaveToFile(OutputFile);
finally
if (FileExists(OutputFile)) then
Result := True;
end;
Icona.Destroy;
end;

// This is like ExportDLLIcon, but it saves a bitmap file.

function ExportDLLIconAsBitmap(OutputFile, InputFile: string; Index: Integer = 0):
Boolean;
var
Icona: TIcon;
Immagine: TBitmap;
begin
Result := False;
Icona := GetDLLIcon(InputFile, Index);
Immagine := TBitmap.Create;
if (not (Icona.Handle = 0)) then
try
Immagine.Assign(Icona);
Immagine.SaveToFile(OutputFile);
finally
if (FileExists(OutputFile)) then
Result := True;
end;
Icona.Destroy;
Immagine.Destroy;
end;

## 2007. június 13., szerda

### Display custom hint messages in a TOpenDialog

Problem/Question/Abstract:

I would like to modify the behavior of the standard OpenDialog component in Delphi 6 to show my custom hints when the mouse pointer is over particular file shown on the OpenDialog screen. By default the screen shows a hint with the file extension and size. I tried to access the (supposedly) integrated component on the dialog screen in a similar way I have done with the QuickReport standard preview screen (not the Preview component from the palette) - using client.parent. I realize that the implementation of the OpenDialog may directly reference Windows DLLs.Is there a way I could implement custom hint messages?

Well, it should be possible, but it will be awkward. The TOpenDialog is not a component wrapper around a control you could easily subclass, it is a wrapper around an API function that shows a dialog. The dialog contains a number of Windows controls, among which is the listview that shows the files. The listviews parent will get WM_NOTIFY messages from the listview (heaps of them, in fact), among which is the notification asking for the tooltip text. You need to subclass the parent the API way to get hold of this message. A place to do this is the TOpenDialogs OnShow event. The parent handle is not the components Handle property, by the way, you need to go one level up via Windows.GetParent to get the dialog boxes true handle. Do a recursive EnumChildWindow on this handle to investigate the control hierarchy on the dialog. I dimly remember that the listview and its container gets created after OnShow, so you may have to delay the enumeration via PostMessage.

The following gets the listview's handle, the listview is recreated by the dialog as needed so you have to retrieve the handle each time you want to access it.

{ ... }
type
pWndSt r = ^hWndStr;
hWndStr = record
lpStr: string;
hWnd: HWND;
end;

function ClassProc(hWnd: HWND; p: pWndStr): Boolean; stdcall;
var
strBuf: array[0..20] of Char;
begin
FillChar(strBuf, SizeOf(strBuf), #0);
GetClassName(hWnd, @strBuf[0], 20);
if StrPas(strBuf) = p^.lpStr then
begin
Result := False;
p^.hWnd := hWnd;
end
else
Result := True;
end;

function ChildByClass(hWnd: HWND; lpzClass: string): HWND;
var
p: pWndStr;
begin
New(p);
p^.lpStr := lpzClass;
p^.hWnd := 0;
EnumChildWindows(hWnd, @ClassProc, Longint(p));
Result := p^.hWnd;
Dispose(p);
end;

function TOpenPictureDialogEx.SystemLVHWND: HWND;
begin
{Handle here is the TOpenPictureDialogEx's Handle as this is
a decendant of TOpenPictureDialog.}
result := ChildByClass(GetParent(Handle), 'SysListView32');
end;

## 2007. június 12., kedd

### How to fix the color and drop shadow glitches in the TActionMainMenuBar component

Problem/Question/Abstract:

The ActionMainMenuBar highlight color is always blue, even if I have the green theme selected (the highlights should be green). How do I fix this? If I turn of menu shadows in Windows, my app still shows menu shadows, so how do I use the Shadows property to detect and fix this? Under Windows XP when XP Manifest is included, the file menu shadow does not draw properly. Actually it is the right border which does not draw properly. It is missing, it is a 3 sided box. How do I fix this?

Here is a solution I found to address all three problems I reported. Everything seems to be good now and finally I can use this component. First I created a new color map component which detects the correct colors (based on the XPColorMap component). See below for the source. This fixes the color problem and the 3-sided menu box problem. Even if the user changes themes during the application, the menus will update with the new colors!

procedure TForm1.PopupActionBarEx1Popup(Sender: TObject);
var
begin
if CheckWin32Version(5, 1) and SystemParametersInfo(SPI_GETDROPSHADOW, 0,
end;

The new color map component:

unit XPColorMapEx;

interface

uses
Windows, SysUtils, Classes, ActnMan, Graphics, GraphUtil;

type
TXPColorMapEx = class(TCustomActionBarColorMap)
public
{ Public declarations }
procedure UpdateColors; override;
published
{ Published declarations }
property Color;
property DisabledColor;
property DisabledFontColor;
property FontColor;
property HighlightColor;
property HotColor;
property HotFontColor;
property FrameTopLeftInner;
property FrameTopLeftOuter;
property FrameBottomRightInner;
property FrameBottomRightOuter;
property BtnFrameColor;
property BtnSelectedColor;
property SelectedColor;
property SelectedFontColor;
property UnusedColor;
property OnColorChange;
end;

procedure Register;

implementation

{ Merge the two colors using the alpha percentage }

function BlendColors(First, Second: TColor; Alpha: Integer): TColor;
var
fR, fG, fB, sR, sG, sB: Integer;
begin
fR := GetRValue(First);
fG := GetGValue(First);
fB := GetBValue(First);
sR := GetRValue(Second);
sG := GetGValue(Second);
sB := GetBValue(Second);
Result := RGB(Round(((Alpha * fR) + ((100 - Alpha) * sR)) / 100), Round(((Alpha * fG) + ((100 - Alpha) * sG)) / 100), Round(((Alpha * fB) + ((100 - Alpha) * sB)) / 100));
end;

procedure TXPColorMapEx.UpdateColors;
begin
inherited;
Color := clBtnFace;
BtnFrameColor := GetSysColor(COLOR_HIGHLIGHT);
BtnSelectedColor := GetSysColor(COLOR_BTNFACE);
DisabledFontColor := clGrayText;
DisabledColor := clGray;
FontColor := clWindowText;
FrameTopLeftInner := clWhite;
FrameTopLeftOuter := \$007A868A;
FrameBottomRightInner := clWhite;
FrameBottomRightOuter := \$007A868A;
HighlightColor := GetHighLightColor(clBtnFace, 15);
HotColor := clDefault;
HotFontColor := clDefault;
SelectedColor := BlendColors(GetSysColor(COLOR_HIGHLIGHT), clWhite, 33);
SelectedFontColor := clBlack;
UnusedColor := GetHighLightColor(clBtnFace, 15);
end;

procedure Register;
begin
RegisterComponents('Samples', [TXPColorMapEx]);
end;

end.

## 2007. június 11., hétfő

### Find a word in an Array of String

Problem/Question/Abstract:

How to find a word in an Array of String

{ ... }
const
StringsToSearch: array[0..7] of string = ('hello', 'earth', 'why', 'this', '12',
'people', 'how', 'what');
var
Found: Boolean;
i: Integer;
begin
Found := False;
for i := 0 to 7 do
if Pos(StringsToSearch[i], ALongLongLongString) > 0 then
begin
Found := True;
break;
end;
if Found then
ShowMessage('At least one word was found')
else
ShowMessage('No words found');
end;

## 2007. június 10., vasárnap

### Setting environment variables

Problem/Question/Abstract:

There have been various articles showing how to access the environment variables. This article shows how to create, modify and delete an environment variable.

The following simple routine stores a new value in an environment variable. If the the environment variable doesn't exists then it is created. Setting an environment variable to the empty string deletes the variable. The function returns 0 if the variable is set / created successfully, or returns a Windows error code on failure. Note that there is a limit on the amount of space available for environment variables.

function SetEnvVarValue(const VarName,
VarValue: string): Integer;
begin
// Simply call API function
if Windows.SetEnvironmentVariable(PChar(VarName),
PChar(VarValue)) then
Result := 0
else
Result := GetLastError;
end;

It should be noted that changes to environment variables only apply to the current process or to any child processes spawned by the current process.

To pass a custom environment variable to a child process simply:

Create the new environment variable using SetDOSEnvVar.
Execute the new program.

So, to pass the current environment + a an environment variable FOO=Bar to a child process do:

{ snip ... }
var
ErrCode: Integer;
begin
ErrCode := SetEnvVarValue('FOO', 'Bar');
if ErrCode = 0 then
WinExec('MyChildProg.exe', SW_SHOWNORMAL);
else
ShowMessage(SysErrorMessage(ErrCode));
end;
{ ... end snip }

The new program can access the new variable using any of the techniques described in other articles.

It is also possible to pass a custom environment variable block to another process. The method for doing this is covered by another article.

A demo program that demonstrates this and other environment variable techniques is available for download here.

## 2007. június 9., szombat

### Extract WAV files from Audio CD

Problem/Question/Abstract:

Not a real, professional way, but it works. You can also select what tipe of file to grab (bitrate, mono/stereo, Hz).

(don't know if it work on NT / 2000)

\Windows\System\IOSubSys directory.

I suppose it needs a reboot.

In your program, in the "Grab" button just put in the function that calculates the location of the file and makes a copy of it.

( probabily this will not work, but it demonstrates how to make)

procedure TfrmMain.cmdGrabClick(Sender: TObject);
var
mHz: string;
mBr: string;
mStereo: string;
mTrack: string;
mFile: string;
begin
case rgHz.ItemIndex of
0: mHz := '11025kHz';
1: mHz := '22050kHz';
2: mHz := '44100kHz';
else
mHz := '48000kHz';
end;
if (rgBr.ItemIndex = 0) then
mBr := '8bit'
else
mBr := '16bit';
if (chkStereo.Cheched) then
mStereo := 'Stereo'
else
mStereo := 'Mono';
mTrack := 'Track ' + cboTrack.Text + '.wav';

mFile := cboDrive.Text + ':\' + mStereo + '\' + mHz + '\' + mBr + '\' + mTrack;
// Copy now the file in mFile.

end;

## 2007. június 8., péntek

### Get notified: CD in/out

Problem/Question/Abstract:

Need to know when the user inserts/extracts a CD?

there's a message you can intercept to know this: WM_DEVICECHANGE

so... the rest is easy on the private section of your form, declare the function:

Private
{ Private declarations }

procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;

the implement it:

procedure TForm1.WMDeviceChange(var Msg: TMessage);
const
CD_IN = \$8000;
CD_OUT = \$8004;
begin
inherited;
case Msg.wParam of
CD_IN: ShowMessage('CD in'); //or do whatever you want!!
CD_OUT: ShowMessage('CD out')
end
end;

that's it... you'll receive a message when you put a CD in/out... try it then just instead of showing 'CD in'/'CD out'... do whatever you want

## 2007. június 7., csütörtök

### Merge the sections of two TIniFiles

Problem/Question/Abstract:

Imagine there are two win.ini files and I want to combine both together. Some of the common sections and keys/ values are the same in each but they differ in their data generally. How could I merge the two together to get an ini file that contains all the data from both in the right places?

Iterate over the sections in the source file. For each section, iterate over the names. If there is a name in Source that already exists in Dest, Dest's copy will be overwritten.

{ ... }
var
Source, Dest: TIniFile;
SectionNames: TStrings;
i: Integer;
begin
SectionNames := TStringList.Create;
try
for i := 0 to SectionNames.Count - 1 do
begin
MergeSection(Source, Dest, SectionNames[i]);
end;
finally
SectionNames.Free;
end;
end;

procedure MergeSection(Source, Dest: TIniFile; const SectionName: string);
var
i: Integer;
Section: TStrings;
Name, Value: string;
begin
Section := TStringList.Create;
try
for i := 0 to Section.Count - 1 do
begin
Name := Section.Names[i];
Value := Section.Values[Name];
Dest.WriteString(SectionName, Name, Value);
end;
finally
Section.Free;
end;
end;

## 2007. június 6., szerda

### Create/Alter/Delete tables and fields in Access using SQL

Problem/Question/Abstract:

How to Create/Alter/Delete tables and fields in Access using SQL

How to Create a Table in Access Using SQL

Even if you don't have the ability to run Access on your PC, you can still create tables in an Access database using ASP and SQL.

Here is a general look at the "Create Table" command:

CREATE TABLE tablename (
id Counter Primary Key,
fieldname_1 type NOT NULL,
fieldname_2 type NOT NULL
);

Notes:

Be sure to NOT modify the section "id Counter Primary Key" Every table you create should have an auto-incrementing primary key field. Always naming this field "id" is a good practice as well.
Be sure to replace "tablename" with the actual name you want to call your new table.
Be sure to replace "fieldname_1" and "fieldname_2" with the actual field names you want in your new table. You can have as many fields as you need, not just two!
Be sure to replace "type" with the actual type of data you want your field to hold.
Some valid options for "type" include:
Counter - An auto-incrementing number.
Currency - Used for holding financial numbers.
Datetime - Used to hold formal date and time information. However, it is easier to make date fields using "Text(50)" instead of actual "datetime" fields. Every database uses a different deafult format for dates, and it is difficult to keep track. So the easiest method is to hold dates in a text field and translate that to an actual date in your programming language of choice rather than having the database keep track of an actual formatted date.
Long - A number that can include decimal places.
LongText - A text field that can hold billions of characters.
Text(n) - where n is a number between 1-255, this is the maximum number of characters that can be held in this field.

How to Alter a Table in Access Using SQL

Even if you don't have the ability to run Access on your PC, you can still alter tables in an Access database using ASP and SQL. The examples below use the "Birthdays" table we created in the Create Table tutorial. There are three ways to alter a table in any database: 1) add a column, 2) modify a column, 3) delete a column.

Here is a general look at the "Alter Table" command:

ALTER TABLE tablename ADD/ALTER/DROP COLUMN fieldname type NOT NULL;

Notes:

Be sure to replace "tablename" with the actual name of the table you want to modify.
Be sure to select only one action from "ADD/ALTER/DROP" depending on how you want to modify your table.
Be sure to replace "fieldname" with the actual field name you want to modify in your table.
Be sure to replace "type" with the actual type of data you want your field to hold.
Some valid options for "type" include:
Counter - An auto-incrementing number.
Currency - Used for holding financial numbers.
Datetime - Used to hold formal date and time information. However, it is easier to make date fields using "Text(50)" instead of actual "datetime" fields. Every database uses a different deafult format for dates, and it is difficult to keep track. So the easiest method is to hold dates in a text field and translate that to an actual date in your programming language of choice rather than having the database keep track of an actual formatted date.
Long - A number that can include decimal places.
LongText - A text field that can hold billions of characters.
Text(n) - where n is a number between 1-255, this is the maximum number of characters that can be held in this field.

Part 1 - Adding a column to a table

The following SQL statement will add a column called "zodiac_sign" to our table (zodiac_sign will be a text column with a maximum length of 50 characters):

ALTER TABLE Birthdays ADD COLUMN zodiac_sign Text(50) NOT NULL;

Part 2 - Modifying a column in a table

The following SQL statement will modify the field called "dob" in our table by changing it from a text field to a datetime field. (zodiac_sign will be a text column with a maximum length of 50 characters):

ALTER TABLE Birthdays ALTER COLUMN dob datetime NOT NULL;

Part 3 - Deleting a column from a table

The following SQL statement will delete the field called "zodiac_sign" from our table:

ALTER TABLE Birthdays DROP COLUMN zodiac_sign;

How to Delete a Table in Access Using SQL

Here is a general look at the "Drop Table" command:

DROP TABLE tablename;

Notes:

Be sure to replace "tablename" with the actual name of the table you want to delete.

## 2007. június 5., kedd

### Combine multiple wave files into a single one

Problem/Question/Abstract:

Does anyone have a snippet of code in Delphi to combine multiple WAV files into one? I am writing a very simple text-to-speech application for Chinese pronounciation. I have all the wave files needed to synthesize Chinese pronounciation (506 files in all). Now, all I need is the ability to create one wave file based on a list of multiple wave files which are in a specific order.

This one should work with any PCM format as long as all files are the same format:

procedure JoinWaves(FileList: TStrings; OutputFile: string);
{All files must be of the same format}
var
I: Integer;
FileSize: LongInt;
InStream, OutStream: TFileStream;
begin
OutStream := TFileStream.Create(OutputFile, fmCreate);
try
for I := 0 to FileList.Count - 1 do
if FileExists(FileList[I]) then
begin
try
if I = 0 then
OutStream.CopyFrom(InStream, InStream.Size)
else if InStream.Size > 44 then
begin
InStream.Position := 44;
OutStream.CopyFrom(InStream, InStream.Size - 44);
end;
finally
InStream.Free;
end;
end;
OutStream.Position := 4;
FileSize := OutStream.Size - 8;
OutStream.WriteBuffer(FileSize, SizeOf(FileSize));
OutStream.Position := 40;
FileSize := OutStream.Size - 44;
OutStream.WriteBuffer(FileSize, SizeOf(FileSize));
finally
OutStream.Free;
end;
end;

## 2007. június 4., hétfő

### Find out what is you IP adress

Problem/Question/Abstract:

If you want to find out what is your actual IP, this is the right thing for you.

Start by creating a new application. Add a Button and two Edit Boxes to your project. Remember not to name them. Just leave them the way they are. In the unit add to uses: winsock.
After that double click on the Button you have just created and in the unit paste the following script instead of the begin function:

function GetIPFromHost
(var HostName, IPaddr, WSAErr: string): Boolean;
type
Name = array[0..100] of Char;
PName = ^Name;
var
HEnt: pHostEnt;
HName: PName;
i: Integer;
begin
Result := False;
if WSAStartup(\$0101, WSAData) <> 0 then begin
WSAErr := 'Winsock is not responding."';
Exit;
end;
New(HName);
if GetHostName(HName^, SizeOf(Name)) = 0 then
begin
HostName := StrPas(HName^);
HEnt := GetHostByName(HName^);
for i := 0 to HEnt^.h_length - 1 do
Result := True;
end
else begin
case WSAGetLastError of
WSANOTINITIALISED:WSAErr:='WSANotInitialised';
WSAENETDOWN      :WSAErr:='WSAENetDown';
WSAEINPROGRESS   :WSAErr:='WSAEInProgress';
end;
end;
Dispose(HName);
WSACleanup;
end;

var
Host, IP, Err: string;
begin
if GetIPFromHost(Host, IP, Err) then begin
Edit1.Text := Host;
Edit2.Text := IP;
end
else
MessageDlg(Err, mtError, [mbOk], 0);
end;

After pasting all this just delete the other end; that is left at the end of the source. That's it. This source was not originally made by me but was modified by me. Hope you find it useful. Good luck!

## 2007. június 3., vasárnap

### Change font color, size, style, and back color of certain words inside a rich edit

Problem/Question/Abstract:

Do you want to have a nice looking rich edit?

This procedure will search and change the attributes (font name, font size, font color, font style, and back color) of certain words inside a rich edit control.  Try the example.

type
TTextAttributes = record
Font: TFont;
BackColor: TColor;
end;
{..}

procedure SetTextColor(oRichEdit: TRichEdit; sText: string; rAttributes:
TTextAttributes);
var
iPos: Integer;
iLen: Integer;

Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
Format.cbSize := SizeOf(Format);
Format.crBackColor := rAttributes.BackColor;

iPos := 0;
iLen := Length(oRichEdit.Lines.Text);
iPos := oRichEdit.FindText(sText, iPos, iLen, []);

while iPos <> -1 do
begin
oRichEdit.SelStart := iPos;
oRichEdit.SelLength := Length(sText);
oRichEdit.SelAttributes.Color := rAttributes.Font.Color;
oRichEdit.SelAttributes.Size := rAttributes.Font.Size;
oRichEdit.SelAttributes.Style := rAttributes.Font.Style;
oRichEdit.SelAttributes.Name := rAttributes.Font.Name;

oRichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));

iPos := oRichEdit.FindText(sText, iPos + Length(sText), iLen, []);
end;
end;

Example:

var
rAttrib: TTextAttributes;
begin
rAttrib.Font := TFont.Create;
rAttrib.Font.Color := clWhite;
rAttrib.Font.Size := 16;
rAttrib.Font.Style := [fsBold];
rAttrib.BackColor := clRed;

SetTextColor(RichEdit1, 'Delphi', rAttrib);

//Change another word attributes.
rAttrib.Font.Color := clYellow;
rAttrib.Font.Size := 10;
rAttrib.Font.Style := [fsBold, fsItalic];
rAttrib.BackColor := clBlue;

SetTextColor(RichEdit1, 'Is greate', rAttrib);

rAttrib.Font.Free; //Now free the font.
end;

## 2007. június 2., szombat

### Show bullets in a TRichEdit

Problem/Question/Abstract:

How to show bullets in a TRichEdit?

uses
RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
var
fmt: TParaformat2;
begin
FillChar(fmt, SizeOf(fmt), 0);
fmt.cbSize := SizeOf(fmt);
// The PARAFORMAT2 structure is used to set the numbering style.
// This is done through the following structure members:
fmt.dwMask := PFM_NUMBERING or PFM_NUMBERINGSTART or PFM_NUMBERINGSTYLE or
PFM_NUMBERINGTAB;
// Set the following values (bitwise-or them together) to identify
// which of the remaining structure members are valid:
// PFM_NUMBERING, PFM_NUMBERINGSTART, PFM_NUMBERINGSTYLE, and PFM_NUMBERINGTAB
fmt.wNumbering := 2;
//0 no numbering or bullets
//1 (PFN_BULLET) uses bullet character
//2 Uses Arabic numbers (1, 2, 3, ...).
//3 Uses lowercase letters (a, b, c, ...).
//4 Uses uppercase letters (A, B, C, ...).
//5 Uses lowercase Roman numerals (i, ii, iii, ...).
//6 Uses uppercase Roman numerals (I, II, III, ...).
//7 Uses a sequence of characters beginning with the Unicode
//  character specified by the wNumberingStart member.
fmt.wNumberingStart := 1;
//  Starting value for numbering.
fmt.wNumberingStyle := \$200;
// Styles for numbering:
// 0 : Follows the number with a right parenthesis.  1)
// \$100 : Encloses the number in parentheses.       (1)
// \$200 : Follows the number with a period.          1.
// \$300 : Displays only the number.                  1
// \$400 : Continues a numbered list without applying the next number or bullet.
// \$8000 : Starts a new number with wNumberingStart.
fmt.wNumberingTab := 1440 div 4;
// Minimum space between a paragraph number and the paragraph text, in twips

RichEdit1.Perform(EM_SETPARAFORMAT, 0, lParam(@fmt));
end;

## 2007. június 1., péntek

### Check if a printer supports postscript

Problem/Question/Abstract:

How to check if a printer supports postscript?

That is really difficult do to if it has to work on all Windows platforms. The best way (no kidding) may be to ask the user which printer to use. What platforms do you need to support? If it is only Win2K (and perhaps XP) one may be able to use this (i have no postscript-enabled printer around to see if it works!):

uses
WinSpool, Printers;

{: Check if the currently selected printer supports postscript.
Only applicable on Win2K/XP! }

function PrinterSupportsPostscript: Boolean;
const
POSTSCRIPT_PASSTHROUGH = 4115;
POSTSCRIPT_IDENTIFY = 4117;

Escapes: array[0..2] of Cardinal =
(POSTSCRIPT_DATA, POSTSCRIPT_IDENTIFY, POSTSCRIPT_PASSTHROUGH);
var
res: Integer;
i: Integer;
begin
Result := false;
for i := Low(Escapes) to High(Escapes) do
begin
res := ExtEscape(printer.Handle,
QUERYESCSUPPORT,
sizeof(Escapes[0]),
@Escapes[i], 0, nil);
if res <> 0 then
begin
Result := true;
Break;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
boolstr: array[Boolean] of string = (' not', '');
var
i: Integer;
S: string;
begin
for i := 0 to Printer.Printers.Count - 1 do
begin
Printer.PrinterIndex := i;