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}