How to open an URL in a regular browser instead of opening it in a TWebBrowser

Problem/Question/Abstract:

I have a TWebBrowser in my application that loads unknown remote content. When a user clicks on any link in it, I would like to have the URL opened in a regular browser, but not within the TWebBrowser itself. I do not want the TWebBrowser to act upon the click.

Answer:

Use the OnBeforeNavigate2 event like that:

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject; const pDisp: IDispatch;
  var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
begin
  if not FManuallyLoading then
  begin
    {Stop Loading in this Browser ...}
    Cancel := True;
    {... but open in new Browser}
    Flags := Flags or 1;
    (Sender as TWebBrowser).Navigate(WideString(URL), Flags,
      TargetFrameName, PostData, Headers);
  end;
end;


Set FManuallyLoading to True, while you are programmatically loading content into the web browser:


procedure TForm1.Button1Click(Sender: TObject);
begin
  FManuallyLoading := True;
  WebBrowser1.Navigate('http://www.nineberry.de');
  FManuallyLoading := False;
end;

How to use Randomize so that the same value is not chosen more than once

Problem/Question/Abstract:

How can I write a procedure that does not choose the same number more than once?

Answer:

This is called "shuffling". Most often, you want it to randomize the values in a list or array. In any case, the only way to count "more than once" is to do this over a given array. If you just want the shuffle values one by one, you shuffle the array and then take the values from the lowest element to the highest, successively.

The thing to avoid is to go and keep a list of the numbers already found, and call random endlessly until it gives a number not on the list. With a large range, this takes incredibly long.

The procedure below shows how to do it correctly. It assumes you want a continuous range of values. If you want something fancier (say, a shuffle of various weights, or of names, etc.), then you merely have to change the procedure to take an array of the proper type, and NOT to fill it at the beginning - the caller can pre-fill it with the values wanted.

