How to hide the scrollbars of a MDI child form

Problem/Question/Abstract:

With Delphi 5, how can I hide the scrollbars on a MDI Form? I tried to set the properties AutoScroll, HorzScrollBar.Visible, VertScrollBar.visible to false but it had no effect.

Answer:

This has no effect since the scrollbars do not belong to the MDI frame window itself, they belong to the client window, which is not a Delphi form. Which means one has to attack the problem on the API level. Since this question has come up so frequently in recent days I have modified a sample based on the stock MDI project to include this feature. The salient parts are quoted below.

Open the main forms unit in the IDE. If you don't have a handler for the OnCreate event, add one. In the handler you do this:


if ClientHandle <> 0 then
begin
  if GetWindowLong(ClientHandle, GWL_USERDATA) <> 0 then
    Exit; {cannot subclass client window, userdata already in use}
  SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong(ClientHandle,
    GWL_WNDPROC, integer(@ClientWindowProc)));
end;


Add a new standalone function to the unit, it has to go above the FormCreate method since it is referenced in the statement above:


function ClientWindowProc(wnd: HWND; msg: Cardinal; wparam, lparam: Integer): Integer;
  stdcall;
var
  f: Pointer;
begin
  f := Pointer(GetWindowLong(wnd, GWL_USERDATA));
  case msg of
    WM_NCCALCSIZE:
      begin
        if (GetWindowLong(wnd, GWL_STYLE) and (WS_HSCROLL or WS_VSCROLL)) <> 0 then
          SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE)
            and not (WS_HSCROLL or WS_VSCROLL));
      end;
  end;
  Result := CallWindowProc(f, wnd, msg, wparam, lparam);
end;


I clipped this code from a larger project, so let's hope I did not create errors in the process. What this code does is to subclass the client window the API way. It stores the old window function into the GWL_USERDATA field of the window structure since it is needed in the replacement window function, all messages need to be passed on to the old window function. There is only one message of interest in this case (the use of a Case results from the larger project, which handles more than this message): WM_NCCALCSIZE. The window gets this message when Windows tries to hide or show the scrollbars, among other cases. And it arrives *before* there is any painting of the scrollbar. So we can check if the window is going to sprout scrollbars and simply remove the scrollbar styles again.

For the purists: there is no need to undo the subclassing before the form is destroyed since the client window is destroyed before the form object.

Simulate a mouse click on our form (control)

Problem/Question/Abstract:

Simulate a mouse click on our form (control)

Answer:

This is easily done by position the mouse cursor onto the form using SetCursorPos, then using mouse_event to fake a mouse click.


// click in upper-left corner, 50 pixels inward
  SetCursorPos(Form1.Left + 50, Form1.Top + 50);
� mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
� mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);

Execute a file by its extension and wait to finish

Problem/Question/Abstract:

Execute/open any file with the associated application, waiting until it finish.

Answer:

We will make it thanks to the function of the API ShellExecuteEx

Here the code is:

Add 'ShellApi' in the uses of your form


