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

Answer:

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.

How to tell what kind of drive is used

Problem/Question/Abstract:

How to tell what kind of drive is used

Answer:

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;

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?

Answer:

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;
      if reg.OpenKeyReadOnly(keyname) then
      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
              S := reg.ReadString(temp[i]);
              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;

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?

Answer:

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.

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

Problem/Question/Abstract:

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

Answer:

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;

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?

Answer:

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;

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

Answer:

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);
    {Load the bitmap file}
    IM.Picture.LoadFromFile(OpenDialog1.FileName);
    {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}
    Image1.Picture.LoadFromFile(TempFileName);
    {Delete the temp file}
    DeleteFile(TempFileName);
  end;
end;

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.

Answer:

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 already had a .backup then it will be overwritten.

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.

FilterLoader.dpr - Main project file
EggFilterLoader.pas - The update engine.
Fn_GetModuleName.pas - Utility to return the name of the module.

FilterLoader.dpr

library FilterLoader;
{
  Author
    William Egge
    egge@eggcentric.com

  Version 1.0
  Original FileName FilterLoader.dpr
  Date: Sep 9, 2001
  Website http://www.eggcentric.com/ISAPIFilterLoader.htm
  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
  and headache of updating your isapi filters.

  Check my website at http://www.eggcentric.com/ISAPIFilterLoader.htm
  for updates or further explaining.
}

uses
  ISAPI2,
  Windows,
  EggFilterLoader;

{$R *.RES}
var
  GEggFilterLoader: IEggFilterLoader = nil;

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

function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
  NotificationType: DWORD;
  pvNotification: Pointer): DWORD; export; stdcall;
begin
  try
    Result := GEggFilterLoader.HttpFilterProc(pfc, NotificationType, pvNotification);
  except // Dont crash IIS
    Result := SF_STATUS_REQ_NEXT_NOTIFICATION;
  end;
end;

exports
  GetFilterVersion,
  HttpFilterProc;

begin
end.

EggFilterLoader.pas

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

  Version 1.0
  Original FileName EggFilterLoader.pas
  Date: Sep 9, 2001
  Website http://www.eggcentric.com/ISAPIFilterLoader.htm
  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
  function CoCreateEggFilterLoader then your main isapi filter
  application should forward all extension calls to the object.
}

interface
uses
  ISAPI2,
  Fn_GetModuleName,
  SysUtils,
  Windows;

type
  IEggFilterLoader = interface
    function GetFilterVersion(var pVer: HTTP_FILTER_VERSION): BOOL;
    function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
      NotificationType: DWORD;
      pvNotification: Pointer): DWORD;
  end;

function CoCreateEggFilterLoader: IEggFilterLoader;

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 =
    //       SF_NOTIFY_READ_RAW_DATA
      {or} SF_NOTIFY_PREPROC_HEADERS
  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
  TEggFilterLoader = class(TInterfacedObject, IEggFilterLoader)
  private
    FLastTimeCheck: LongWord;
    FCheckSync: TMultiReadExclusiveWriteSynchronizer;
    FDLLSync: TMultiReadExclusiveWriteSynchronizer;
    FDLL: HModule;
    FCallbackVersion: TGetFilterVersion;
    FCallbackProc: THttpFilterProc;
    FBackupDLLName, FRunDLLName, FUpdateDLLName: string;
    FFilterFlags: DWord;
    procedure ReloadDLL;
    procedure DoUpdateIfNeeded;
  public
    constructor Create;
    destructor Destroy; override;
    function GetFilterVersion(var pVer: HTTP_FILTER_VERSION): BOOL;
    function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
      NotificationType: DWORD;
      pvNotification: Pointer): DWORD;
  end;

function CoCreateEggFilterLoader: IEggFilterLoader;
begin
  Result := TEggFilterLoader.Create;
end;

{ TEggFilterLoader }

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

destructor TEggFilterLoader.Destroy;
begin
  // unload DLL
  if FDLL <> 0 then
    FreeLibrary(FDLL);
  FDLLSync.Free;
  FCheckSync.Free;
  inherited;
end;

procedure TEggFilterLoader.DoUpdateIfNeeded;
var
  NeedCheck, NeedLoad: Boolean;
begin
  // Quick Check
  FCheckSync.BeginRead;
  try
    NeedCheck := (GetTickCount - FLastTimeCheck) >= WAIT_BEFORE_CHECK;
  finally
    FCheckSync.EndRead;
  end;

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

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

function TEggFilterLoader.GetFilterVersion(
  var pVer: HTTP_FILTER_VERSION): BOOL;
begin
  DoUpdateIfNeeded;
  FDLLSync.BeginRead;
  try
    pVer.dwFilterVersion := MakeLong(0, 1);
    pVer.lpszFilterDesc := 'Eggcentric Filter Loader.';
    pVer.dwFlags := ALL_FLAGS;
    Result := True;
  finally
    FDLLSync.EndRead;
  end;
end;

function TEggFilterLoader.HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
  NotificationType: DWORD; pvNotification: Pointer): DWORD;
begin
  DoUpdateIfNeeded;
  FDLLSync.BeginRead;
  try
    // Check Notification bit to make sure the DLL should be called
    if Assigned(FCallbackProc) and ((NotificationType and FFilterFlags) <> 0) then
      Result := FCallbackProc(pfc, NotificationType, pvNotification)
    else
      Result := SF_STATUS_REQ_NEXT_NOTIFICATION;
  finally
    FDLLSync.EndRead;
  end;