procedure shuffle(var a: array of integer; nLow: integer);
{"a" holds all values from nLow to nLow + high(a) in pseudorandom order.
Method: Fill array with values in order. Values above jTop are shuffled. jTop starts at array top and moves down one element per step. We're done when jTop is a[0]. On each step, a random element below jTop is exchanged with the one at jTop}
var
  j: integer;
  jTop: integer;
  nTemp: integer;
begin
  for j := 0 to high(a) do
    a[j] := j + nLow;
  jTop := high(a);
  randomize;
  while (jTop > 0) do
  begin
    j := random(jTop + 1);
    nTemp := a[j];
    a[j] := a[jTop];
    a[jTop] := nTemp;
    dec(jTop);
  end;
end;

How to store OLE objects in a blob field

Problem/Question/Abstract:

How would I store an OLE object into a database's blob field and preferably be able to read it back in a usable form later on?

Answer:

To write a TOLEContainer to a blobfield:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(myOleField, bmWrite);
  try
    Ole1.SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

To read it back:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(BugData.NotesNote, bmRead);
  try
    Ole1.LoadFromStream(Stream);
    Ole1.Iconic := False;
  finally
    Stream.Free;
  end;
end;

Where you put the code is up to you, but the DataChange and UpdateData events of the appropriate TDatasource might be a good idea.

How to limit the number of lines in a TRichEdit

Problem/Question/Abstract:

I have a form with fixed size boxes. I want to prevent the user from overfilling it. Is it possible to limit the height or at least the number of lines in a TRichEdit?

Answer:

Try keypress code like this:

procedure Form1.FMemo1KeyPress(Sender: TObject; var Key: Char);
begin
  if (Key = #13) and ((Sender as TRichEdit).Lines.Count >= 32) then
    Key := #0;
end;

How to save and load the captions of all components on a form to / from a text file

Problem/Question/Abstract:

I'm using a component which is able to save the caption of components to a textfile and then retrieve it again. This works quite nice since if one wants another language one can just change some captions and load the desired language. The only problem is that it is using only the well known Windows controls and is also checking if a component is of a certain type. Of course I want to be able to use it for all components, so how would I be able to check all the components on a form for caption properties (even if it is e.g. in a item of a component) without having to do type checking etc.?

Answer:

You can use functions from the TypInfo unit. You'll need a GetPropInfo to get information about the property, GetStrProp and SetStrProp functions to read and set a new caption for components. The example below is a component which can save the captions of all components on a form to the text file and load them back after the form was loaded. There is also a design time component editor which you need to save and load captions (see a popup menu over the component).

{The main component}
TMyCaptionReader = class(TComponent)
protected
  FFileName: string;
  procedure Loaded; override;
public
  constructor Create(AOwner: TComponent); override;
  procedure ReadCaptions;
  procedure WriteCaptions;
published
  property FileName: string read FFileName write FFileName;
end;

{The component editor}
TMyCaptionReaderEditor = class(TDefaultEditor)
public
  procedure ExecuteVerb(Index: Integer); override;
  function GetVerb(Index: Integer): string; override;
  function GetVerbCount: Integer; override;
end;

{ ... }

procedure TMyCaptionReaderEditor.ExecuteVerb(Index: Integer);
begin
  case Index of
    0: TMyCaptionReader(Component).WriteCaptions;
    1: TMyCaptionReader(Component).ReadCaptions;
  else
    inherited ExecuteVerb(Index)
  end;
end;

function TMyCaptionReaderEditor.GetVerb(Index: Integer): string;
begin
  case Index of
    0: Result := 'Write Captions...';
    1: Result := 'Read Captions...'
  else
    Result := inherited GetVerb(Index);
  end;
end;

function TMyCaptionReaderEditor.GetVerbCount: Integer;
begin
  Result := 2;
end;

constructor TMyCaptionReader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFileName := 'TheFile.txt';
end;

procedure TMyCaptionReader.Loaded;
begin
  inherited Loaded;
  ReadCaptions;
end;

procedure TMyCaptionReader.ReadCaptions;
var
  XStrings: TStringList;
  XComponent: TComponent;
  XPropInfo: PPropInfo;
  XName, XCaption: string;
  i, XPos: integer;
begin
  if not FileExists(FFileName) then
    exit;
  XStrings := TStringList.Create;
  try
    XStrings.LoadFromFile(FFileName);
    for i := 0 to XStrings.Count - 1 do
    begin
      XPos := pos('=', XStrings[i]);
      if XPos > -1 then
      begin
        XName := copy(XStrings[i], 0, XPos - 1);
        XCaption := copy(XStrings[i], XPos + 1, length(XStrings[i]) - 1);
        XComponent := Owner.FindComponent(XName);
        if Assigned(XComponent) then
        begin
          XPropInfo := GetPropInfo(XComponent, 'Caption');
          if Assigned(XPropInfo) then
            SetStrProp(XComponent, 'Caption', XCaption);
        end;
      end;
    end;
  finally
    XStrings.Free;
  end;
end;

procedure TMyCaptionReader.WriteCaptions;
var
  XStrings: TStringList;
  XComponent: TComponent;
  XPropInfo: PPropInfo;
  XCaption: string;
  i: integer;
begin
  XStrings := TStringList.Create;
  try
    if Assigned(Owner) then
    begin
      for i := 0 to Owner.ComponentCount - 1 do
      begin
        XComponent := Owner.Components[i];
        if Assigned(XComponent) then
        begin
          try
            XPropInfo := GetPropInfo(XComponent, 'Caption');
            if Assigned(XPropInfo) then
            begin
              XCaption := GetStrProp(XComponent, 'Caption');
              XStrings.Add(XComponent.Name + '=' + XCaption);
            end;
          except
          end;
        end;
      end;
    end;
    XStrings.SaveToFile(FFileName);
  finally
    XStrings.Free;
  end;
end;

Here's how the Register procedure could be:

procedure Register;
begin
  RegisterComponents('My Components', [TMyCaptionReader]);
  RegisterComponentEditor(TMyCaptionReader, TMyCaptionReaderEditor);
end;

Prompt the user before closing the program

Problem/Question/Abstract:

How to prompt the user before closing the program

Answer:

Here's how to prompt users whether they really want to exit a program or not (regardless of how they choose to close it). Place the following code in the OnCloseQuery event of the form:

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if (mrNo = MessageDlg('You really want to exit?', mtInformation, [mbYes, mbNo], 0)) then
  begin
    CanClose := False;
  end;
end;

How to use the alpha transparency features included in Windows 2000 and XP

Problem/Question/Abstract:

How to use the alpha transparency features included in Windows 2000 and XP

Answer:

{ ... }
const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY = 1;
  LWA_ALPHA = 2;

type
  TSetLayeredWindowAttributes = function(
    hwnd: HWND; {handle to the layered window}
    crKey: TColor; {specifies the color key}
    bAlpha: byte; {value for the blend function}
    dwFlags: DWORD {action}
    ): BOOL; stdcall;

procedure TfBaseSplash.FormCreate(Sender: TObject);
var
  Info: TOSVersionInfo;
  F: TSetLayeredWindowAttributes;
begin
  inherited;
  Info.dwOSVersionInfoSize := SizeOf(Info);
  GetVersionEx(Info);
  if (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and (Info.dwMajorVersion >= 5) then
  begin
    F := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
    if Assigned(F) then
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE)
        or WS_EX_LAYERED);
      F(Handle, 0, Round(255 * 80 / 100), LWA_ALPHA);
    end;
  end;
end;

Protect your software against piracy

Problem/Question/Abstract:

Here's my own experience on how to reduce the number of non-legal installations of software.

Answer:

Before I start, let me tell you that whatever protection system you use it's just a matter of time until someone's break it! So what you must have in mind is: "what is the best protection system for this special case ?"  You also must have in mind that the best you got is still breakable!

Once I needed to develop an application where preventing piracy was a must.

I did some investigation and found out what were the possible systems to prevent this. I also did some investigation on how to break those same protection systems.
Let me say that I got a bit disappointed...  I though that mass protection systems would be better then they are... Here's a summary of what I found among the most common:

Anti-Copy: prevents the disk copy, CD in this case.
Disk check: when application starts up check for the original disk, CD in this case.
Hardware check-up: you plug-in some hardware on your RS-232 port and check for it in your application from time to time.
Key activation: the software requires a key to be activated.

Here's what I found out about breaking thoes systems:

Anti-Copy: can be broken with a "clone copy" (bit-by-bit) of the disc...
Disk check: can be broken with a "clone copy" also...
Hardware check-up: read too much complains about it interfering with the system, and it also generates too much calls into your help-line...  Plus read somewhere that this can be fooled through software also...
Key activation: once the user registers, it can spread the key among friends and everybody can activate the application. If someone takes some time, one can break the code and create a patch to ignore activation or create a key generator.

Looking at this, you must agree that it didn't look too good...

After thinking a while on each of these systems I concluded that:

Anti-Copy: to easy to break!
Disk check: to easy to break!
Hardware check-up: causes to much troubles and can make customers to become un-satisfied.
Key activation: would be great if key proliferation could be stopped!

So I stick on the key activation idea and gave it a second though, exploiting the pros and cons of this system!  I simulated the regular use of this system to better understand it:

Get the product
Install the product
Request key
User requests the key
User gets the key
User activates the product

Here's another way to do it:

Get the product from friend
Install the product
Request key
User asks friend for friend's key
User uses the friend’s key

I concluded that if was definitely the best - having in mind what I needed to protect this specific product - if I could prevent the key from spreading!
Preventing key spreading became my next goal!

I knew I needed something that could give me guarantees that the application being activated was a legal copy and not a pirate one!  How could I guarantee this ?  How do you prove that what you own is legal ?  How do you prove that you bought something ?
The answer was easy: invoice!
Every product sold comes with an invoice, which has different data, like the invoice number, date and entity sold to!
My next step was using the invoice data on activation product.
But invoice data "per se" it was not enough, I mean, if someone gives a copy of the product can also give the invoice data to activate the product!
I simulated the piracy process again, using the invoice data:

Get the product from friend
Install the product
Request the invoice data
User requests the invoice data from friend
Request the key
User requests the key from friend

Now, that has a the same hole that usual key activation has...
I knew that I needed to force the key request for all installed products!
That became my next goal. How could I force the user to request a new key ?  
After some more neuron work, I came up with the answer: time!
On my simulations, both users, the legal an non-legal, did the same steps to activate the product, but they didn't do it at the same time...  Time is continuous and non-repeating, so time was the answer!

What did I do with time then ?  Basically, I generated a key using it!
To activate the product you must have a key, which is generated using the invoice data and the time you have installed the product in the system!
Here's how I made it work:

After product installed an encryption of the current time - year, month, day, hour, minute, second, millisecond - is saved somewhere in the system!  This is easy to do and there's a lot of ways to hide something is the system.
Invoice data request.
Generate a "request-key" using the time from 1. and the invoice data from 2..
Inform the user that it must request the activation key for the "request-key".
Key for product activation request.

I had found the solution!
To request the activation key, the user must specify what is the "request-key", which is guaranteed to be unique, since time is involved and the algorithm I used makes sure of that! ;)