procedure TForm1.Button1Click(Sender: TObject);

  procedure RunAndWaitShell(Ejecutable,
                            Argumentos:string
                            ;Visibilidad:integer);
  var
     Info:TShellExecuteInfo;
     pInfo:PShellExecuteInfo;
     exitCode:DWord;
  begin
     {Puntero a Info}
     {Pointer to Info}
     pInfo:=@Info;
     {Rellenamos Info}
     {Fill info}
     with Info do
     begin
      cbSize:=SizeOf(Info);
      fMask:=SEE_MASK_NOCLOSEPROCESS;
      wnd:=Handle;
      lpVerb:=nil;
      lpFile:=PChar(Ejecutable);
      {Parametros al ejecutable}
      {Executable parameters}
      lpParameters:=Pchar(Argumentos+#0);
      lpDirectory:=nil;
      nShow:=Visibilidad;
      hInstApp:=0;
     end;
     {Ejecutamos}
     {Execute}
     ShellExecuteEx(pInfo);

     {Esperamos que termine}
     {Wait to finish}
     repeat
      exitCode := WaitForSingleObject(Info.hProcess,500);
      Application.ProcessMessages;
     until (exitCode <> WAIT_TIMEOUT);
  end;

begin
  RunAndWaitShell('c:\windows\notepad.exe','c:\autoexec.bat',Sw_ShowNormal);
end;

If we call to an executable, this it will be executed.
If we call to a non executable file, the function will execute its associate application.

For example, to open a file HTML with the default browser of the system:

RunAndWaitShell('c:\kk\registro.html', '', Sw_ShowNormal);

We can also execute and wait to finish a DOS program.

For example, this opens my DOS editor QEdit to edit the Autoexec.bat:

RunAndWaitShell('c:\discoc\tools\q.exe', 'c:\autoexec.bat', Sw_ShowNormal);

How to center a TOpenDialog on a form

Problem/Question/Abstract:

How to center a TOpenDialog on a form

Answer:

{ ... }
type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure OpenDialog1Show(Sender: TObject);
  private
    { Private declarations }
    procedure MoveDialog(var Msg: TMessage); message WM_USER;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Execute;
end;

procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
  PostMessage(Self.Handle, WM_USER, 0, 0);
end;

procedure TForm1.MoveDialog(var Msg: TMessage);
var
  rec: TRect;
  wh: HWND;
  l, t, r, b: Integer;
begin
  if ofOldStyleDialog in OpenDialog1.Options then
    wh := OpenDialog1.Handle
  else
    wh := Windows.GetParent(OpenDialog1.Handle);
  if IsWindow(wh) then
    if GetWindowRect(wh, rec) then
    begin
      l := (Width - (rec.Right - rec.Left)) div 2 + Left;
      t := (Height - (rec.Bottom - rec.Top)) div 2 + Top;
      r := rec.Right - rec.Left;
      b := rec.Bottom - rec.Top;
      MoveWindow(wh, l, t, r, b, True);
    end;
end;

How to store records to a stream for later retrieval

Problem/Question/Abstract:

How to store records to a stream for later retrieval

Answer:

Stores a record to stream. Record can later be retrieved with RecordFromStream procedure.

procedure RecordToStream
  (DSet: TDataSet; {Dataset in question}
  Stream: TStream; {Stream to store to}
  PhysFieldsOnly: Boolean; {Do not store lookup and calculated fields}
  FieldsNotStore: array of TField); {Additional fields that should not be stored}

  function DoStoreFld(aFld: TField): Boolean;
    {Checks whether the field should be stored}
  var
    i: Integer;
  begin
    Result := not PhysFieldsOnly or (aFld.FieldNo > 0);
    {FieldNo of Lookup and calculated fields is <= 0}
    if Result then
      for i := 0 to High(FieldsNotStore) do
        if aFld = FieldsNotStore[i] then
        begin
          Result := false;
          break;
        end;
  end;

  procedure WriteFldname(fldname: string);
  var
    L: longint;
  begin
    L := length(fldname);
    Stream.Write(L, sizeOf(L));
    Stream.Write(fldname[1], L);
  end;

var
  I, Cnt, Len: Longint;
  Fld: TField;
  FldBuff: Pointer;
  BStream: TBlobStream;
begin
  Cnt := DSet.FieldCount;
  Getmem(FldBuff, 256);
  try
    for i := 1 to Cnt do
    begin
      Fld := DSet.Fields[i - 1];
      if not DoStoreFld(Fld) then
        Continue;
      WriteFldname(Fld.Fieldname);
      if Fld is TBlobField then
      begin
        BStream := TBlobStream.Create(Fld as TBlobField, bmRead);
        try
          Len := BStream.Size;
          Stream.Write(len, SizeOf(Len));
          Stream.CopyFrom(BStream, Len);
        finally
          BStream.Free;
        end;
      end
      else
      begin
        Len := Fld.dataSize;
        Fld.Getdata(FldBuff);
        Stream.Write(Len, SizeOf(Len));
        Stream.Write(FldBuff^, Len);
      end;
    end;
    Len := 0;
    {Mark the end of the stream with zero}
    Stream.Write(Len, SizeOf(Len));
  finally
    Freemem(FldBuff, 256);
  end;
end;

Reads record from the stream. The record was previously stored with RecordToStream procedure. Dset must be in edit/insert mode.

procedure RecordFromStream
  (DSet: TDataSet; {Dataset in question}
  Stream: TStream; {Stream to retrieve from}
  FieldsToIgnore: array of TField); {Fields that should not be retrieved}

  function DoReadFld(aFld: tField): Boolean;
  var
    i: Integer;
  begin
    Result := (aFld <> nil) and (aFld.FieldNo > 0);
    {calculated and lookup fields are allways ignored}
    if Result then
      for i := 0 to High(FieldsToIgnore) do
        if aFld = FieldsToIgnore[i] then
        begin
          Result := false;
          break;
        end;
  end;

  function ReadFldname: string;
  var
    L: longint;
  begin
    Stream.Read(L, sizeOf(L));
    if L = 0 then
      result := ''
    else
    begin
      SetLength(Result, L);
      Stream.Read(Result[1], L);
    end;
  end;

var
  Len: Longint;
  Fld: TField;
  Fldname: string;
  FldBuff: Pointer;
begin
  Getmem(FldBuff, 256);
  try
    Fldname := ReadFldname;
    while Fldname <> '' do
    begin
      if Fldname = '' then
        break;
      Fld := DSet.FindField(Fldname);
      Stream.Read(Len, SizeOf(Len));
      if DoReadFld(Fld) then
      begin
        if Fld is TBlobField then
        begin
          with TBlobStream.Create(Fld as TBlobField, bmWrite) do
          try
            CopyFrom(Stream, Len);
          finally
            Free;
          end;
        end
        else
        begin
          if Fld.datasize <> Len then
            raise Exception.CreateFmt('Field size changed: Field: %s', [Fldname]);
          Stream.Read(FldBuff^, Fld.dataSize);
          Fld.Setdata(FldBuff);
        end;
      end
      else
      begin
        Stream.Seek(Len, soFromCurrent);
      end;
      Fldname := ReadFldname;
    end
  finally
    Freemem(FldBuff, 256);
  end;
end;

How to reposition the cursor in a TEdit

Problem/Question/Abstract:

How to reposition the cursor in a TEdit

Answer:

The example below uses two TEdit's:

unit Cursor;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Edit1Change(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private declarations }
  public
    { Public declarations }
    CurPos: integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Change(Sender: TObject);
begin
  CurPos := Edit1.SelStart;
  edit2.Text := IntToStr(CurPos);
end;

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_LEFT then
    dec(CurPos);
  if Key = VK_RIGHT then
    inc(CurPos); {Right Arrow}
  edit2.text := inttostr(CurPos);
end;

end.

Sorting aTable Using DBISortTable

Problem/Question/Abstract:

How to sort aTable using DBISortTable

Answer:

I'm not a masochist by nature, but having started to delve into the Borland Database Engine has made me rethink that. Well, I shouldn't be too hard on myself. Let me just say that I think Borland should come out with a manual that is specific to Delphi regarding DBI calls. The current manual is written for C/C++ programmers, so if you're not all that familiar with the syntax (or really rusty with it like I am), it's a long process in making the translation to Pascal using the examples. Actually, it really sucks! but that's beside the point. I'll add, though, that once you do learn how to pass the myriad parameters to the functions, it becomes relatively easy - I say relatively because there's a lot that can go wrong, and you'd never know it until you see the results. For example, I was passing the wrong type of parameter in the pSortOrder param. The function ran without a hitch, only to empty my table! ARRRGH!

Before I go on, I advise you to purchase the Borland Database Engine manual from Borland. I think it's only US$15.00, and it's worth it. I will not be discussing the data types, just how to make the call. In any case, here's the code.

The DBIPROCS.INT file lists the function call as follows:

function DbiSortTable({ Sort table }
  hDb: hDBIDb; { Database handle }
  pszTableName: PChar; { Table name of source }
  pszDriverType: PChar; { Driver type /NULL }
  hSrcCur: hDBICur; { OR cursor of table to sort }
  pszSortedName: PChar; { Destination table (NULL if sort to self) }
  phSortedCur: phDBICur; { If non-null, return cursor on destination }
  hDstCur: hDBICur; { OR cursor of destination }
  iSortFields: Word; { Number of sort fields }
  piFieldNum: PWord; { Array of field numbers }
  pbCaseInsensitive: PBool; { Which fields should sort c-i (Opt) }
  pSortOrder: pSORTOrder; { Array of Sort orders (Opt) }
  ppfSortFn: ppfSORTCompFn; { Array of compare fn pntrs (Opt) }
  bRemoveDups: Bool; { TRUE : Remove duplicates }
  hDuplicatesCur: hDBICur; { Cursor to duplicates table (Opt) }
  var lRecsSort: Longint { in/out param. - sort this number }
  ): DBIResult;

And here's a method that uses the call. Mind you, that this will sort only on one field because that was all I needed it to do. If you want to sort on more fields, all you have to do is increase the size of the array (the piFieldNum param) and make sure you make the right field number assignments to the array elements (see the comments in the code below). Okay, here's the code...

uses DBIProcs, DBITypes, DBIErrs {You must add these to your uses section!!!}

{====================================================================================
Sorts a table using the DBISortTable method. The trick here was setting the sort direction.
The pSortOrder is a pointer to an enumerated type. So first you have to set a var that is of that type to an appropriate value, then set a pointer's value to equal the value of the var. It's a real pain.
Note  : This sorts STANDARD driver tables only. To any type, you'd set up a PChar to hold the valid driver type and insert the pointer as a param for driver type in      the DBISortTable declaration. Also, this will sort on only ONE field. Furthermore,
the method will not sort Paradox tables to self (which this does) if the table has a primary index.
   =====================================================================================}

procedure SortATable(dbName, tblName, {Database and Table Name}
  sortOrd: string; {'A' = Ascending 'D' = Descending}
  fldNum: Integer); {The field number to sort on}
var
  msg: string;
  hDb: hDBIDb;
  pOptFldDesc: pFLDDesc;
  pOptParams: pBYTE;
  dbRes: DBIResult;
  dName,
    tName: PChar;
  sOrd: sortOrder;
  pSort: pSortOrder;
  arrFlds: array[0..0] of Integer;
    {This is the array of fieldnums. Note it's only one element large}
  boolVal: Boolean;
  pRecs: LongInt;
begin
  {Initialize vars}
  arrFlds[0] := fldNum; {Set the element to the field number to sort on}
  boolVal := True;
  New(pSort);
  if (sortOrd = 'A') then
    sOrd := sortASCEND
  else
    sOrd := sortDESCEND;
  pSort^ := sOrd; {set the value of the pointer to whatever was passed}
  DBIInit(nil); {initialize the database engine}

  {Now, get a handle to the default database. We won't specify a path just yet }
  dbRes := DBIOpenDatabase(nil, nil, dbiREADWRITE, dbiOPENSHARED, nil, 0,
    @pOptFldDesc, @pOptParams, hDb);
  case dbRes of
    DBIERR_UNKNOWNDB: msg := 'Database specified is unknown. Check your drivers.';
    DBIERR_NOCONFIGFILE: msg := 'No IDAPI.CFG file for this machine. Install BDE.';
    DBIERR_DBLIMIT: msg := 'Maximum number of databases have been opened.
                                                                                                                Close down one and retry';
  end;

  if (dbRes <> DBIERR_NONE) then
  begin
    raise Exception.Create(msg);
    Exit;
  end;
  GetMem(tName, SizeOf(PChar) * 256);
  GetMem(dName, SizeOf(PChar) * 256);
  StrPCopy(tName, tblName);
  StrPCopy(dName, GetAliasPath(dbName));

  {Now set the directory to the specified path of the alias passed.
        Why do this when we can pass the alias to DBIOpenDatabase directly?
  Well, I ran across some really problems doing that, so I decided
  to do it after I got the handle.}

  DBISetDirectory(hDb, dName);

  {Make the call to DbiSortTable, passing the appropriate parameters.
        Note that about half of the parameters are nil.
  That's because they're optional for simple sorts, and since they're pointers,
  you can pass nils.}
  try
    dbRes := DbiSortTable(hDb, tName, nil, nil, nil, nil, nil, 1,
      @arrFlds, @boolVal, pSort, nil, False, nil, pRecs);
    case dbRes of
      DBIERR_INVALIDHNDL: msg := 'Invalid database handle - alias bad';
      DBIERR_INVALIDFILENAME: msg := 'Invalid file name specified';
      DBIERR_UNKNOWNTBLTYPE: msg := 'The source driver type was not provided.';
      DBIERR_INVALIDPARAM: msg := 'The specified number of sort fields is invalid.';
      DBIERR_NOTSUPPORTED: msg := 'DBISortTable does not support sorting to self on a '  +  'Paradox table with a primary index.';
    end;

    if (dbRes <> DBIERR_NONE) then
      raise Exception.Create(msg);
  finally
    {Free up all memory used.}
    DbiCloseDatabase(hDb);
    Dispose(pSort);
    FreeMem(tName, SizeOf(PChar) * 256);
    FreeMem(dName, SizeOf(PChar) * 256);
  end;
end;

{===============================================================================
  Gets the path of an existing alias. Will produce an error message if the alias
  doesn't exist. I threw this in from the previous page.
===============================================================================}

function GetAliasPath(aliasName: string): string;
var
  cfgRec: DBDesc;
  dbRes: DBIResult;
  tempStr: array[0..255] of char;
begin
  result := '';
  dbRes := DBIGetDatabaseDesc(StrPCopy(tempStr, aliasName), @cfgRec);
  if dbRes = DBIERR_OBJNOTFOUND then
  begin
    raise Exception.create('The database alias input is not a valid BDE alias.');
  end
  else
    result := strPas(cfgRec.szPhyName);
end;

Note: This is an OLD Delphi 1.0 method for sorting a table. If you're going to use this in your Delphi 2+ applications, make sure you use the BDE uses file instead of the DBIProcs, etc. declarations in your uses section. Furthermore, you don't need to trap the errors yourself. Instead, enclose the BDE calls in the Check function to trap errors. It's a much cleaner implemenation. Note that I could use compiler directives to make this compatible with older versions of Delphi, but time is of the essence, and this has been sitting in my home directory for quite awhile.

Right-align a menu item

Problem/Question/Abstract:

How to right-align a TMenuItem

Answer:

If you have a TMainMenu MainMenu1 and a HelpMenuItem at the end of the Menubar; calling the following OnCreate- Eventhandler will right-align the HelpMenuItem

uses
  Windows;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup
    or mf_Help, HelpMenuItem1.Handle, '&Help');
end;

How to read a file in binary mode

Problem/Question/Abstract:

How can I read a file and get the first 10 bytes of that file in its hexadecimal format?

Answer:

function FirstTenBytes(const sFile: TFileName): string;
var
  oIn: TFileStream;
  iRead: Integer;
  iMaxRead: Integer;
  iData: Byte;
begin
  Result := '';
  oIn := TFileStream.Create(sFile, fmOpenRead or fmShareDenyNone);
  try
    iMaxRead := 10;
    if iMaxRead > oIn.Size then
      iMaxRead := oIn.Size;
    for iRead := 1 to iMaxRead do
    begin
      oIn.Read(iData, 1);
      Result := Result + IntToHex(iData, 2);
    end;
  finally
    FreeAndNil(oIn);
  end;
end;

How to load JPG images from a resource-only DLL

Problem/Question/Abstract:

I stored jpeg's in DLL as resource, and I want to load it from the DLL using Delphi3

Answer:

You can use LoadLibrary( ' yourdllname ' ) or GetModuleHandle( ' yourdllname ' ) for retrieving the handle of your DLL and after that something like:

procedure TForm1.LoadJPGFromDLL(DLLHandle: THandle; ResName, ResType: PChar;
  JPG: TJPEGImage);

  procedure Error;
  begin
    raise Exception.Create('Filed to load resource!');
  end;

var
  ResSize: dword;
  HG, HI: LongInt;
  P: Pointer;
  MS: TMemoryStream;
begin
  HI := FindResource(DLLHandle, ResName, ResType);
  if HI = 0 then
    Error;
  HG := LoadResource(DLLHandle, HI);
  if HG = 0 then
    Error;
  ResSize := SizeOfResource(DLLHandle, HI);
  MS := TMemoryStream.Create;
  try
    P := Pointer(LockResource(HG));
    MS.Write(P^, ResSize);
    MS.Position := 0;
    JPG.LoadFromStream(MS);
    UnlockResource(HG);
  finally
    MS.Free;
    FreeResource(HG);
  end;
end;

How to draw a rotated ellipse at a specific angle

Problem/Question/Abstract:

I'm looking for an algorithm that draws an ellipse, but is not based on the Bresenham mid-point method. I want to specify the bounding box and the algorithm should draw the ellipse. As I need to do things for each pixel on the line of the ellipse, I can not use the Windows.Ellipse(dc...) function. Does anyone have such an algorithm?

Answer:

The procdure draws an rotated ellipse at a specific angle:


procedure TForm1.EllipseAngle(ACanvas: TCanvas; XCenter, YCenter,
  XRadius, YRadius: Integer; Angle: Integer);
const
  Step = 49;
var
  RX, RY: Integer;
  i: Integer;
  Theta: Double;
  SAngle, CAngle: Double;
  RotAngle: Double;
  XC, YC: Integer;
  Kf: Double;
  X, Y: Double;
  XRot, YRot: Integer;
  Points: array[0..Step] of TPoint;
begin
  RotAngle := Angle * PI / 180;
  Kf := (360 * PI / 180) / Step;
  SAngle := Sin(RotAngle);
  CAngle := Cos(RotAngle);
  for i := 0 to Step do
  begin
    Theta := i * Kf;
    X := XCenter + XRadius * Cos(Theta);
    Y := YCenter + YRadius * Sin(Theta);
    XRot := Round(XCenter + (X - XCenter) * CAngle - (Y - YCenter) * SAngle);
    YRot := Round(YCenter + (X - XCenter) * SAngle + (Y - YCenter) * CAngle);
    Points[i] := Point(XRot, YRot);
  end;
  ACanvas.Polygon(Points);
end;

Include .Wav Files into your .EXE File

Problem/Question/Abstract:

How to Include .Wav Files into your .EXE File

Answer:

STEP 1:

Create a resource script file (*.RC) with a simple text editor like Notepad and add the following line:

1 WAVE "MyWav.wav"

The '1' is simply the index of the resource.  The 'WAVE' specifies that we are dealing with a WAVE FILE user-defined resource.  The third and final entry is the name of the Wav file.

STEP 2:

User Borland's Resource Compiler, BRCC32.EXE, to compile it into a .RES file.  At the MS- DOS command line, type:

BRCC32 MyWav.RC

This will create a resource file called MyWav.RES.

STEP 3:

Add a compiler directive to the source code of your program.  It should immediately follow the form directive, as shown here:

{$R *.DFM}
{$R MyWAV.RES}

STEP 4:

Add the following code to your project:

procedure TForm1.Button1Click(Sender: TObject);
begin
  PlaySound(PChar(1), HInstance, snd_ASync or snd_Memory or snd_Resource);
end;

You can add as many .Wav files as you want, just by adding another index number to your list, and call it using the PChar(index) in the PlaySound line.

STEP 5:

Run your program and click on the button, and enjoy.

Hint:  MMSystem must be in the uses clause!

Interfacing between Web and Applications

Problem/Question/Abstract:

Ever considered developing a web client which interacts with a windows application, or maybe a windows application which contains web pages within it&#8217;s confines, and allow them to seamlessly interact with one another.
The best way for me to explain this would be to give you a description of a current development and how I would like to introduce this interfacing.
Taking a database application which consists of a Contacts database and a Call logging system, and the requirement to introduce into the application a web front end or more specific, introduce a web plug-in and interact between the web pages and the application. Once this web interaction is introduced, the web front end(s) could make requests to application by calling any exposed routines. The Web page could call exposed functions from the application to fire off to a Contact record, or Call log view within the application.
A common example would be the idea of the Outlook Today page. A container within outlook which is or similar to a web page and interacts with the main application.
The definite advantage of this is the ease of handling large amounts of image and data information with Web technologies not just HTML but also Flash, XML which could then just plug into your application as controlling and interacting elements. Also the remote administrative and loading of these web interfaces, meaning less involvement with the client side, and entire areas of your main client application could be interacting web pages.
Developing such flexibility into a client side application using only Delphi would be a lot of work, &#8220;then again we&#8217;re Delphi developers, not VB developers and we thrive at a good challenge..&#8221;, but bringing this concept of a web plugin and interfacing it with my application sounds very powerful.

             "In this article I'll tell you how to do it...."


Answer:

&#8220;Now that I&#8217;ve got you in the mood lets start thinking how I might implement this &#8230;&#8221;

I have two main paths in which you could implement such a solution, and I will distinguish between the two :

  1.The more complicated and less desirable approach for my development would be for a web browser to load a page which creates a client side ActiveX object and for me to interface with an application through this object.  There is no reason why this method could not be adapted to implement my solution, and functionally work as I want it to.
            &#8220;In-fact I started my development using this method&#8221;
The main disadvantages of this method would be as follows :

The client would require an activex object installed on the machine along with the application which also must be digitally signed. Digital signing is required for Activex objects to be able to load securely for client assurance.
Clients rarely like the sound of active controls and objects when it comes to web pages.
The web page would require more information than I would desire and compared to my next solution is not so transparent.

  2. My preferred solution was to implement into the application the functionality to open and create instances of a Web Browser or TWebBrowser control and pass into the Web page an interface to an Automation object which exposes the application to the web page.
This then eliminates the requirement for the digitally signed Activex object which was to be called from the web page. Also I see an excellent advantage for Web pages having the capability to communicate with my application and not be affected if the application is not connected.
I could have a commercial web site, which my in-house system(s) could interact with, but is totally transparent to any client users of the site.
Also then I could then control which pages could connect to my (client)application more easily! Just a few ideas there !

Taking these two solutions into account, I am going to discuss and detail the second solution in the remainder of this article.

&#8220;So lets get down to the facts and implement this &#8230;&#8221;

Here are a few facts to help you understand how it can be done so easily.

A web page is filled with objects (which by the way all communicate pretty much through late binded interfaces) which you only usually have access to through client side scripting. All these interfaces would give us access control and use all of the objects within a web page.

Which leads me to the Window Object.

Each page or frame within a Web browser contains a window object. The window object exposes all of the objects and even javascript its self as it too is accessable through the window object interface.

&#8220;So all we need is to get the Interface for the window object into my application and then I have the access to all the objects within a web page &#8221;

Weather I have an application which creates an instance of a web browser, or uses a TWebBrowser control I&#8217;ll always be using COM/Automation and Interfaces to control the browsers and they are mainly the same.

Note: If you do not have a TWebBrowser component already installed into your Delphi pallete then you just need to install the Internet Explorer type library and activex control. You will also want this installed for ease when creating instances of a web browser and not using the TWebBrowser control.

Basically under the Web Browser interface/TWebBrowser control you will find it contains many properties, methods and callbacks/events which are exposed for use. There is a property in particular which is important to me which is the Document object which I use to get the window object for a loading page.
The method I use is to force the web browser to notify my application every time a web page/frame loads and it then send with the notification the new Document object for that page/frame. Using the &#8220;DocumentComplete&#8221; callback/event I can setup this notification.

This is the event implementation which I use to obtain the window object

//-----

procedure TForm2.WebBrowser_V11DownloadComplete(Sender: TObject);
var
  WindowObject: Variant;
begin
  windowobject := Variant(WebBrowser_V11.Document).parentwindow;
end;

//-----

So now that I have the window object I can now (in Delphi) control the web page with statements like :

//-----

WindowObject.document.formname.editbox1.value := &#8216;Hey Cubud&#8217;;

Or even.

WindowObject.AScriptFunction(&#8216;Shake that ass!&#8217;);

//-----

I&#8217;m sure your thinking, how can that work!

Remember I mentioned that the web page communicates as late binded interfaces. By assigning the window object to a variant we are effectively going to make blind access to the window object methods and properties and using late binding to invoke the methods and properties for use so when compiling, Delphi doesn&#8217;t kick up a fuss. Obviously late binding is slower than earlier binding, but then so is VB compared to Delphi. Really there is no real way around the late binding in this instance.

So that is basically how an application could control objects within a web page.

So next is how could I allow the web page to execute a javascript statement like :

//-----

<script language=&#8221;javascript&#8221;>
MyApplication.OpenAContact(ContactID);
</script>

//-----

&#8220;Well, I&#8217;m sure that a lot of you will have cracked the answer by now!&#8221;

The answer is to pass an interface from the application into the web page.

This is where I would simply add into my application an Interfaced Object, which I will pass the across to the web page.

Note: Because of the Web page will be using this interface to communicate with our application, and as the Web page will use Late Binding, the interface therefore needs to expose the methods for IDispatch.

Simpliest is to create an Automation object which already implements for IDispatch methods.

I&#8217;ll create the Automation object and add a method and an Identifier property into the Type library editor. Delphi will implement all the definitions and headings for the methods when the editor is saved, and all that is needed is to implement the code within the methods.

//-----
type
  TTMyAppInterfaceObject = class(TAutoObject, ITMyAppInterfaceObject)
  protected
    function OpenContact(ContactID: Integer): HResult; safecall;
    function Get_AppIdentifier: OleVariant; safecall; // Read Only Property
    { Protected declarations }
    &#8230;&#8230;&#8230;
      function TTMyAppInterfaceObject.OpenContact(ContactID: Integer): HResult;
    begin
      MainApplicationOpenContact(ContactID);
    end;

    function TTMyAppInterfaceObject.Get_AppIdentifier: OleVariant;
    begin
      Result := 'My Application';
    end;
    //-----

I now need to write a block of Javascript which can be included into any page which I would like this interfacing to be possible.
Note: I&#8217;ve implemented this method for web pages which contains multiple frames, and it is far simplier to make the parent of all frames, (the main page) the page that talks to the application and all other frames talk to that.

I have written this to a file called AppInterfacing.js so I can include it into any web page I would like interfacing.

//-----

<!--
var AppInterface
AppInterface = null;
OnAppAttached = null;

function AttachAppInterface ( AppIntf ) {
AppInterface = AppIntf;
if (OnAppAttached)
OnAppAttached()
}

function AppAssigned () {
return ((AppInterface != null)&&(AppInterface.AppIdentifier))
}
-->

//-----

Now with our web pages containing this block of Javascript, for the application to attach itself we just need to write the following statement.

//-----

function TForm2.AppInterface: ITMyAppInterfaceObject;
begin
  if FAppInterface = nil then
    FAppInterface := TTMyAppInterfaceObject.Create as ITMyAppInterfaceObject;
  result := FAppInterface;
end;

procedure TForm2.WebBrowser_V11DownloadComplete(Sender: TObject);
var
  WindowObject: Variant;
begin
  WindowObject := Variant(WebBrowser_V11.Document).parentwindow;
  try
    WindowObject.AttachAppInterface(AppInterface);
  except
    //-- &#8220;AttachAppInterface&#8221; not available
  end;
end;

//-----

So the entire page source could read as...

//-----

<script language=&#8221;javascript&#8221; src=&#8221;AppInterfacing.js&#8221;></script>
<script language=&#8221;javascript&#8221;>

function AppNotifyAttached() {
    alert(&#8216;Application has been attached&#8217;);
}
OnAppAttached = AppNotifyAttached;

function OpenContact(contactId) {
if (AppAssigned()) {
AppInterface.OpenContact(contactid);
} else {
               alert(&#8216;the contact id is &#8216;+contacted);
        }
}
-->
</script>

<HTML>
<BODY>
<form name="formname">
<input type="button" value="Request" onclick="OpenContact('123')">
</form>
</BODY>
</HTML>

//-----

Well that&#8217;s it for this article. I hope it reads well and gives a few of you some ideas. Any queries feel free to post me, I have tested this with IE 4/5 and Delphi 4/5 and worked really well.

Get notified when the user changes the theme (XP)?

Problem/Question/Abstract:

How to get notified when the user changes the theme (XP)?

Answer:

const
  WM_THEMECHANGED = $031A;

type
  TForm1 = class(TForm)
    {...}
  private
  public
    procedure WMTHEMECHANGED(var Msg: TMessage); message WM_THEMECHANGED;
  end;

  {...}

implementation

{...}

procedure TForm1.WMTHEMECHANGED(var Msg: TMessage);
begin
  Label1.Caption := 'Theme changed';
  Msg.Result := 0;
end;

How to disable the caret in a TMemo or TRichEdit

Problem/Question/Abstract:

How can I "turn off" the caret in a TRichEdit control? I want to use the control as a viewer only. I have ReadOnly selected but it still wants to display a caret.

Answer:

You can try to do the same the following TCustomMemo descendent does with a TCustomRichedit descendent:

unit DisplayMemo;

interface

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

type
  TDisplayMemo = class(TcustomMemo)
  private
    { Private declarations }
    procedure WMSetFocus(var msg: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var msg: TWMKillFocus); message WM_KILLFOCUS;
  protected
    { Protected declarations }
    procedure WndProc(var Message: TMessage); override;
  public
    { Public declarations }
    constructor Create(aOwner: TComponent); override;
  published
    { Publish most of the stuff TMemo publishes, rest commented out }
    property Align;
    property Alignment;
    property Anchors;
    property BiDiMode;
    property BorderStyle;
    property Color default $C0FFFF;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    {property HideSelection;}
    property ImeMode;
    property ImeName;
    property Lines;
    property MaxLength;
    property OEMConvert;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    {property ReadOnly;}
    property ScrollBars;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    {property WantReturns;}
    {property WantTabs;}
    property WordWrap;
    property OnChange;
    {property OnClick;}
    {property OnDblClick;}
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    {property OnKeyDown;}
    {property OnKeyPress;}
    {property OnKeyUp;}
    {property OnMouseDown;}
    {property OnMouseMove;}
    {property OnMouseUp;}
    property OnStartDock;
    property OnStartDrag;

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('PBGoodies', [TDisplayMemo]);
end;

{ TDisplayMemo }

constructor TDisplayMemo.Create(aOwner: TComponent);
begin
  inherited;
  ReadOnly := True;
  Color := $C0FFFF;
end;

procedure TDisplayMemo.WMKillFocus(var msg: TWMKillFocus);
begin
  ShowCaret(handle);
  inherited;
end;

procedure TDisplayMemo.WMSetFocus(var msg: TWMSetFocus);
begin
  inherited;
  HideCaret(handle);
end;

procedure TDisplayMemo.WndProc(var Message: TMessage);

  procedure Scroll(msg, scrollcode: Integer);
  begin
    Perform(msg, scrollcode, 0);
    Perform(msg, SB_ENDSCROLL, 0);
  end;

begin
  if not (csDesigning in ComponentState) then
    case Message.Msg of
      WM_LBUTTONDOWN, WM_LBUTTONUP, WM_MOUSEMOVE,
        WM_LBUTTONDBLCLK, WM_CHAR, WM_KEYUP:
        begin
          Message.Result := 0;
          if Message.Msg = WM_LBUTTONDOWN then
            if not Focused then
              SetFocus;
          Exit;
        end;
      WM_KEYDOWN:
        begin
          case Message.WParam of
            VK_DOWN: Scroll(WM_VSCROLL, SB_LINEDOWN);
            VK_UP: Scroll(WM_VSCROLL, SB_LINEUP);
            VK_LEFT: Scroll(WM_HSCROLL, SB_LINELEFT);
            VK_RIGHT: Scroll(WM_HSCROLL, SB_LINERIGHT);
            VK_NEXT: Scroll(WM_VSCROLL, SB_PAGEDOWN);
            VK_PRIOR: Scroll(WM_VSCROLL, SB_PAGEUP);
            VK_HOME: Scroll(WM_VSCROLL, SB_TOP);
            VK_END: Scroll(WM_VSCROLL, SB_BOTTOM);
          end;
          Message.Result := 0;
          Exit;
        end;
    end;
  inherited;
end;

end.

Moving a form with a mouse click on client area

Problem/Question/Abstract:

You want to move your TForm with a mouse click on the client area? No Problem.

Answer:

Insert the following code in the OnMouseDown-Event of your form:

procedure LetMoveWindow(Window: TControl);
begin
  ReleaseCapture;
  Window.Perform(WM_SysCommand, 61458, 0);
end;

procedure TForm1.FormMouseDown(Sender: TObject);
begin
  LetMoveWindow(Self);
end;

Color TDBGrid

Problem/Question/Abstract:

How to color TDBGrid

Answer:

Function to color a DBGrid (declared as private)

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  iValue: LongInt;
begin
  // color only the first field
  if (DataCol = 0) then
  begin
    // Check the field value and assign a color
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

How to check italian code for companies

Problem/Question/Abstract:

In Italy companies have a code for use with fiscal transactions. There's a checksum digit.
This function not only checks for its validity, but also retrieves some interesting information
from the code: the progressive number a company has in his state (provincia) and the country
that generated that code.

Answer:

const
  Provincie: array[0..102] of string =
  ('Torino', 'Vercelli', 'Novara', 'Cuneo', 'Asti',
    'Alessandria', 'Aosta', 'Imperia', 'Savona', 'Genova',
    'La Spezia', 'Varese', 'Como', 'Sondrio', 'Milano',
    'Bergamo', 'Brescia', 'Pavia', 'Cremona', 'Mantova',
    'Bolzano-Bozen', 'Trento', 'Verona', 'Vicenza', 'Belluno',
    'Treviso', 'Venezia', 'Padova', 'Rovigo', 'Udine',
    'Gorizia', 'Trieste', 'Piacenza', 'Parma', 'Reggio nell''Emilia',
    'Modena', 'Bologna', 'Ferrara', 'Ravenna', 'Forli''-Cesena',
    'Pesaro e Urbino', 'Ancona', 'Macerata', 'Ascoli Piceno', 'Massa-Carrara',
    'Lucca', 'Pistoia', 'Firenze', 'Livorno', 'Pisa',
    'Arezzo', 'Siena', 'Grosseto', 'Perugia', 'Terni',
    'Viterbo', 'Rieti', 'Roma', 'Latina', 'Frosinone',
    'Caserta', 'Benevento', 'Napoli', 'Avellino', 'Salerno',
    'L''Aquila', 'Teramo', 'Pescara', 'Chieti', 'Campobasso',
    'Foggia', 'Bari', 'Taranto', 'Brindisi', 'Lecce',
    'Potenza', 'Matera', 'Cosenza', 'Catanzaro', 'Reggio di Calabria',
    'Trapani', 'Palermo', 'Messina', 'Agrigento', 'Caltanissetta',
    'Enna', 'Catania', 'Ragusa', 'Siracusa', 'Sassari',
    'Nuoro', 'Cagliari', 'Pordenone', 'Isernia', 'Oristano',
    'Biella', 'Lecco', 'Lodi', 'Rimini', 'Prato',
    'Crotone', 'Vibo Valentia', 'Verbano-Cusio-Ossola'
    );

function PartitaIVA(code: string; var Progressive: integer; var Provincia: string):
  boolean;
  function ReduceSum(n: Integer): Integer;
  var
    i: Integer;
    s: string;
  begin
    s := inttostr(n);
    if (length(s) = 1) then
    begin
      result := n;
      exit;
    end;
    result := 0;
    for i := 1 to length(s) do
    begin
      result := result + strtointdef(s[i], 0);
    end;
  end;
  function ReduceNum(n: Integer): Integer;
  var
    s: string;
  begin
    result := n;
    s := inttostr(n);
    if (length(s) > 1) then
    begin
      result := strtointdef(s[length(s)], 0)
    end;
  end;
var
  i: Integer;
  c: Integer;
begin
  result := false;
  if (length(code) <> 11) then
  begin
    provincia := '11 numeric-characters needed!';
    raise exception.Create(provincia);
    exit;
  end;
  for i := 1 to 11 do
  begin
    if (not (code[i] in ['0'..'9'])) then
    begin
      provincia := '"' + code[i] + '" is not a numeric value!';
      raise exception.Create(provincia);
      exit;
    end;
  end;
  // Returns the town.
  i := strtointdef(copy(code, 8, 3), 0) - 1;
  if ((i < 0) or (i > 102)) then
  begin
    provincia := 'Value out of set!';
    raise exception.create(provincia);
    exit;
  end
  else
    provincia := provincie[i];
  // Returns the progressive number.
  progressive := strtointdef(copy(code, 1, 7), 0);
  // Calculates if is valid.
  c := 0;
  for i := 1 to 10 do
  begin
    if ((i mod 2) = 0) then
      inc(c, reducesum(strtointdef(code[i], 0) * 2))
    else
      inc(c, strtointdef(code[i], 0));
  end;
  result := ((10 - ReduceNum(c)) = strtointdef(code[11], -1));
end;

Text to GIF

Problem/Question/Abstract:

Text to GIF

Answer:

procedure TxtToGif(txt, FileName: string);
var
  temp: TBitmap;
  GIF: TGIFImage;
begin

  temp := TBitmap.Create;
  try
    temp.Height := 400;
    temp.Width := 60;
    temp.Transparent := True;
    temp.Canvas.Brush.Color := colFondo.ColorValue;
    temp.Canvas.Font.Name := Fuente.FontName;
    temp.Canvas.Font.Color := colFuente.ColorValue;
    temp.Canvas.TextOut(10, 10, txt);
    Imagen.Picture.Assign(nil);

    GIF := TGIFImage.Create;
    try
      // Convert the bitmap to a GIF
      GIF.Assign(Temp);
      // Save the GIF
      GIF.SaveToFile(FileName);
      // Display the GIF
      Imagen.Picture.Assign(GIF);
    finally
      GIF.Free;
    end;

  finally

    temp.Destroy;
  end;
end;

Boyer-Moore string searching

Problem/Question/Abstract:

Boyer-Moore string searching

Answer:

Solve 1:

unit BMSearch;

interface

type
{$IFDEF WINDOWS}
  size_t = Word;
{$ELSE}
  size_t = LongInt;
{$ENDIF}

type
  TTranslationTable = array[char] of char; { translation table }
  TSearchBM = class(TObject)
  private
    FTranslate: TTranslationTable; { translation table }
    FJumpTable: array[char] of Byte; { Jumping table }
    FShift_1: integer;
    FPattern: pchar;
    FPatternLen: size_t;
  public
    procedure Prepare(Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean);
    procedure PrepareStr(const Pattern: string; IgnoreCase: Boolean);
    function Search(Text: pchar; TextLen: size_t): pchar;
    function Pos(const S: string): integer;
  end;

implementation

uses
  SysUtils;

{Ignore Case Table Translation}

procedure CreateTranslationTable(var T: TTranslationTable; IgnoreCase: Boolean);
var
  c: char;
begin
  for c := #0 to #255 do
    T[c] := c;
  if not IgnoreCase then
    exit;
  for c := 'a' to 'z' do
    T[c] := UpCase(c);

  { Mapping all accented characters to their uppercase equivalent }

  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';

  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';

  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';

  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';

  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';

  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';

  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';

  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';

  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';

  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';

  T['�'] := '�';
end;

{Preparation of the jumping table}

procedure TSearchBM.Prepare(Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean);
var
  i: integer;
  c, lastc: char;
begin
  FPattern := Pattern;
  FPatternLen := PatternLen;
  if FPatternLen < 1 then
    FPatternLen := strlen(FPattern);
  {This algorythm is based on a character set of 256}
  if FPatternLen > 256 then
    exit;
  {1. Preparing translating table}
  CreateTranslationTable(FTranslate, IgnoreCase);
  {2. Preparing jumping table}
  for c := #0 to #255 do
    FJumpTable[c] := FPatternLen;
  for i := FPatternLen - 1 downto 0 do
  begin
    c := FTranslate[FPattern[i]];
    if FJumpTable[c] >= FPatternLen - 1 then
      FJumpTable[c] := FPatternLen - 1 - i;
  end;
  FShift_1 := FPatternLen - 1;
  lastc := FTranslate[Pattern[FPatternLen - 1]];
  for i := FPatternLen - 2 downto 0 do
    if FTranslate[FPattern[i]] = lastc then
    begin
      FShift_1 := FPatternLen - 1 - i;
      break;
    end;
  if FShift_1 = 0 then
    FShift_1 := 1;
end;

procedure TSearchBM.PrepareStr(const Pattern: string; IgnoreCase: Boolean);
var
  str: pchar;
begin
  if Pattern <> '' then
  begin
{$IFDEF Windows}
    str := @Pattern[1];
{$ELSE}
    str := pchar(Pattern);
{$ENDIF}
    Prepare(str, Length(Pattern), IgnoreCase);
  end;
end;

{Searching Last char & scanning right to left}

function TSearchBM.Search(Text: pchar; TextLen: size_t): pchar;
var
  shift, m1, j: integer;
  jumps: size_t;
begin
  result := nil;
  if FPatternLen > 256 then
    exit;
  if TextLen < 1 then
    TextLen := strlen(Text);
  m1 := FPatternLen - 1;
  shift := 0;
  jumps := 0;
  {Searching the last character}
  while jumps <= TextLen do
  begin
    Inc(Text, shift);
    shift := FJumpTable[FTranslate[Text^]];
    while shift <> 0 do
    begin
      Inc(jumps, shift);
      if jumps > TextLen then
        exit;
      Inc(Text, shift);
      shift := FJumpTable[FTranslate[Text^]];
    end;
    { Compare right to left FPatternLen - 1 characters }
    if jumps >= m1 then
    begin
      j := 0;
      while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do
      begin
        Inc(j);
        if j = FPatternLen then
        begin
          result := Text - m1;
          exit;
        end;
      end;
    end;
    shift := FShift_1;
    Inc(jumps, shift);
  end;
end;

function TSearchBM.Pos(const S: string): integer;
var
  str, p: pchar;
begin
  result := 0;
  if S <> '' then
  begin
{$IFDEF Windows}
    str := @S[1];
{$ELSE}
    str := pchar(S);
{$ENDIF}
    p := Search(str, Length(S));
    if p <> nil then
      result := 1 + p - str;
  end;
end;

end.


Solve 2:

Here's a demo program of the Boyer-Moore search algorithm. The basic idea is to first create a Boyer-Moore index table for the string you want to search for, and then call the BMsearch routine. Remember to turn-off Range Checking {$R-} in your finished program, otherwise the BMSearch will take 3-4 times longer than it should.


{Public-domain demo of Boyer-Moore search algorithm.
Guy McLoughlin - May 1, 1993.}

program DemoBMSearch;

{Boyer-Moore index table data definition}
type
  BMTable = array[0..127] of byte;

  {Create a Boyer-Moore index table to search with.}

procedure Create_BMTable(Pattern: string; var BMT: BMTable);
var
  Index: byte;
begin
  fillchar(BMT, sizeof(BMT), length(Pattern));
  for Index := 1 to length(Pattern) do
    BMT[ord(Pattern[Index])] := (length(Pattern) - Index)
end;

{Boyer-Moore Search function. Returns 0 if string is not found. Returns 65,535 if
BufferSize is too large, ie: greater than 65,520 bytes.}

function BMsearch(var Buffer; BuffSize: word; var BMT: BMTable; Pattern: string): word;
var
  Buffer2: array[1..65520] of char absolute Buffer;
  Index1, Index2, PatSize: word;
begin
  if (BuffSize > 65520) then
  begin
    BMsearch := $FFFF;
    exit
  end;
  PatSize := length(Pattern);
  Index1 := PatSize;
  Index2 := PatSize;
  repeat
    if (Buffer2[Index1] = Pattern[Index2]) then
    begin
      dec(Index1);
      dec(Index2)
    end
    else
    begin
      if (succ(PatSize - Index2) > (BMT[ord(Buffer2[Index1])])) then
        inc(Index1, succ(PatSize - Index2))
      else
        inc(Index1, BMT[ord(Buffer2[Index1])]);
      Index2 := PatSize
    end;
  until
    (Index2 < 1) or (Index1 > BuffSize);
  if (Index1 > BuffSize) then
    BMsearch := 0
  else
    BMsearch := succ(Index1)
end;

type
  arby_64K = array[1..65520] of byte;

var
  Index: word;
  st_Temp: string[10];
  Buffer: ^arby_64K;
  BMT: BMTable;

begin
  new(Buffer);
  fillchar(Buffer^, sizeof(Buffer^), 0);
  st_Temp := 'Gumby';
  move(st_Temp[1], Buffer^[65516], length(st_Temp));
  Create_BMTable(st_Temp, BMT);
  Index := BMSearch(Buffer^, sizeof(Buffer^), BMT, st_Temp);
  writeln(st_Temp, ' found at offset ', Index)
end.

Trap the OnEnter and OnLeave events

Problem/Question/Abstract:

This code shows how to get the OnEnter and OnLeave event from components without changing the component.

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FFocusControl: TControl;
    procedure ApplicationIdle(Sender: TObject; var Done: Boolean);
  public
    { Public declarations }
    procedure OnEnter(Sender: TObject);
    procedure OnExit(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FFocusControl := nil;
  Application.OnIdle := ApplicationIdle;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Application.OnIdle := nil;
end;

procedure TForm1.ApplicationIdle(Sender: TObject; var Done: Boolean);
var
  CurControl: TControl;
  P: TPoint;
begin
  GetCursorPos(P);
  CurControl := FindDragTarget(P, True);
  if FFocusControl <> CurControl then
  begin
    if FFocusControl <> nil then
      OnExit(FFocusControl);
    FFocusControl := CurControl;
    if FFocusControl <> nil then
      OnEnter(FFocusControl);
  end;
end;

procedure TForm1.OnEnter(Sender: TObject);
begin
  //OnEnter code
  if sender = Button1 then
  begin
    Label1.caption := 'Hello';
    Button1.Caption := 'Exit';
  end;
end;

procedure TForm1.OnExit(Sender: TObject);
begin
  //OnExit code
  if sender = Button1 then
  begin
    Label1.caption := 'Godbye';
    Button1.Caption := 'Enter';
  end;
end;

end.

How to check what type of component is the Sender

Problem/Question/Abstract:

The piece of code below is typical of some routines we have. This example only uses 2 component types but sometimes there could be 7 or 8 and then the code is really bad.

procedure TEN1FORM.myonEnter(Sender: TObject);
begin
  if Sender is TDBComboBox then
    enterstr := TDBComboBox(Sender).text
  else if Sender is TOVCDBPICTUREFIELD then
    enterstr := TOVCdbPICTUREFIELD(Sender).text;
end;

Answer:

Solve 1:

function CheckIsType(AObject: TObject; const ClassArray: array of TClass): Integer;
{Return an index indicative of a type match on the object, and array of types passed}
begin
  for Result := 0 to High(ClassArray) do
    if AObject is ClassArray[Result] then
      Exit;
  Result := -1;
end;

{ ... }
case CheckIsType(Sender, [TdbComboBox, TOVCDBPctureField, TSpeedButton, TEdit]) of
  0: { ... }; {TDBComboBox}
  1: { ... }; {TOVCDBPctureField}
  2: { ... }; {TSpeedButton}
  3: { ... }; {TEdit}
end;
{ ... }

I also use the following routine which does an exact type match:

function CheckType(AObject: TObject; const ClassArray: array of TClass): Integer;
var
  Index: Integer;
begin
  Result := -1;
  if Assigned(AObject) then
    for Index := 0 to High(ClassArray) do
      if AObject.ClassType = ClassArray[Index] then
      begin
        Result := Index;
        Exit;
      end;
end;


Solve 2:

Let me add one more way to tackle this: use run-time type information. Text is a published property so RTTI exists for it. So you can use the stuff in Unit TypInfo to access it.

uses
  TypInfo;

function GetStrProperty(anObj: TObject; const propname: string): string;
var
  PInfo: PPropInfo;
begin
  result := EmptyStr;
  PInfo := GetPropInfo(anObj.ClassInfo, propname);
  if PInfo <> nil then
    {found aproperty with this name, check if it has the correct type}
    if PInfo^.Proptype^.Kind in [tkString, tkLString] then
    begin
      {it has! Get the string value from theproperty}
      Result := GetStrProp(anObj, PInfo);
    end;
end;

Using this function your handler becomes

procedure TEN1FORM.myonEnter(Sender: TObject);
begin
  enterstr := GetStrProperty(sender, 'text');
  { ... }

How to limit the number of characters per line and the number of lines in a TMemo (2)

Problem/Question/Abstract:

Is there a way to place a maximum number of lines in a TMemo?

Answer:

procedure TForm1.Memo1Change(Sender: TObject);
var
  i: Integer;
  s: string;
begin
  i := Length(Memo1.Lines.Text);
  {Limit the number of lines to 3}
  if Memo1.Lines.Count > 3 then
  begin
    s := Memo1.Lines.Text;
    Delete(s, i, 1);
    {Remove line wrap}
    i := Length(s);
    while (Ord(s[i]) = 10) or (Ord(s[i]) = 13) do
    begin
      Delete(s, i, 1);
      i := Length(s);
    end;
    Memo1.Lines.Text := s;
    {posistion cursor at end of memo}
    Memo1.SelStart := Length(s);
    Memo1.SelLength := 0;
    ShowMessage('Over Max Lines');
  end;
end;

How to create a TProgressBar inside a TListView

Problem/Question/Abstract:

I would like to display a progress bar as a sub item in a TListView (vsReport mode). How can I do that?

Answer:

Well, you can in fact parent a live progressbar to a listview, you just have to do it at run-time. The sample below has timer that randomly steps the progress bars. The bar is added to the last column of the listview.

There are some gotchas here: the DisplayRect method of a listitem does not return the correct position unless the control is visible, thus the hack used at the top of the method to ensure this. And of course you will have to adjust the width and left bound of the progress bars if the user resizes columns. And you need to add new bars if the user can add items and destroy bars if the user can delete item.

procedure TForm1.FormCreate(Sender: TObject);
var
  pb: TProgressBar;
  r: TRect;
  i, k: Integer;
begin
  Show;
  Application.ProcessMessages;
  for i := 0 to listview1.items.count - 1 do
  begin
    r := listview1.items[i].DisplayRect(drBounds);
    {last column is to take progress bar}
    for k := 1 to listview1.columns.Count - 1 do
      r.left := r.left + listview1.columns[k - 1].Width;
    r.right := r.Left + listview1.columns[listview1.columns.Count - 1].Width;
    pb := TProgressBar.Create(self);
    pb.Parent := listview1;
    pb.BoundsRect := r;
    listview1.items[i].Data := pb;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i: Integer;
  pb: TProgressbar;
begin
  i := Random(listview1.items.count);
  pb := TProgressBar(listview1.Items[i].Data);
  if assigned(pb) then
    if pb.Position = pb.Max then
      pb.Position := 0
    else
      pb.StepBy(pb.Max div 10);
end;

Converting MS-Word DOC to RTF using OLE

Problem/Question/Abstract:

I want to load a Word document into a RitchText control

Answer:

Open a new Application and place:

  a button named Button3,
  a RitchText object named WordEditor
  and an OpenDialog component.

From now on, you can browse for any *.doc file and load it into the RitchText object.

NOTE: Format:=6 instructs Word to save the file as RTF. Extension is not enough.

Other File Formats:

Argument Format  
File Format
0
Normal (Word format)
1
Document Template
2
Text Only (extended characters saved in ANSI character set)
3
Text+Breaks (plain text with line breaks; extended characters saved in ANSI character set)
4
Text Only (PC-8) (extended characters saved in IBM PC character set)
5
Text+Breaks (PC-8) (text with line breaks; extended characters saved in IBM PC character set)
6
Rich-text format (RTF)



procedure TImport_Form.ToolButton3Click(Sender: TObject);
var
  WordApp: Variant;
begin
  if OpenDialog1.Execute then
  begin
    Edit1.Text := ExtractFileName(OpenDialog1.FileName);
    StatusBar1.SimpleText := OpenDialog1.FileName;
    WordApp := CreateOleObject('Word.Basic');
    if not VarIsEmpty(WordApp) then
    begin
      WordApp.FileOpen(OpenDialog1.FileName);
      WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format := 6);
      WordApp.AppClose;
      WordApp := Unassigned;
      WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');
    end
    else
      ShowMessage('Could not start MS Word');
  end;

end;

How to prevent word from opening password-protected files or resume wizard files and sometimes causing application to hang ?

The sollution is to add the folowing query before openning the document:

if WordApp.ActiveDocument.HasPassword = True then
  MsgBox("Password Protected");

You can even preset the password propery as:

WordApp.Password := 'mypassword";

NOTE: If the above code generates an "Undefined property: ActiveDocument" change the:

CreateOleObject('Word.Basic');

with

CreateOleObject('Word.Application');

How to detect a sound device

Problem/Question/Abstract:

Is there a way to detect a sound device (personally, I want to detect a sound card) to know if such a device is present on the computer my application is running?

Answer:

Solve 1:

{ ... }
if WaveOutGetNumDevs > 0 then
  ShowMessage('Wave-Device present')
else
  ShowMessage('No Wave-Device present');
{ ... }


Solve 2:

function IsSoundCardInstalled: Boolean;
type
  SCFunc = function: UInt; stdcall;
var
  LibInst: LongInt;
  EntryPoint: SCFunc;
begin
  Result := False;
  LibInst := LoadLibrary(PChar('winmm.dll'));
  try
    if LibInst <> 0 then
    begin
      EntryPoint := GetProcAddress(LibInst, 'waveOutGetNumDevs');
      if (EntryPoint <> 0) then
        Result := True;
    end;
  finally
    if (LibInst <> 0) then
      FreeLibrary(LibInst);
  end;
end;

Replace Text in Bookmarks in WORD

Problem/Question/Abstract:

How can I replace Text in Bookmarks in WORD?

Answer:

When Word is connected via OLE, you can use bookmarks to fill in text into an existing template or document.

The first step is connecting to WORD, either with an OLE-Object or in an OLE-Control.

The Server You connect to should be WORD.Document, not WORD.Application. With this, it is easier to control that You always word on the right Document.

Finding an Replacing a bookmark goes like that:

var
  Doc: Variant;
  Result: string;
  Bookmark: string;
  Startpos, Endpos: longint;
begin
  // You already are connected to a WORD.Document Object!
  //
  Result := 'anything';
  Bookmark := 'bookmark 20';
  // Replace the Text:
  Doc.Bookmarks.Items('bookmark 20').range.text := Result;
  // done this, You have lost the Bookmark, but integrated the Text
end;

Sending an email from Delphi with Outlook

Problem/Question/Abstract:

Sending an email from Delphi with Outlook

Answer:

Outlook can be easily controlled through OLE. Try the sample procedure SendOutlookMail() from below.

This does not work with Outlook Express.


program MailWithOutlook;

procedure SendOutlookMail;
const
  olMailItem = 0;
var
  Outlook: OleVariant;
  vMailItem: variant;
begin
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  vMailItem := Outlook.CreateItem(olMailItem);
  vMailItem.Recipients.Add('dummy@hotmail.com');
  vMailItem.Subject := 'test email';
  vMailItem.Body := 'This is a test';
  vMailItem.Attachments.Add('C:\temp\sample.txt');
  vMailItem.Send;

  VarClear(Outlook);
end;

end.

How to save / load a ScanLine to / from a stream

Problem/Question/Abstract:

How to save / load a ScanLine to / from a stream

Answer:

I won't claim this is fastest in any way, but it shows how to write scanlines to a stream and then read the stream to fill in the scanlines.

Example of flipping a bitmap by writing to MemoryStream and loading second bitmap in flipped order.

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  j: Integer;
  Bitmap1: TBitmap;
  Bitmap2: TBitmap;
  row: pByteArray;
  ScanlineBytes: Integer;
  Stream: TMemoryStream;
begin
  Bitmap1 := TBitmap.Create;
  try
    {Assume Image1 and Image2 are the same size}
    Bitmap1.Width := Image1.Width;
    Bitmap1.Height := Image1.Height;
    Bitmap1.PixelFormat := pf24bit;
    {Make something assymmetric in picture}
    Bitmap1.Canvas.Pen.Color := clRed;
    Bitmap1.Canvas.MoveTo(0, 0);
    Bitmap1.Canvas.LineTo(Bitmap1.Width, Bitmap1.Height);
    Bitmap1.Canvas.MoveTo(Bitmap1.Width div 2, 0);
    Bitmap1.Canvas.LineTo(0, Bitmap1.Height div 2);
    Image1.Picture.Graphic := Bitmap1;
    Stream := TMemoryStream.Create;
    try
      ScanlineBytes := ABS(Integer(Bitmap1.Scanline[1]) - Integer(Bitmap1.Scanline[0]));
      for j := 0 to Bitmap1.Height - 1 do
      begin
        row := Bitmap1.Scanline[j];
        Stream.Write(row[0], ScanlineBytes);
      end;
      Bitmap2 := TBitmap.Create;
      try
        Bitmap2.Width := Bitmap1.Width;
        Bitmap2.Height := Bitmap1.Height;
        Bitmap2.PixelFormat := pf24bit;
        {position stream pointer at beginning}
        Stream.Position := 0;
        {Flip bitmap by reading scanlines from stream and placing them in flipped row}
        for j := Bitmap2.Height - 1 downto 0 do
        begin
          row := Bitmap2.Scanline[j];
          Stream.Read(row[0], ScanlineBytes)
        end;
        Image2.Picture.Graphic := Bitmap2
      finally
        Bitmap2.Free
      end
    finally
      Stream.Free
    end
  finally
    Bitmap1.Free
  end;
end;

end.

Perform a file search including subdirectories

Problem/Question/Abstract:

How to perform a file search including subdirectories

Answer:

Solve 1:

Recursively scanning all drives:

{excerpt from form declaration, form has a listbox1 for the  results, a label1 for progress, a button2 to start the scan, an edit1 to get the search mask from, a button3 to stop the scan.}
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }

function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;

function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;

  function ScanDirectory(var path: string): Boolean;
  var
    SRec: TSearchRec;
    pathlen: Integer;
    res: Integer;
  begin
    label1.caption := path;
    pathlen := Length(path);
    { first pass, files }
    res := FindFirst(path + filemask, faAnyfile, SRec);
    if res = 0 then
    try
      while res = 0 do
      begin
        hitlist.Add(path + SRec.Name);
        res := FindNext(SRec);
      end;
    finally
      FindClose(SRec)
    end;
    Application.ProcessMessages;
    Result := not (FScanAborted or Application.Terminated);
    if not Result then
      Exit;
    {second pass, directories}
    res := FindFirst(path + ' *.* ', faDirectory, SRec);
    if res = 0 then
    try
      while (res = 0) and Result do
      begin
        if ((Srec.Attr and faDirectory) = faDirectory) and (Srec.name <> ' . ')
          and (Srec.name <> ' .. ') then
        begin
          path := path + SRec.name + '\';
          Result := ScanDirectory(path);
          SetLength(path, pathlen);
        end;
        res := FindNext(SRec);
      end;
    finally
      FindClose(SRec)
    end;
  end;

begin
  FScanAborted := False;
  Screen.Cursor := crHourglass;
  try
    Result := ScanDirectory(root);
  finally
    Screen.Cursor := crDefault
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  ch: Char;
  root: string;
begin
  root := 'C:\';
  for ch := 'A' to 'Z' do
  begin
    root[1] := ch;
    case GetDriveType(Pchar(root)) of
      DRIVE_FIXED, DRIVE_REMOTE:
        if not ScanDrive(root, edit1.text, listbox1.items) then
          Break;
    end;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin {aborts scan}
  fScanAborted := True;
end;


Solve 2:

procedure TFrmRecurseDirTree.RecurseDirTree(APath: string; AList: TStrings);
var
  searchRec: TSearchRec;
  thePath: string;
begin
  if (Length(thePath) > 0) then
    Exit;
  {Riffle through the subdirectories and find the file(s) there}
  thePath := APath;
  if (thePath[Length(thePath)] <> '\') then
    thePath := thePath + '\';
  if FindFirst(thePath + '*.*', faDirectory, searchRec) = 0 then
  try
    repeat
      if (searchRec.Attr and faDirectory > 1) and (searchRec.Name <> '.') and
        (searchRec.Name <> '..') then
      begin
        AList.Add(thePath + searchRec.Name);
        RecurseDirTree(thePath + searchRec.Name + '\', AList);
        Application.ProcessMessages;
      end;
    until
      FindNext(searchRec) <> 0;
  finally
    SysUtils.FindClose(searchRec);
  end;
end;


Solve 3:

Here is a procedure to scan for all bitmaps below the current directory and add them to a list. It can easily be modified to add all sub-directories to the list, just add "List.Add..." just before "ScanDirectory..." and delete the part that adds the bitmap filenames. Maybe it's better to change faAnyFile to faDirecory, but I am not sure if this will return all directories including hidden ones etc.

procedure TForm1.ScanDirectory(Path: string; List: TStringList; SubDirFlag: Boolean);
var
  SearchRec: TSearchRec;
  Ext: string;
begin
  if Path[Length(Path)] <> '\' then
    Path := Path + '\';
  if FindFirst(Path + '*.*', faAnyFile, SearchRec) = 0 then
  begin
    repeat
      if SearchRec.Attr = faDirectory then
      begin
        if SubDirFlag and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          ScanDirectory(Path + SearchRec.Name, List, SubDirFlag);
      end
      else
      begin
        Ext := UpperCase(ExtractFileExt(SearchRec.Name));
        if (Ext = '.BMP') then
        begin
          List.Add(Path + SearchRec.Name);
        end;
      end;
    until
      FindNext(SearchRec) <> 0;
  end;
end;

Use it as follows:

ScanDirectory(GetCurrentDir, YourStringList, False);


Solve 4:

procedure TForm1.Button1Click(Sender: TObject);
var
  SearchRec: TSearchRec;
begin
  if FindFirst('c:\images\*.jpg', faAnyFile, SearchRec) = 0 then
  try
    repeat
      listbox1.items.add(searchrec.name);
    until
      Findnext(SearchRec) <> 0;
  finally
    FindClose(SearchRec);
  end;
end;

Note: if you are displaying many items, you will probably want to wrap the code within listbox1.items.BeginUpdate/EndUpdate.


Solve 5:

Searching for a file in a directory:

function FileExistsExt(const aPath, aFilename: string): Boolean;
var
  DSearchRec: TSearchRec;
begin
  Result := FileExists(IncludeTrailingPathDelimiter(aPath) + aFilename);
  if not Result then
  begin
    if FindFirst(APath + '\*', faDirectory, DSearchRec) = 0 then
    begin
      repeat
        if (DSearchRec.Name <> '.') and (DSearchRec.Name <> '..') then
          Result := FileExistsExt(IncludeTrailingPathDelimiter(aPath) +
                                         DSearchRec.Name, aFilename);
      until
        FindNext(DSearchRec) <> 0;
    end;
    FindClose(DSearchRec);
  end;
end;

Usage:

{ ... }
if FileExistsExt('C:', 'Testfile.dat') then
  { ... }


Solve 6:

The following function receives as parameters a file specification (like for example 'C:\My Documents\*.xls' or 'C:\*' if you want to search the entire hard disk) and optionally a set of attributes (exactly as Delphi's FindFirst function), and it returs a StringList with the full pathnames of the found files. You should free the StringList after using it.

interface

function FindFile(const filespec: TFileName; attributes: integer
  = faReadOnly or faHidden or faSysFile or faArchive): TStringList;

implementation

function FindFile(const filespec: TFileName;
  attributes: integer): TStringList;
var
  spec: string;
  list: TStringList;

  procedure RFindFile(const folder: TFileName);
  var
    SearchRec: TSearchRec;
  begin
    // Locate all matching files in the current
    // folder and add their names to the list
    if FindFirst(folder + spec, attributes, SearchRec) = 0 then
    begin
      try
        repeat
          if (SearchRec.Attr and faDirectory = 0) or
            (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
            list.Add(folder + SearchRec.Name);
        until FindNext(SearchRec) <> 0;
      except
        FindClose(SearchRec);
        raise;
      end;
      FindClose(SearchRec);
    end;
    // Now search the subfolders
    if FindFirst(folder + '*', attributes
      or faDirectory, SearchRec) = 0 then
    begin
      try
        repeat
          if ((SearchRec.Attr and faDirectory) <> 0) and
            (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
            RFindFile(folder + SearchRec.Name + '\');
        until FindNext(SearchRec) <> 0;
      except
        FindClose(SearchRec);
        raise;
      end;
      FindClose(SearchRec);
    end;
  end; // procedure RFindFile inside of FindFile

begin // function FindFile
  list := TStringList.Create;
  try
    spec := ExtractFileName(filespec);
    RFindFile(ExtractFilePath(filespec));
    Result := list;
  except
    list.Free;
    raise;
  end;
end;

Sample call

You can try this function placing a ListBox and a button on a form and adding this code to the OnClick event of the button:

procedure TForm1.Button1Click(Sender: TObject);
var
  list: TStringList;
begin
  list := FindFile('C:\Delphi\*.pas');
  ListBox1.Items.Assign(list);
  list.Free;
end;


Solve 7:

I thought if there was a way to create a function that does not recursively call itself to list all the files in the harddisk, so that there might be some improvement in speed, other than making the function more complex there were no speed improvements. Here is the code of the function any way.

type
  PRecInfo = ^TRecInfo;
  Trecinfo = record
    prev: PRecInfo;
    fpathname: string;
    srchrec: Tsearchrec;
  end;

function TForm1.RecurseDirectory1(fname: string): tstringlist;
var
  f1, f2: Tsearchrec;
  p1, tmp: PRecInfo;
  fwc: string;
  fpath: string;
  fbroke1, fbroke2: boolean;
begin
  result := tstringlist.create;
  fpath := extractfilepath(fname);
  fwc := extractfilename(fname);
  new(p1);
  p1.fpathname := fpath;
  p1.prev := nil;
  fbroke1 := false;
  fbroke2 := false;
  while (p1 <> nil) do
  begin
    if (fbroke1 = false) then
      if (fbroke2 = false) then
      begin
        if (findfirst(fpath + '*', faAnyfile, f1) <> 0) then
          break;
      end
      else if (findnext(f1) <> 0) then
      begin
        repeat
          findclose(f1);
          if (p1 = nil) then
            break;
          fpath := p1.fpathname;
          f1 := p1.srchrec;
          tmp := p1.prev;
          dispose(p1);
          p1 := tmp;
        until (findnext(f1) = 0);
        if (p1 = nil) then
          break;
      end;
    if ((f1.Name <> '.') and (f1.name <> '..') and ((f1.Attr and fadirectory) =
      fadirectory)) then
    begin
      fbroke1 := false;
      new(tmp);
      with tmp^ do
      begin
        fpathname := fpath;
        srchrec.Time := f1.time;
        srchrec.Size := f1.size;
        srchrec.Attr := f1.attr;
        srchrec.Name := f1.name;
        srchrec.ExcludeAttr := f1.excludeattr;
        srchrec.FindHandle := f1.findhandle;
        srchrec.FindData := f1.FindData;
      end;
      tmp.prev := p1;
      p1 := tmp;
      fpath := p1.fpathname + f1.name + '\';
      if findfirst(fpath + fwc, faAnyfile, f2) = 0 then
      begin
        result.add(fpath + f2.Name);
        while (findnext(f2) = 0) do
          result.add(fpath + f2.Name);
        findclose(f2);
      end;
      fbroke2 := false;
    end
    else
    begin
      if (findnext(f1) <> 0) then
      begin
        findclose(f1);
        fpath := p1.fpathname;
        f1 := p1.srchrec;
        fbroke1 := false;
        fbroke2 := true;
        tmp := p1.prev;
        dispose(p1);
        p1 := tmp;
      end
      else
      begin
        fbroke1 := true;
        fbroke2 := false;
      end;
    end;
  end;
  fpath := extractfilepath(fname);
  if findfirst(fname, faAnyfile, f1) = 0 then
  begin
    result.add(fpath + f2.Name);
    while (findnext(f1) = 0) do
      result.add(fpath + f2.Name);
    findclose(f1);
  end;
end;