end;

procedure TEggFilterLoader.ReloadDLL;
var
  ShouldReload: Boolean;
  pVer: THTTP_FILTER_VERSION;
begin
  FDLLSync.BeginWrite;
  try
    // First Determine if we really should
    ShouldReload := (FDLL = 0) or FileExists(FUpdateDLLName);
    if ShouldReload then
    begin
      // First unload the DLL
      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
        FDLL := LoadLibrary(PChar(FRunDLLName));
        if FDLL <> 0 then
        begin
          FCallbackVersion := GetProcAddress(FDLL, 'GetFilterVersion');
          FCallbackProc := GetProcAddress(FDLL, 'HttpFilterProc');
          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.


Component Download: http://www.eggcentric.com/Download/ISAPIFilterLoaderSource.zip

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?

Answer:

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.

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.

Answer:

Just add this to your memo keypress event:

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!

Parsing strings

Problem/Question/Abstract:

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

Answer:

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

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?

Answer:

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.

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

Answer:

{
Copyright (c) 1999 by E.J.Molendijk

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.ClientSocket1Read;
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;
  PostAddr = '/cgi-bin/form';

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

procedure T...Form.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // Incoming result data
  FResult := FResult + Socket.ReceiveText;
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;
  HTTP_POST := 'POST http://'+WebServer+PostAddr+' HTTP/1.0'#10;
  {--- 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 ---}

  // Concat the header
  HTTP_Post := HTTP_Post + HTTP_Data;

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

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.

Answer:

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}

Customize the Open Dialog

Problem/Question/Abstract:

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

Answer:

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 AddControl(AControl: TControl): boolean;
    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;

function TCustomOpenDialog.AddControl(AControl: TControl): boolean;
var
  pcinfo: pcontrolinfo;
begin
  result := false;
  if (acontrol is TControl) then
  begin
    new(pcinfo);
    pcinfo.control := acontrol;
    pcinfo.parent := TControl(acontrol).parent;
    Controls.Add(pcinfo);
    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.

function AddControl(AControl: TControl): boolean;

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);
  CustomOpenDialog1.AddControl(image1);
  image1.left := 430;
  image1.top := 35;
  CustomOpenDialog1.execute;
end;

procedure TForm1.CustomOpenDialog1SelectionChange(Sender: TObject);
begin
  try
    image1.Picture.LoadFromFile(CustomOpenDialog1.FileName);
  except
  end;
end;

end.

Auto-search in ComboBox or ListBox

Problem/Question/Abstract:

How to realise automatic search feature in ComboBox?

Answer:

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

1. Add string variable to your form:

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.

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.

Answer:

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;

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?

Answer:

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;

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?

Answer:

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!

To fix the shadow problem do this on your menu's popup event. It checks if the shadows option is enabled in Windows.

procedure TForm1.PopupActionBarEx1Popup(Sender: TObject);
var
  DisplayShadow: Boolean;
begin
  if CheckWin32Version(5, 1) and SystemParametersInfo(SPI_GETDROPSHADOW, 0,
    @DisplayShadow, 0) then
    PopupActionBarEx1.Shadows := DisplayShadow;
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 ShadowColor;
    property Color;
    property DisabledColor;
    property DisabledFontColor;
    property DisabledFontShadow;
    property FontColor;
    property HighlightColor;
    property HotColor;
    property HotFontColor;
    property MenuColor;
    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;
  MenuColor := clWindow;
  BtnFrameColor := GetSysColor(COLOR_HIGHLIGHT);
  BtnSelectedColor := GetSysColor(COLOR_BTNFACE);
  DisabledFontColor := clGrayText;
  DisabledFontShadow := clBtnHighlight;
  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;
  ShadowColor := cl3DDkShadow;
  UnusedColor := GetHighLightColor(clBtnFace, 15);
end;

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

end.

Find a word in an Array of String

Problem/Question/Abstract:

How to find a word in an Array of String

Answer:

{ ... }
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;

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.

Answer:

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.

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

Answer:

Simply use that trick to made your rippers/grabers:

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

Download the substitutive FSCD.VXD from the Net and substitute to your original located in
\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;

Get notified: CD in/out

Problem/Question/Abstract:

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

Answer:

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

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?

Answer:

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
    Source.ReadSections(SectionNames);
    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
    Source.ReadSection(SectionName, Section);
    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;

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

Answer:

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.

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.

Answer:

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
InStream := TFileStream.Create(FileList[I], fmOpenRead);
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;

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.

Answer:

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;
WSAData: TWSAData;
i: Integer;
begin
Result := False;
if WSAStartup($0101, WSAData) <> 0 then begin
WSAErr := 'Winsock is not responding."';
Exit;
end;
IPaddr := '';
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
IPaddr :=
Concat(IPaddr,
IntToStr(Ord(HEnt^.h_addr_list^[i])) + '.');
SetLength(IPaddr, Length(IPaddr) - 1);
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!

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?

Answer:

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.dwMask := CFM_BACKCOLOR;
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;

Show bullets in a TRichEdit

Problem/Question/Abstract:

How to show bullets in a TRichEdit?

Answer:

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;

Check if a printer supports postscript

Problem/Question/Abstract:

How to check if a printer supports postscript?

Answer:

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;
memo1.Lines.add(
Format('Printer %s does%s support Postscript',
[printer.printers[printer.printerindex],
boolstr[PrinterSupportsPostscript]]));
end;
end;