Here's a simulation of the legal case:

Buy product and receive invoice
Install the product
Request invoice data
Inform user what the "request-key" is
User requests the activation key referring the "request-key" and the invoice data
User receives the key
User activates the product

It's quite simple, really, the only "visible" change from the original key activation system is the "request-key" that the user must specify when requesting the key!

But this is just half the solution, the other half is you controlling the number of installations!
But that is quite easy!  Every time a key is requested, you know who is requesting it, since the invoice data is specified, so if you got a customer that has 154 key requests in one month, there's something wrong... :)

I've also exploit the possible holes on the system:

A couple of non-legal installations may be done, the customer - or "customer friend" - may say that the system crashed and must reinstall...  That will just work for a couple of non-legal installations, since you may ask why that is the 98th key request done this week or the 3rd this day...
Disk clone can be done. There are tools on the market that clone hard-disks. But what the hack, you cannot prevent that!
Some one takes some time and patches the security or creates a key generator. Like said in the beginning, there's no way to prevent this...

This system does not work just as a piracy stopper, it also prevents it.
When the invoice data is requested, it's more unlike to someone to give it away, since you can track the customer that gave the invoice data to a friend, that gave it to a friend, that gave it to a friend... The original customer knows it can get troubles with the law by giving that information.
If you get some "customer" requesting its 10th activation key because "We got a new computer that is faster and want the application running on it.", you can say "Why have you bought 9 computers in the last 4 weeks ?"...
If you get some "customer" requesting its 50th activation key because "the system crashed and need to reinstall everything", you can say "Maybe there's something wrong, I'll send someone there to take a look at it! Please have your invoice in hand!"...
If you get some "customer" requesting its 154th activation key, you can say that unless proven to be the legal owner of the product you will not give the activation key...  The "customer" may say it is - it even can be -, but unless it has the invoice, it cannot prove it!...
And if you want to be a bit "nasty", you code a special key that will show the "Do you know that non-legal software may give you 3 years in jail ?" and uninstalls the application from the system...
The "customer" will get the point! ;)

Read out Edit / EditBox from another application even if it says: "*****"

Problem/Question/Abstract:

How to read out Edit / EditBox from another application even if it says: "*****"

Answer:

unit
  Unit1;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Panel1: TPanel;
    StatusBar1: TStatusBar;
    // Procedures
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  bQuit: Boolean;

implementation

{$R *.DFM}

//--------------------------------------------------------------------

procedure TForm1.FormCreate(Sender: TObject);

begin
  // Init Bo
  bQuit := False;

  // Init timer
  Timer1.Interval := 250;
  Timer1.Enabled := True;

end;
//--------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);

var
  pP: TPoint;
  iX, iY: Integer;
  iOldX, iOldY: Integer;
  iL: Integer;
  aBuf: array[0..255] of Char;
  hH, hOldH: THandle;
  hH1: Thandle;

begin
  // Timer off
  Timer1.Enabled := False;
  iOldX := 0;
  iOldY := 0;
  hOldH := 0;
  repeat
    // Let windows do his job(s)
    Application.ProcessMessages;
    // Get position of cursor on screen
    GetCursorPos(pP);
    // Convert to X and Y value
    iX := pP.x;
    iY := pP.y;
    // Get the handle of the component under the cursor
    hH := WindowFromPoint(pP);
    // Get the handle of the child (if any)
    hH1 := ChildWindowFromPoint(hH, pP);
    if hH1 <> 0 then
      hH := hH1;

    if (iOldX <> iX) or (iOldY <> iY) then
      if hH <> hOldH then
      begin
        if hH <> Panel1.Handle then
        begin
          GetClassName(hH, aBuf, SizeOf(aBuf));
          Form1.Panel1.Caption := 'Class: ' + StrPas(aBuf);
          // Show the classname in the label
          iL := SendMessage(hH, WM_GETTEXT, SizeOf(aBuf), longint(@aBuf));
          // If length of line > 0 then show the line in the Label
          if iL > 0 then
            Panel1.Caption := 'Text: "' + StrPas(aBuf) + '"';
        end
        else
          Panel1.Caption := 'Get me the password!';

        // Save old x, y, h values
        hOldH := hH;
        iOldX := iX;
        iOldY := iY;
      end;
  until bQuit;
end;
//--------------------------------------------------------------------

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin
  // Quit the repeat loop on close
  bQuit := True;
end;
//--------------------------------------------------------------------
end.
//====================================================================

How to make the first letter of a user-entered word in a TComboBox always uppercase

Problem/Question/Abstract:

Does anyone have a routine for uppercasing only the first letter of each word the user typed in an edit control - especially a combo box. I've experimented with the mask property for the dataset field but am not having any luck.

Answer:

procedure TForm1.ComboBox1Change(Sender: TObject);
var
  s, TempString: string;
  Cnt, temp: integer;
begin
  s := ComboBox1.Text;
  temp := ComboBox1.SelStart;
  if s <> '' then
  begin
    for Cnt := 1 to Length(s) do
    begin
      if (Cnt = 1) or (s[Cnt - 1] in [' ', ', ', ' ;']) then {or others here}
      begin
        TempString := s[Cnt];
        s[Cnt] := AnsiUpperCase(TempString)[1];
      end;
    end;
    ComboBox1.Text := s;
  end;
  ComboBox1.SelStart := temp;
end;

I strongly recommend to use the AnsiUpperCase function, if there's any possibility that non-English words may ever be entered into your application.

Allow Incremental Searching in your TDataSets

Problem/Question/Abstract:

Allow Incremental Searching in your TDataSets

Answer:

If you implement your search box (against a TDataSet) with a regular Locate() or FindKey() call requires that the user has typed in the exact search expression. It is much more handy to jump to the first match based on a partial search. E.g. if your user searches for the month 'August' in the list of 12 months' names, the user would type in 'A' and the cursor would jump to 'April'. Then the user would type the second letter.. 'u' and 'August' would be selected. This is called 'Incremental Searching'.

The following piece of code shows how to do it - put it as the onChange event handler of your form's edit box.

procedure TForm1.Edit1Change(Sender: TObject);
begin
  // empty? then do nothing!
  if Edit1.Text = '' then
    exit;

  //goto nearest match
  with Table1 do
  begin
    SetKey;
    FieldByName('Month').AsString := Edit1.Text;
    GotoNearest;
  end;
end;

How to trap mouse clicks on the Desktop

Problem/Question/Abstract:

I wonder if anyone can help me. I am trying to capture when the mouse button is pressed on the desktop wallpaper (excluding icons if possible).

Answer:

This returns the same handle:

function GetDesktopListViewHandle: THandle;
var
  S: string;
begin
  Result := FindWindow('ProgMan', nil);
  Result := GetWindow(Result, GW_CHILD);
  Result := GetWindow(Result, GW_CHILD);
  SetLength(S, 40);
  GetClassName(Result, PChar(S), 39);
  if PChar(S) <> 'SysListView32' then
    Result := 0;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  CursorPos: TPoint;
  h: THandle;
begin
  GetCursorPos(CursorPos);
  h := WindowFromPoint(CursorPos);
  Label1.Caption := IntToStr(h);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Label2.Caption := IntToStr(GetDesktopListViewHandle); { GetDeskTopWindow); }
  Timer1.Enabled := True;
end;

Encode a HTTP URL

Problem/Question/Abstract:

How to encode a HTTP URL?

Answer:

function HTTPEncode(const AStr: string): string;
const
  NoConversion = ['A'..'Z', 'a'..'z', '*', '@', '.', '_', '-'];
var
  Sp, Rp: PChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else if Sp^ = ' ' then
      Rp^ := '+'
    else
    begin
      FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
      Inc(Rp, 2);
    end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := HTTPEncode(Edit1.Text);
end;

Delete a complete folder

Problem/Question/Abstract:

How to delete a complete folder

Answer:

Solve 1:

I use this code to delete all files in a folder and/ or the folder itself:

function DeleteFolder(FolderName: string; LeaveFolder: Boolean): Boolean;
var
  r: TshFileOpStruct;
begin
  Result := False;
  if not DirectoryExists(FolderName) then
    Exit;
  if LeaveFolder then
    FolderName := FolderName + ' *.* '
  else if FolderName[Length(FolderName)] = ' \ ' then
    Delete(FolderName, Length(FolderName), 1);
  FillChar(r, SizeOf(r), 0);
  r.wFunc := FO_DELETE;
  r.pFrom := PChar(FolderName);
  r.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
  Result := ((ShFileOperation(r) = 0) and (not r.fAnyOperationsAborted));
end;


Solve 2:

uses
  ShellAPI;

function DeleteDir(const Directory: string);
var
  FileOp: TSHFileOpStruct;
begin
  FileOp.Wnd := Application.Handle;
  FileOp.wFunc := FO_DELETE;
  FileOp.pFrom := PChar(Directory + #0);
  FileOp.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
  Result := SHFileOperation(FileOp) = 0;
end;

Add FOF_SILENT to fFlags if you don't want a dialog.


Solve 3:

The following will send a directory to the recycle bin:

procedure ToRecycle(AHandle: THandle; const ADirName: string);
var
  SHFileOpStruct: TSHFileOpStruct;
  DirName: PChar;
  BufferSize: Cardinal;
begin
  BufferSize := Length(ADirName) + 1 + 1;
  GetMem(DirName, BufferSize);
  try
    FillChar(DirName^, BufferSize, 0);
    StrCopy(DirName, PChar(ADirName));
    with SHFileOpStruct do
    begin
      Wnd := AHandle;
      wFunc := FO_DELETE;
      pFrom := DirName;
      pTo := nil;
      fFlags := FOF_ALLOWUNDO;
      fAnyOperationsAborted := False;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
    if SHFileOperation(SHFileOpStruct) <> 0 then
      RaiseLastWin32Error;
  finally
    FreeMem(DirName, BufferSize);
  end;
end;


Solve 4:

procedure DeleteDir(aDir: string);
{delete directory & everything in it}
var
  T: TSHFileOpStruct;
begin
  Fillchar(T, SizeOf(T), #0);
  with T do
  begin
    Wnd := 0; {no handle -> no animation}
    wFunc := FO_DELETE;
    pFrom := pchar(aDir + #0#0);
    fFlags := FOF_SILENT or FOF_NOCONFIRMATION; {just do it}
  end;
  Application.ProcessMessages;
  if (SHFileOperation(T) <> 0) then
    RemoveDir(aDir);
end;


Solve 5:

The command-line program DELTREE.EXE that comes with Windows removes a directory with all its files and subdirectories. To mimic this behaviour in Delphi we can use the following procedure that uses the FindFirst, FindNext and FindClose functions to perform the file and directory search:

uses FileCtrl;

procedure DelTree(const Directory: TFileName);
var
  DrivesPathsBuff: array[0..1024] of char;
  DrivesPaths: string;
  len: longword;
  ShortPath: array[0..MAX_PATH] of char;
  dir: TFileName;
  procedure rDelTree(const Directory: TFileName);
    // Recursively deletes all files and directories
    // inside the directory passed as parameter.
  var
    SearchRec: TSearchRec;
    Attributes: LongWord;
    ShortName, FullName: TFileName;
    pname: pchar;
  begin
    if FindFirst(Directory + '*', faAnyFile and not faVolumeID,
      SearchRec) = 0 then
    begin
      try
        repeat // Processes all files and directories
          if SearchRec.FindData.cAlternateFileName[0] = #0 then
            ShortName := SearchRec.Name
          else
            ShortName := SearchRec.FindData.cAlternateFileName;
          FullName := Directory + ShortName;
          if (SearchRec.Attr and faDirectory) <> 0 then
          begin
            // It's a directory
            if (ShortName <> '.') and (ShortName <> '..') then
              rDelTree(FullName + '\');
          end
          else
          begin
            // It's a file
            pname := PChar(FullName);
            Attributes := GetFileAttributes(pname);
            if Attributes = $FFFFFFFF then
              raise EInOutError.Create(SysErrorMessage(GetLastError));
            if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then
              SetFileAttributes(pname, Attributes and not
                FILE_ATTRIBUTE_READONLY);
            if Windows.DeleteFile(pname) = False then
              raise EInOutError.Create(SysErrorMessage(GetLastError));
          end;
        until FindNext(SearchRec) <> 0;
      except
        FindClose(SearchRec);
        raise;
      end;
      FindClose(SearchRec);
    end;
    if Pos(#0 + Directory + #0, DrivesPaths) = 0 then
    begin
      // if not a root directory, remove it
      pname := PChar(Directory);
      Attributes := GetFileAttributes(pname);
      if Attributes = $FFFFFFFF then
        raise EInOutError.Create(SysErrorMessage(GetLastError));
      if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then
        SetFileAttributes(pname, Attributes and not
          FILE_ATTRIBUTE_READONLY);
      if Windows.RemoveDirectory(pname) = False then
      begin
        raise EInOutError.Create(SysErrorMessage(GetLastError));
      end;
    end;
  end;
  // ----------------
begin
  DrivesPathsBuff[0] := #0;
  len := GetLogicalDriveStrings(1022, @DrivesPathsBuff[1]);
  if len = 0 then
    raise EInOutError.Create(SysErrorMessage(GetLastError));
  SetString(DrivesPaths, DrivesPathsBuff, len + 1);
  DrivesPaths := Uppercase(DrivesPaths);
  len := GetShortPathName(PChar(Directory), ShortPath, MAX_PATH);
  if len = 0 then
    raise EInOutError.Create(SysErrorMessage(GetLastError));
  SetString(dir, ShortPath, len);
  dir := Uppercase(dir);
  rDelTree(IncludeTrailingBackslash(dir));
end;

Sample calls

This code will remove the directory C:\TEMP\A123:

DelTree('C:\TEMP\A123');

And this code will wipe out the diskette in drive A:

DelTree('A:'); // or DelTree('A:\');


WARNING: The procedure DelTree presented here erases files and directories, and they might not be recoverable later. It is provided in the belief that it is useful, but you use it at our own risk.