How to create a countdown timer

Problem/Question/Abstract:

I was wondering if anyone knew of a way in which you were able to create a timer in which you could set a time (of about 20 minutes) and have it countdown by seconds and be able to stop it.

Answer:

Drop a TTimer onto your form. Set the INTERVAL using the object inspector to 1000. Set the control's Enabled property to False. Use another control, say a TEdit or TSpinEdit to set a variable with the total number of seconds you wish to wait. Use a TButton control to enable the timer. Use a second button to disable the timer. Double-click on the timer to create an OnTimer event handler. In the event handler, decrement the total time counter and check to see if it hit zero.

procedure TForm1.Edit1Change(Sender: TObject);
begin
  {the time is entered in seconds.  If you wish the time to be entered in "hh:mm:ss",
  you will have to parse it and put it into a total seconds format.}
  TotalTime := StrToInt(Edit1.Text);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Timer1.Enabled := true;
  Edit1.Enabled := false; {disable the ability to set the time}
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Timer1.Enabled := false;
  Edit1.Enabled := true; {re-enable the ability to set the time}
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  dec(TotalTime); {decrement the total time counter}
  Edit2.Text := IntToStr(TotalTime); {put the value in an edit box so he can see it}
  if TotalTime = 0 then {have we timed out?}
    {... Do something ...}
end;

Remark:

Rather than decrement a counter in the OnTimer event handler, it's better to compare the current system time to the original start time and calculate the difference. The reason for this is that timer messages are low priority, and it's very likely that some will be lost before being processed, causing any countdown scheme to be inaccurate.

Save a complete directory

Problem/Question/Abstract:

Is there an API function which gives all the subdirectories and all the files of one particular directory (in order to save a whole directory for example )?

Answer:

You can copy a whole directory with one instruction using the ShFileOperation API function:

procedure TForm1.Button2Click(Sender: TObject);
var
  OpStruc: TSHFileOpStruct;
  frombuf, tobuf: array[0..128] of Char;
begin
  FillChar(frombuf, Sizeof(frombuf), 0);
  FillChar(tobuf, Sizeof(tobuf), 0);
  StrPCopy(frombuf, 'd:\brief\*.*');
  StrPCopy(tobuf, 'd:\temp\brief');
  with OpStruc do
  begin
    Wnd := Handle;
    wFunc := FO_COPY;
    pFrom := @frombuf;
    pTo := @tobuf;
    fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
    fAnyOperationsAborted := False;
    hNameMappings := nil;
    lpszProgressTitle := nil;
  end;
  ShFileOperation(OpStruc);
end;

If you need a list of all files and subdirs you have to do a recursive scan using FindFirst/ FindNext.

How to use SQL in combination with a TCheckListBox

Problem/Question/Abstract:

On a form, I have a TCheckListBox with records (fields code and name, strings) of a TTable (emp.DB).

[ ] 001 - aaaaaaaaaaa
[ ] 002 - bbbbbbbbbbb
[ ] 003 - ccccccccccc
etc.

How to build an SQL with only the checked items of the CheckListBox? For example, SELECT * FROM emp WHERE code = (???)...

Answer:

You need to inspect all of the items in the TCheckListBox and, for each one checked, add the text of the item (with quotation marks) to a string to be used for an IN predicate in the WHERE clause of your statement.

Written manually, your SQL statement might look like this (for the first two items checked):

SELECT *
FROM emp
WHERE code in ("aaaaaaaaaaa", "bbbbbbbbbbb")

Done programmatically, it would look something like this:

var
  InPredicate: string;
  i: Integer;
begin
  InPredicate := '';
  with Query1 do
  begin
    for i := 0 to (CheckListBox1.Items.Count - 1) do
      if CheckListBox1.Checked[i] then
        InPredicate := InPredicate + '"' + CheckListBox1.Items[i] + '",';
    System.Delete(InPredicate, Length(InPredicate), 1);
    Close;
    SQL[2] := Format('WHERE State IN (%s)', [InPredicate]);
    Open;
  end;
end;

Of course, this assumes the SQL statement starts out with a WHERE clause and this filter will always be on the third line. At any rate, that routine demonstrates dynamically building the values list for the IN predicate.

If you have too many items in that TCheckListBox, it might be possible to exceed the maximum length of a line in the TQuery.SQL property (255 characters). In such cases, you would need to add checking for this and account for building the filter across multiple lines in the SQL statement.

Too many programs create files but never cleanup after them self why?

Problem/Question/Abstract:

Yes that is a good question. In this short article I will try to motivate programmers to cleanup after their programs.

Answer:

In this short article I will try to motivate programmers to cleanup after their programs.

A program has several of files to keep track off in this busy world.  A program has supports files like the Ini file type.  The rule here is to remove old stuff from the file it is no longer is using.  You have a new release and you change the topic from one type to another.  Please remove the old one you know where and what - the user does not.

A program can create files as an output or function of the program.  In general the rule is that the program that creates the program gives it to someone else (another program).  In a good world the "other" program now owns the files and should be the one that removes the files when no longer needed or outdated.

A program can create log files.  This is to me always a real good idea to create log files.  The program should be able to run in three different modes: Full debug mode, log error mode, and absolute no logging at all.  One smart way of doing this is to create a folder structure lets say under the Exe location or user defined under setup.  Under the Log folder or whatever you call it create daily folders with the folder name of YYYYMMDD this way your program can easily delete older folders by simply reading the folder name.  You can select to keep all log files, delete all log files that is older than 30 - 60 - 90 days, or you can say I only want the last 7 folders.  The last option is great for programs that may only be used on weekly bases.

If you are in full debug mode you can even let you program email you the log files, so you can monitor the progress of the program.  You can take this to a profiling level where you log every function and then you can see that your clients are really using and what is not that heavily used.  Very good for upgrades information.

A trick regarding log files is to create them as ASCII comma delimited files (you can use the Commatext property in the TStringList).  With a CSV file you can use most database manager to massage the data in the file.  If you are not in the consulting business the CSV file can help you with your client.  If a client want a special report you can guide them to Excel and the book "Excel for dummies" and you clients can create reports till the paper runs out of the printer.

Again please have a function that will cleanup old files.  Here is another solution.

The DeleteAllFilesOlderThan function takes either a path like "C:\MyProgram\" or a full filename like "C:\MyProgram\Tmp\*.Txt".  If the Date is "Now" then all the files in the path or with the filename will be deleted.

{====================================================================}

function DeleteAllFilesOlderThan(const FileName: string; Date: TDateTime): Boolean;
{====================================================================}
var
  SearchRec: TSearchRec;
  sFile, sPath: string;

begin
  Result := True;
  sFile := ExpandFileName(FileName);
  sPath := ExtractFilePath(sFile);
  if FindFirst(sFile, faAnyFile, SearchRec) = 0 then
  begin
    if (SearchRec.Name <> '') and (SearchRec.Name <> '.') and (SearchRec.Name <> '..')
      then
    begin
      if FileDateToDateTime(FileAge(sPath + SearchRec.Name)) < Date then
      begin
        if not SysUtils.DeleteFile(sPath + SearchRec.Name) then
        begin
          Result := False;
        end;
      end;
    end;
    while FindNext(SearchRec) = 0 do
    begin
      if (SearchRec.Name <> '') and (SearchRec.Name <> '.') and (SearchRec.Name <>
        '..') then
      begin
        if FileDateToDateTime(FileAge(sPath + SearchRec.Name)) < Date then
        begin
          if not SysUtils.DeleteFile(sPath + SearchRec.Name) then
          begin
            Result := False;
          end;
        end;
      end;
    end;
  end;
  SysUtils.FindClose(SearchRec);
end;

I use this function as a base function for other functions like:

{====================================================================}

function DeleteAllFilesOlderThan30Days(const FileName: string): Boolean;
{====================================================================}
begin
  Result := DeleteAllFilesOlderThan(FileName, IncMonth(Now, -1));
end;

{====================================================================}

function DeleteAllFilesOlderThan60Days(const FileName: string): Boolean;
{====================================================================}
begin
  Result := DeleteAllFilesOlderThan(FileName, IncMonth(Now, -2));
end;

{====================================================================}

function DeleteAllFilesOlderThan90Days(const FileName: string): Boolean;
{====================================================================}
begin
  Result := DeleteAllFilesOlderThan(FileName, IncMonth(Now, -3));
end;

The Delphi IncMonth works also with negative numbers so if "Now" is May 13 and you are using -2 you will be looking at March 13.

So now your program should know.  Cleanup all the old files and files that the program no longer is using.

How to avoid flicker when switching a TForm from fsNormal to fsStayOnTop

Problem/Question/Abstract:

Is there any way to make a form StayOnTop whitout the little flickering it makes when switching from fsNormal to fsStayOnTop?

Answer:

It could be done, but requires some code from your side:

SetWindowPos(MyFormHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE +
  SWP_NOMOVE + SWP_NOACTIVATE);

I think you have to call this again when your application is restored from minimized state, or after closing a modal form.

Keystroke recording and playing back in the IDE

Problem/Question/Abstract:

Keystroke recording and playing back in the IDE

Answer:

If you write a lot of code, you probably have come across a situation where you need to record some keystrokes and play them back a number of times.

You can now do this in the Delphi IDE by pressing [Ctrl][Shift][R] to start recording, type in the keystrokes you want repeated, and press [Ctrl][Shift][R] to stop recording. To Play back, press [Ctrl][Shift][P].

Works with Default and Classic keymapping, Delphi 2.x and higher.

How to store the HTML source of a TWebBrowser programmatically

Problem/Question/Abstract:

Using the TWebBrowser component (Delphi 5), I am looking for a way to store the HTML code of the TWebBrowser. When I use the right mouse button, I can store the HTML code, but I would like to do this programmatically.

Answer:

uses
  ActiveX;

{Saves the HTML document - referenced through 'Document' - to a stream}

procedure SaveDocumentSourceToStream(Document: IDispatch; Stream: TStream);
var
  PersistStreamInit: IPersistStreamInit;
  StreamAdapter: IStream;
begin
  {Delete content of stream}
  Stream.Size := 0;
  Stream.Position := 0;
  {IPersistStreamInit - get document interface}
  if Document.QueryInterface(IPersistStreamInit, PersistStreamInit) = S_OK then
  begin
    {Use StreamAdapter to get the IStream interface for our stream}
    StreamAdapter := TStreamAdapter.Create(Stream, soReference);
    {Save data from document into stream}
    PersistStreamInit.Save(StreamAdapter, False);
    {Destroy StreamAdapter. Optional.}
    StreamAdapter := nil;
  end;
end;

Credit Card Validation

Problem/Question/Abstract:

Credit Card Validation

Answer:

Are you in need to validate a credit card? The following routine does some basic checking and returns the type of the credit card as a number - or use the const array to get the type of credit card by name. (E.g. 'Mastercard').

This code does not check that the credit card is actually valid, that it is good for a purchase or whether it belongs to a certain person. To accept any kind of orders, you need to do an address verification, combined with checking the expiration date.

The routine is still handy as an input validator on forms. You may download it here.


program CardTest;

uses
  Dialogs,
  SysUtils;

{$R *.RES}

const
  CardType: array[0..4] of string = ('Invalid', 'Amex', 'Visa', 'Mastercard',
    'Discover');

function Vc(C: string): Integer;
var
  Card: string[21];
  VCard: array[0..21] of Byte absolute Card;
  XCard: Integer;
  Cstr: string[21];
  y,
    x: Integer;
begin
  Cstr := '';
  FillChar(VCard, 22, #0);
  Card := C;
  for x := 1 to 20 do
    if (VCard[x] in [48..57]) then
      Cstr := Cstr + Chr(VCard[x]);
  Card := '';
  Card := Cstr;
  XCard := 0;
  if not odd(Length(Card)) then
    for x := (Length(Card) - 1) downto 1 do
    begin
      if odd(x) then
        y := ((VCard[x] - 48) * 2)
      else
        y := (VCard[x] - 48);
      if (y >= 10) then
        y := ((y - 10) + 1);
      XCard := (XCard + y)
    end
  else
    for x := (Length(Card) - 1) downto 1 do
    begin
      if odd(x) then
        y := (VCard[x] - 48)
      else
        y := ((VCard[x] - 48) * 2);
      if (y >= 10) then
        y := ((y - 10) + 1);
      XCard := (XCard + y)
    end;
  x := (10 - (XCard mod 10));
  if (x = 10) then
    x := 0;
  if (x = (VCard[Length(Card)] - 48)) then
    Vc := Ord(Cstr[1]) - Ord('2')
  else
    Vc := 0
end;

begin
  ShowMessage(CardType[Vc('4479750100222862')]);
end.

Getting the number of records from a fixed-length ASCII file

Problem/Question/Abstract:

I work a lot with fixed-length ASCII files, and I need to know how many total lines there are in a file. Sure, I can open up the file in a text editor, but really large files take forever to load. Is there a better way?

Answer:

As Mr. Miyagi said to Daniel-san in Karate Kid, "Funny you should ask..." Yes, there is a better way. What I'm going to show you may not be the best way, but it's reasonably fast, and exceptionally easy to use. It starts out with this premise. If you know the total number of bytes in the file and know the length of each record, then if you divide the total bytes by the record length, you should get the number of records in the file. Sounds reasonable, right? And it's exactly the way we do it.

For this example, I used a TFileStream object to open up my text file. I like using this particular object because it has come convenient methods and properties that I can use to get the information that I need; in particular, the Size property and the Read and Seek methods. How do I use them? Let's go through some plain English to give you an idea:

Open up a file stream on a text file
Get its total byte size
Now, serially move through the file, byte-by-byte reading each byte into a single-character buffer until you reach a return character (#13).
As you pass each byte, increment a counter variable that will serve as both a file reference point and later, the length of the record.
When you get to the return character, break out of the loop, add 2 to the reference counter (to account for the #13#10 CR/LF pair).
Finally return the result as the file size divided by the record length.

Here's the code that accomplishes the English above:

{======================================================================
This function will give you the exact record count of a file. It uses
a TFileStream and goes through it byte by byte until it encounters
a #13. When it does, it adds 2 to the recLen to account for the #13#10
CR/LF pair, then divides the byte size of the file by the record true
record length.

Note that this will only work on text files.
======================================================================}

function GetTextFileRecords(FileName: string): Integer;
var
  ts: TFileStream;
  fSize,
    recLen: Integer;
  buf: Char;
begin
  buf := #0;
  recLen := 0;
  //Open up a File Stream
  ts := TFileStream.Create(FileName, fmOpenRead);
  with ts do
  begin
    //Get the File Size
    fSize := Size;
    try
      //Move through the file a byte at a time
      while (buf <> #13) do
      begin
        Seek(recLen, soFromBeginning);
        Read(buf, 1);
        Inc(recLen);
      end
    finally
      Free;
    end;
  end;
  recLen := recLen + 2; //Need to account for CR/LF pair.
  Result := Round(fSize / recLen);
end;

As I mentioned above, this may not be the "best" way to do this, but it is a way to approach this problem. A faster way to do this would have been to open up the file as a regular file, then read a bunch of bytes into a large buffer, let's say an Array of Char 4K in size. Perusing through an array is much faster than moving through a file, but the disadvantage there is that you run the risk of having the buffer too small. I've seen some fixed-length ASCII files with line sizes up to 8K.

In any case, the method I presented above may not be the most efficient, but it's safe, and it works. Besides, what's a few milliseconds worth to you? Have at it!

Wait a minute! 10:00PM

Okay, I couldn't resist. I realized that I could've done better than my example above. Here's the method I described immediately above:

function GetTextFileRecords(FileName: string): Integer;
const
  BlockSize = 8192;
var
  F: file;
  fSize,
    amtXfer: Integer;
  buf: array[0..BlockSize] of Char;
begin
  AssignFile(F, FileName); //Open up the text file as an untyped file
  Reset(F, 1);
  fSize := FileSize(F); //Get the file size
  BlockRead(F, buf, BlockSize, amtXfer); //read in up to an 8K block
  CloseFile(F); //close the file, you're done
  Result := Round(fSize / (Pos(#13, StrPas(buf)) + 1));
end;

There are several things different about this function as opposed to the function above. First of all, it involves a lot less code. This is due to not have to perform class constructor; I open up an untyped file, read a big block, get its size, then immediately close it. Notice too that I don't use a loop to find a #13. Instead, I use the StrPas function to convert the array of char into a string that's passed to the Pos function that will give me the position of the return character; thus the record length. Adding one to this value will account for the #10 portion of the CR/LF pair.

Because I don't have to deal with constructing an object, this method is a lot faster than method above, and amazingly it's not very complicated. Where this type of operation can get tricky is with the BlockRead function. In order to use BlockRead successfully, you need to specify a record size. That can be a bit confusing, so just remember this: for byte- by-byte serial reads through a file, always use a record size of 1. Also, notice that I also included a variable called amtXfer. BlockRead fills this with the actual number of bytes read. If you don't supply this, you'll raise an exception when BlockRead executes. That's not too much of a problem because all you need to do is create an exception handling block - but why bother? Just supply the variable, and you don't have to worry about the exception.

Okay, now it's time to close this out... Is this the best way to get the record length of a fixed length text file? Admittedly, it's one of the faster ways save using Assembler. But I'm wondering what a purely WinAPI call set would look like.... If you have any ideas, please make sure to let me know!

Here I Go Again! 11:05 PM

I guess my curiosity got the best of me tonight, because I just wasn't satisfied doing just the BlockRead method. I knew there had to be another way to do it with WinAPI calls. So I did just that. Look at the code below:

function GetTextFileRecordsWinAPI(FileName: string): Integer;
const
  BlockSize = 8192;
var
  F: THandle;
  amtXFer,
    fSize: DWORD;
  buf: array[0..BlockSize] of Char;
begin
  //Open up file
  F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_NO_BUFFERING, 0);
  fSize := GetFileSize(F, nil); //Get the file's size
  ReadFile(F, buf, BlockSize, amtXfer, nil); //Read a block from the file
  CloseHandle(F);
  Result := Round(fSize / (Pos(#13, StrPas(buf)) + 1));
end;

This method is almost exactly the same as the one immediately above, but instead uses WinAPI calls to accomplish the same task.

Now which method is better? I DON'T KNOW! Actually, for simplicity's sake, I prefer the elegance of the second method - there's just a lot less coding involved. With the WinAPI method, while it may require one less line of code, the CreateFile function is not the easiest thing to work with - I spent a bit of time Alt-Tabbing between the code editor and Windows help to get the syntax and constants right. Granted, it's easier now that I've done it, but it's not a method that I prefer.

So I'll leave it up to you to decide which method you like better.

Set margins in a TMemo

Problem/Question/Abstract:

How to set margins in a TMemo

Answer:

EM_SETRECT message is sent to Memo to fix the size of the canvas of the component.

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TRect;
  LeftMargin: integer;
  RightMargin: integer;
begin
  LeftMargin := 20;
  RightMargin := 10;

  R := Memo1.ClientRect;
  R.Left := R.Left + LeftMargin;
  R.Top := R.Top + 2;
  R.Bottom := R.Bottom - 2;
  R.Right := R.Right - RightMargin;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, Longint(@R));
end;

How to disable the ability of a MDI child form to move

Problem/Question/Abstract:

I try to disable the ability to move MDI children around. Problem is that if I have tiled for example 2 MDI's, I cannot change focus to another one.

Answer:

procedure TForm1.WMSyscommand(var msg: TWMSyscommand);
begin
  if (msg.cmdtype and $FFF0) <> SC_MOVE then
    inherited;
end;

How to store two strings in the item of a TComboBox

Problem/Question/Abstract:

I want to store a second string in a combobox item. How can I do this without defining an object wrapper?

Answer:

procedure AddString(const S1, S2: string; Items: TStrings);
var
  Obj: TObject;
begin
  Obj := nil;
  string(Obj) := S2;
  Items.AddObject(S1, Obj);
end;

procedure DeleteItem(const I: Integer; Items: TStrings);
var
  Obj: TObject;
begin
  Obj := Items.Objects[I];
  Items.Objects[I] := nil;
  string(Obj) := '';
end;


Just be sure to go over every item and release the string.

How to control focus in a MDI application

Problem/Question/Abstract:

Status: MDI-application. MDI window and one child window. MDI window owns a TPanel component, which owns any component which can get focus (TEdit for example). Child window owns a TDBGrid component.

Problem: After running this simple test application, the focus is set on child window's first focusable component - TDBGrid. After switching focus to TEdit component owned by MDI window, there is no more possibility to switch focus back to TDBGrid component owned by child window. TDBGrid component is immune to any mouse events. Why? It looks like a child window is thinking about still having focus.

Answer:

This is one of the many shortcomings of the Windows MDI framework, it has never been designed to cope with controls outside the MDI children that can take the focus. You can trick it by sending a WM_MDIACTIVATE message to the active MDI child, here demonstrated by an OnClick handler for a combobox on the toolbar:

procedure TMainForm.ComboBox1Click(Sender: TObject);
begin
  { ... other actions }
  if Assigned(ActiveMDIChild) then
    with ActiveMDIChild do
      sendmessage(handle, WM_MDIACTIVATE, 0, handle);
end;

Determining if a string matches a pattern with wildcards ('?' and '*')

Problem/Question/Abstract:

Is there a LIKE function in Delphi that compares a string with a pattern?

Answer:

Solve 1:

Sometimes we need to know if a string matches a pattern, which is a string with wildcards (for example '?' and '*'). Here we implement a function that returns True if the string matches the pattern and False if not.

function Like(AString, Pattern: string): boolean;
var
  i, n, n1, n2: integer;
  p1, p2: pchar;
label
  match, nomatch;
begin
  AString := UpperCase(AString);
  Pattern := UpperCase(Pattern);
  n1 := Length(AString);
  n2 := Length(Pattern);
  if n1 < n2 then
    n := n1
  else
    n := n2;
  p1 := pchar(AString);
  p2 := pchar(Pattern);
  for i := 1 to n do
  begin
    if p2^ = '*' then
      goto match;
    if (p2^ <> '?') and (p2^ <> p1^) then
      goto nomatch;
    inc(p1);
    inc(p2);
  end;
  if n1 > n2 then
  begin
    nomatch:
    Result := False;
    exit;
  end
  else if n1 < n2 then
  begin
    for i := n1 + 1 to n2 do
    begin
      if not (p2^ in ['*', '?']) then
        goto nomatch;
      inc(p2);
    end;
  end;
  match:
  Result := True;
end;

Sample call

if Like('Walter', 'WA?T*') then
  ShowMessage('It worked!');

If you want to see another example, we use this function to determine if a file name matches a specification in the article "Determining if a file name matches a specification" (keyword: MatchesSpec).


Solve 2:

There is a built in Delphi function called MatchesMask(). It takes * , ? and sets as parameters.

{...}
if MatchesMask('Hello World', '[H-K]?????[W-Y]*') then
  
{...}
if MatchesMask(FileName, '*.exe') then
  
{...}

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

How to create a TDrawGrid where all cells act as buttons

Problem/Question/Abstract:

Is there anybody who knows how to subclass the existing TDrawGrid so that all the cells act as buttons? I would like the OnDrawCell to return the inner rectangle of the button look and set the colors of the bevel so that they look like a button.

Answer:

unit ButtonDrawGrid;

interface

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

type
  TPBButtonDrawGrid = class(TDrawGrid)
  private
    FCellDown: TGridCoord;
  protected
    { Protected declarations }
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
  public
    constructor Create(aOwner: TComponent); override;
  end;

procedure Register;

implementation

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

{ TButtonDrawGrid }

constructor TPBButtonDrawGrid.Create(aOwner: TComponent);
begin
  inherited;
  FCellDown.X := -1;
  FCellDown.Y := -1;
end;

procedure TPBButtonDrawGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
var
  r: TRect;
  style: DWORD;
begin
  r := ARect;
  if not (gdFixed in aState) then
  begin
    Canvas.Brush.Color := clBtnFace;
    Canvas.Font.Color := clBtnText;
    style := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
    if (FCellDown.X = aCol) and (FCellDown.Y = aRow) then
      style := style or DFCS_PUSHED;
    DrawFrameControl(Canvas.Handle, r, DFC_BUTTON, style);
  end;
  inherited DrawCell(ACol, aRow, r, aState);
end;

procedure TPBButtonDrawGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  cell: TGridCoord;
begin
  if (Button = mbLeft) and ((Shift - [ssLeft]) = []) then
  begin
    MousetoCell(X, Y, cell.X, cell.Y);
    if (cell.X >= FixedCols) and (cell.Y >= FixedRows) then
    begin
      FCellDown := cell;
      InvalidateCell(cell.X, cell.Y);
    end;
  end;
  inherited;
end;

procedure TPBButtonDrawGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  cell: TGridCoord;
begin
  if Shift = [ssLeft] then
  begin
    MousetoCell(X, Y, cell.X, cell.Y);
    if not CompareMem(@cell, @FCellDown, Sizeof(cell)) then
    begin
      if (FCellDown.X >= 0) and (FCellDown.Y >= 0) then
        InvalidateCell(FCellDown.X, FCellDown.Y);
      FCellDown := cell;
      InvalidateCell(cell.X, cell.Y);
    end;
  end;
  inherited;
end;

procedure TPBButtonDrawGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and (Shift = []) then
  begin
    InvalidateCell(FCellDown.X, FCellDown.Y);
    FCellDown.X := -1;
    FCellDown.Y := -1;
  end;
  inherited;
end;

function TPBButtonDrawGrid.SelectCell(ACol, ARow: Integer): Boolean;
begin
  result := false;
end;

end.

How to create a custom TShape with a caption

Problem/Question/Abstract:

I'd like to read text from a Unicode text file, but don't know how to do this. It looks like ReadLn only works with single-byte character sets.

Answer:

Here is how you can add a caption:

unit SampleShape;

interface

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

type
  TSampleShape = class(TShape)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
  public
    { Public declarations }
  published
    { Published declarations }
    property Caption;
    property Font;
  end;

procedure Register;

implementation

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

procedure TSampleShape.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TSampleShape.CMTextChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TSampleShape.Paint;
var
  R: TRect;
begin
  inherited;
  Canvas.Font.Assign(Font);
  R := ClientRect;
  DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_VCENTER or
    DT_CENTER or DT_SINGLELINE);
end;

end.

Creating an equivalent to the missing TListView.OnColumnDblClick

Problem/Question/Abstract:

How to subclass your header-control (using a TListView), to receive a OnColumnDblClick- equivalent notification?

Answer:

This requires a bit of work. MS did not see fit to send a notification to the TListView when the user double-clicks on the header. But the header control class does have the CS_DBLCLKS style, so it does get WM_LBUTTONDBLCLK messages, it just does not do anything with them.
To get at these messages requires API-style subclassing of the header control. How? See below.


uses..., Commctrl;
...
const
  UM_LISTVIEW_COLUMN_DBLCLICK = WM_USER + 1982;
  ....
    { the HeaderProc function should look something like this: }

function
  HeaderProc(wnd: HWND; msg: Cardinal; wparam: WPARAM; lparam: LPARAM): Longint;
    stdcall;
var
  hti: THDHitTestInfo;
begin
  Result := CallWindowProc(Pointer(GetWindowLong(wnd, GWL_USERDATA)),
    wnd, msg, wparam, lparam);
  if msg = WM_LBUTTONDBLCLK then
  begin
    FillChar(hti, sizeof(hti), 0);
    hti.Point := SmallPointToPoint(TSmallPoint(lparam));
    if SendMessage(wnd, HDM_HITTEST, 0, Longint(@hti)) >= 0 then
      if hti.Flags = HHT_ONHEADER then
        PostMessage(MainForm.Handle, UM_LISTVIEW_COLUMN_DBLCLICK, hti.Item, 0);
    { Change MainForm to whatever you need }
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
var
  wnd: HWND;
  oldProc: Integer;
begin
  {beginning of workaround for missing TListView.OnColumnDblClick}
  wnd := GetWindow(aListView.handle, GW_CHILD); { <-- your TListView's name here }
  if wnd <> 0 then
  begin
    if (GetClassLong(wnd, GCL_STYLE) and CS_DBLCLKS) <> 0 then
    begin
      oldproc := GetWIndowLong(wnd, GWL_WNDPROC);
      if GetWindowLong(wnd, GWL_USERDATA) <> 0 then
        raise
          Exception.Create('Cannot sublcass ListView header, USERDATA already in use');
      SetWIndowLong(wnd, GWL_USERDATA, oldproc);
      SetWindowLong(wnd, GWL_WNDPROC, integer(@HeaderProc));
    end;
  end
  else
    ShowMessage('ListView component in vsReport state is missing !!!');
  {...}
  {Do some more wonderful things}
end;

and then don't forget to declare a custom message handler for UM_LISTVIEW_COLUMN_DBLCLICK (this will be your OnColumnDblClick equivalent).

How to create an 'Easter Egg' in an application

Problem/Question/Abstract:

How to create an 'Easter Egg' in an application

Answer:

1. Give the form a field of type String:


Match: string;


2. Declare a constant that represents the character sequence that needs to be typed in order
     for the Easter Egg to appear. For example:

const
  Target = ' abc ' #1;


(In this example, you have to type "a"  "b"  "c" and finally CTRL - A)


3. Set the forms KeyPreview property to True.


4. In the dialog's OnCreate event handler, do this:


procedure TMyAboutBox.FormCreate(Sender: TObject);
begin
  Match := ''
end;


5. In the dialog's OnKeyPress event handler, do this:


procedure TMyAboutBox.FormKeyPress(Sender: TObject; var Key: Char);
begin
  Match := Match + Key;
  if Pos(Match, Target) <> 1 then
    Match := ''
  else if Match = Target then
    ShowMessage('Congratulations')
end;

Display hints on the title bar of a TForm

Problem/Question/Abstract:

How to display hints on the title bar of a TForm

Answer:

To accomplish this you need to create a handler for the OnHint event for TApplication. Whenever a hint is going to fire, Delphi calls the TApplication.OnHint event for processing, if nothing is defined then the default processing occurs (i.e. the yellow tool-tip window).

To override the event, you need to define a TNotifyEvent method in your form and assign it to Application.OnHint. Following is sample code that demonstrates this. To use, create a new project and drop three buttons on the form. Then set the Form's ShowHint property to True. Finally enter the following code and run the application, when you move the mouse over the buttons, their hint will appear as the form's caption.

unit Sample1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure DoHint(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

procedure TForm1.DoHint(Sender: TObject);
begin

  {A hint can contain to pieces, a short and long hint separated by a pipe '|' (e.g. "Open File|Displays a file browser to select file to open". The short hint is "Open File" and the long hint is "Displays a file browser to select file to open".)

  To display the short portion, use the global method
  GetShortHint(const Hint: string): string;

  To display the long portion, use the global method
  GetLongHint(const Hint: string): string;}

  Caption := GetLongHint(Application.Hint);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnHint := DoHint;
  {Assigns the form's current caption as the form's hint}
  Hint := Caption;
  {Assign Hints to the buttons}
  Button1.Hint := 'Button One|This is the hint for button 1';
  Button2.Hint := 'Button Two|This is the hint for button 2';
  Button3.Hint := 'Button Three|This is the hint for button 3';
end;

end.

Determining if a file name matches a specification

Problem/Question/Abstract:

How can I know if a file name matches a specification with wildcards?

Answer:

Sometimes we need to know if a file name matches a file specification (a name with wildcards: '?' and '*'). Here we implement a function that returns True if the given file name matches a specification and False if not.

function MatchesSpec(const FileName,
  Specification: string): boolean;
var
  SName, SExt, FName, FExt: string;
begin
  FName := ExtractFileName(FileName);
  SName := ExtractFileName(Specification);
  FExt := ExtractFileExt(FName);
  SExt := ExtractFileExt(SName);
  SetLength(FName, Length(FName) - Length(FExt));
  SetLength(SName, Length(SName) - Length(SExt));
  if SName = '' then
    SName := '*';
  if SExt = '' then
    SExt := '.*';
  if FExt = '' then
    FExt := '.';
  Result := Like(FName, SName) and Like(FExt, SExt);
end;

NOTE: The Like function has been featured in my article  
"Determining if a string matches a pattern with wildcards ('?' and '*')"

Sample call

if MatchesSpec('Document1.doc', 'DOC*.DO?') then
  ShowMessage('It worked!');

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

How to create a TListBox with coloured entries

Problem/Question/Abstract:

I add protocol messages into a listbox, simple lines of text like "success" and "failed". Now I want to have a different background color for every item. For example the "failed" ones in red and the "successed" in green. How to achieve this?

Answer:

Put a TListBox on a form, call it ListBox1, set its style to "lbOwnerDrawFixed" and implement the following event:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  Flags: Longint;
begin
  with ListBox1 do
  begin
    { If the item is not selected, then...}
    if not (odSelected in State) then
      with Canvas.Brush do
      begin
        { Choose the appropriate color}
        case Index of
          0: Color := clBlue;
          1: Color := clRed;
          2: Color := clGreen;
        end;
      end;
    { Draw the colored rectangle.}
    ListBox1.Canvas.FillRect(Rect);
    if Index < Items.Count then
    begin
      Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
      if not UseRightToLeftAlignment then
        Inc(Rect.Left, 2)
      else
        Dec(Rect.Right, 2);
      DrawText(Canvas.Handle, PChar(Items[Index]), Length(Items[Index]), Rect, Flags);
    end;
  end;
end;

Create a transparent form which is still moveable

Problem/Question/Abstract:

How to create a transparent form which is still moveable

Answer:

You can achieve a transparency effect by creating a window region that includes only the controls on the form but not the background. Making a window transparent and still moveable:

procedure TForm1.Button2Click(Sender: TObject);
var
  frmRegion, tempRegion: HRGN;
  i: Integer;
  Arect: TRect;
begin
  frmRegion := 0;
  for I := 0 to ControlCount - 1 do
  begin
    { create a region for the control }
    aRect := Controls[i].BoundsRect;
    { coordinates have to be window-relative, not client area relative }
    OffsetRect(aRect, clientorigin.x - left, clientorigin.y - top);
    tempRegion := CreateRectRgnIndirect(aRect);
    { merge the region with the "summary" region we are building }
    if frmRegion = 0 then
      frmRegion := tempRegion
    else
    begin
      CombineRgn(frmRegion, frmRegion, tempRegion, RGN_OR);
      DeleteObject(tempRegion);
    end;
  end;
  { create a region for the caption and menu bar and add it to the summary }
  tempregion := CreateRectRgn(0, 0, Width, GetSystemMetrics(SM_CYCAPTION) +
    GetSystemMetrics(SM_CYSIZEFRAME) +
    GetSystemMetrics(SM_CYMENU) * Ord(Menu < > nil));
  CombineRgn(frmRegion, frmRegion, tempRegion, RGN_OR);
  DeleteObject(tempRegion);
  SetWindowRgn(handle, frmRegion, true);
end;

Four different ways to load and play sound files

Problem/Question/Abstract:

Four different ways to load and play sound files

Answer:

There are four ways of loading and playing sound in your program:

Use the sndPlaySound() function to directly play a wave file
Read the wave file into memory, then use the sndPlaySound() to play the wave file
Use sndPlaySound to directly play a wave file thats embedded in a resource file attached to your application.
Read a wave file thats embedded in a resource file attached to your application into memory, then use the sndPlaySound() to play the wave file


Sample Code:

unit PlaySnd1;

interface

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

type
  TForm1 = class(TForm)
    PlaySndFromFile: TButton;
    PlaySndFromMemory: TButton;
    PlaySndbyLoadRes: TButton;
    PlaySndFromRes: TButton;
    procedure PlaySndFromFileClick(Sender: TObject);
    procedure PlaySndFromMemoryClick(Sender: TObject);
    procedure PlaySndFromResClick(Sender: TObject);
    procedure PlaySndbyLoadResClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$R snddata.res} // Resource file containing the *.wav file

uses
  MMSystem;

{1. Use the sndPlaySound() function to directly play a wave file}

procedure TForm1.PlaySndFromFileClick(Sender: TObject);
begin
  sndPlaySound('hello.wav', SND_FILENAME or SND_SYNC);
end;

{2. Read the wave file into memory, then use the sndPlaySound() to play the wave file}

procedure TForm1.PlaySndFromMemoryClick(Sender: TObject);
var
  f: file;
  p: pointer;
  fs: integer;
begin
  AssignFile(f, 'hello.wav');
  Reset(f, 1);
  fs := FileSize(f);
  GetMem(p, fs);
  BlockRead(f, p^, fs);
  CloseFile(f);
  sndPlaySound(p, SND_MEMORY or SND_SYNC);
  FreeMem(p, fs);
end;

{3. Use sndPlaySound to directly play a wave file thats embedded in a resource file attached
to your application}

procedure TForm1.PlaySndFromResClick(Sender: TObject);
begin
  PlaySound('HELLO', hInstance, SND_RESOURCE or SND_SYNC);
end;

{4. Read a wave file thats embedded in a resource file attached to your application into memory,
then use the sndPlaySound() to play the wave file}

procedure TForm1.PlaySndbyLoadResClick(Sender: TObject);
var
  h: THandle;
  p: pointer;
begin
  h := FindResource(hInstance, 'HELLO', 'WAVE');
  h := LoadResource(hInstance, h);
  p := LockResource(h);
  sndPlaySound(p, SND_MEMORY or SND_SYNC);
  UnLockResource(h);
  FreeResource(h);
end;

end.

Interbase and standard database components

Problem/Question/Abstract:

How do I use an Interbase database with standard database controls?

Answer:

I have struggled for hours to get to grips with this. Manuals available aren't very clear on this.

What you need:

Set BDE alias for Database (BDE Administrator)
Add table (tblDepartm) ,Datasource,Database and UpdateSQL component to a dataform.
Set the Database field of the database to the name of the database component (Not to the Alias of the BDE, this is cross linked through the database component)
Add Data aware component to main form. Set there source to Datasource above.
Add Post button on the main form. (Set the button to post the table i.e. table1.post)
On the UpdateSQL component right click to open the SQLupdate editor. Generate the code for the various functions (Select, update, delete);
Set the tables UpdateObject to the UpdateSQL component.
Set CachedUpdates to true on the table.

How does it work. Each table has an UpdateSQL component associated with it. This handles updates to a live record set. Updating a live recordset of a Interbase database wouldn't be possible without a UpdateSQL component. The code in the UpdateSQL component handles the changes to the underlying table of the table component. When updating a table (pressing the post button) the Onupdaterecord event (below) is called which then tells the UpdateSQL component which update kind to use (insert,delete,update). Once this is applied to the UpdateSQL component the changes are made to the local cached dataset. Remember these updates will not be applied until the Database component's Applyupdates method is called. (Below)

Type the following into the Onupdaterecord event of the Table:

procedure TDataform.tblDepartmUpdateRecord(DataSet: TDataSet;
  UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
begin
  {This is a confusing concept, but the Apply below tells the
  update component which SQL commands to use , insert , alter or select and
  when you applyupdates on the database for this dataset the correct
  sql statement is utilised and the dataset is updated. See on closequery
  method of Department form}
  try
    uptDepartm.Apply(Updatekind);
    UpdateAction := uaApplied;
  except
    UpdateAction := uaFail;
  end;

end;

This is the code to close the main form. It checks if any updates are pending on the database and then applies the updates. Only now is the underlying table updated on the server. Keep in mind that you have to close and open the tables to reflect the changes on the client side because a refresh is not allowed on a DBMS like Interbase.

procedure TfrmDepart.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
var
  Res: integer;
begin
  with Dataform do
    if tblDepartm.UpdatesPending then
    begin
      Res := messagedlg('Save changes ?', mtInformation, mbYesNoCancel, 0);
      if Res = mrYes then
      begin
        dbMTS.Applyupdates([tblDepartm]);
        {Somehow the first time you applyupdates on a dataset it is very
        slow, but thereafter it is lightning fast. Must be that the BDE
        only caches the info once you call the applyupdates method for the
        first time!}
        tblDepartm.close;
        tblDepartm.open;
      end;
      Canclose := Res <> mrCancel;
    end;
end;

How to change contrast in a colour image

Problem/Question/Abstract:

How to change contrast in a color image

Answer:

Changing contrast in a greyscale image is fairly easy. You can use histogram equilization or histogram stretching. Contrast enhancing a color image is a bit tricker since there are three color planes. In some cases you can histostretch each color plane (like HistoStretchGrays above), but usually this will result in an undesirable color shift.

Here's some code for changing contrast in a 256 colour image:

function ContrastLUT(Amount: Integer): array[Byte] of Byte;
var
  i, z: Integer;
begin
  for i := 0 to 126 do
  begin
    z := i - ((Abs(128 - i) * Amount) div 256);
    if z > 255 then
      z := 255
    else if z < 0 then
      z := 0;
    Result[i] := z;
  end;
  for i := 127 to 255 do
  begin
    z := i + ((Abs(128 - i) * Amount) div 256);
    if z > 255 then
      z := 255
    else if z < 0 then
      z := 0;
    Result[i] := z;
  end;
end;

Apply the lookup table to your bitmap bytes to adjust contrast.

How do I stop my TEdit control beeping?

Problem/Question/Abstract:

If a user hits the enter key in a TEdit box, he is 'rewarded' with an annoying beep.

Answer:

To avoid this, set KeyPreview := True for the form and capture the enter key in the OnKeyPress form event.
If the sender is the editbox, you now can process the return and change it to something else like null before the editbox sees it.

How to create a flat TCheckBox

Problem/Question/Abstract:

I want to inherit the TCheckbox class in order to create a new TCheckBox class that is the flat version for TCheckbox. What style to override in order to make it a flat checkbox instead of a 3D checkbox?

Answer:

{ ... }
TExCheckBox = class(TCheckBox)
private
  { Private declarations }
  FFlat: Boolean;
  FMultiLine: Boolean;
  FPushLike: Boolean;
  procedure SetFlat(const Value: Boolean);
  procedure SetMultiLine(const Value: Boolean);
  procedure SetPushLike(const Value: Boolean);
protected
  { Protected declarations }
  procedure CreateParams(var Params: TCreateParams); override;
public
  { Public declarations }
  constructor Create(AOwner: TComponent); override;
published
  { Published declarations }
  property Flat: Boolean read FFlat write SetFlat default true;
  property MultiLine: Boolean read FMultiLine write SetMultiLine default false;
  property PushLike: Boolean read FPushLike write SetPushLike default false;
end;

{ TExCheckBox }

constructor TExCheckBox.Create(AOwner: TComponent);
begin
  FFlat := true;
  FMultiLine := false;
  FPushLike := false;
  inherited Create(AOwner);
end;

procedure TExCheckBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if FFlat then
    Params.Style := Params.Style or BS_FLAT
  else
    Params.Style := Params.Style and not BS_FLAT;
  if FMultiLine then
    Params.Style := Params.Style or BS_MULTILINE
  else
    Params.Style := Params.Style and not BS_MULTILINE;
  if FPushLike then
    Params.Style := Params.Style or BS_PUSHLIKE
  else
    Params.Style := Params.Style and not BS_PUSHLIKE;
end;

procedure TExCheckBox.SetFlat(const Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    RecreateWnd;
  end;
end;

procedure TExCheckBox.SetMultiLine(const Value: Boolean);
begin
  if Value <> FMultiLine then
  begin
    FMultiLine := Value;
    RecreateWnd;
  end;
end;

procedure TExCheckBox.SetPushLike(const Value: Boolean);
begin
  if Value <> FPushLike then
  begin
    FPushLike := Value;
    RecreateWnd;
  end;
end;

Plug-in Internet Protocols (without DLL's)

Problem/Question/Abstract:

Show how to make a plugin protocol which executes your program and can pass variables to your application (like mailto:, http:, telnet:, outlook:,...)

Answer:

After searching through the internet for a way to integrate my application into Internet Explorer in the form of a protocol I found 2 different ways that were documented and included delphi code:

myprotocol://
http://mynamespace//

However I was looking for a way which would look like this:

myprotocol:

Eventually I gave up, until I noticed that on http://messenger.yahoo.com/messenger/imv they used this to execute a chat window with the desired theme. So I decided to look in the registry (as with all previous work I had discovered that the relevant data, usually including CLSID's would be linked together in the registry) and I discovered something
incredibly simple yet effective. Rather than using a DLL and CLSID's they had simply added some keys and values to the HKEY_CLASSES_ROOT exactly the same way as you would if you were associating a file-type. However there were 2 abnormal values:

HKEY_CLASSES_ROOTymsgr (Default) was equal to "URL: YMessenger Protocol"
There was a blank string added as HKEY_CLASSES_ROOTymsgr "URL Protocol"

After changing the default value I found that it made no difference, so all you need to do is to add a blank string named "URL Protocol".

This type of protocol can take parameters, which are parsed as follows:
Lets say that our program is named c:\program.exe and our protocol is program: if you use program:minimize, this is parsed asif you entered the following at the commandline:

c:>program.exe program:minimize

therefore ParamStr(1) is equal to program:minimize

Now, if you are wondering what this has to do with myprotocol:// type protocols, then I think you dont quite understand what was written above. Despite the fact that our protocol program: does not end with //, does not mean that we can not use it in the same way, after all, program: does take parameters, therefore you can actually use myprotocol:// and simply ignore that prefix.

Heres some code to add your program as a protocol:

procedure AddProtocol(Details, Protocol, Command: string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_CLASSES_ROOT;
  Reg.LazyWrite := false;
  Reg.OpenKey(Protocol, true);
  Reg.WriteString('', Details);
  Reg.WriteString('URL Protocol', '');
  Reg.OpenKey('shell\open\command', true);
  Reg.WriteString('', command);
  Reg.CloseKey;
  Reg.free;
end;

example

AddProtocol('URL: DKB Protocol', 'dkb',
  '"D:\Projects\Programs\DKB\Compiled\dkb.exe" %1');

How to attach a file inside a DLL or executable

Problem/Question/Abstract:

I don't know if it is possible to attach a file to a DLL or exe. Example: You create a function (useOtherdll (bool)) in Test.dll with a parameter that tells you to use a DLL named Needed.dll. If the function parameter is 'true' then the DLL Needed.dll must be in the current directory, if the function parameter is 'false' then the DLL Needed.dll must not to be in the current directory. So if it is possible to attach in test.dll my other DLL Needed.dll, and then I can copy it if it is necessary or not.

Answer:

You can use streams to copy any data to the end of any other data - ie., copy a DLL to the end of a DLL. Example:

procedure TForm1.Button1Click(Sender: TObject);
var
  f: integer;
  fStream: TFileStream;
  mStream: TMemoryStream;
  theFiles: TStringList;
begin
  theFiles := TStringList.Create;
  try
    theFiles.Add('Needed.dll');
    theFiles.Add('TEST.dll');
    if theFiles.Count > 0 then
    begin
      mStream := TMemoryStream.Create;
      try
        for f := 0 to theFiles.Count - 1 do
        begin
          fStream := TFileStream.Create(theFiles[f], fmOpenRead);
          try
            mStream.CopyFrom(fStream, fStream.Size);
          finally
            fStream.Free;
          end;
        end;
        mStream.Seek(0, soFromBeginning);
        mStream.SaveToFile('NEW.dll');
      finally
        mStream.Free;
      end;
    end;
  finally
    theFiles.Free;
  end;
end;

You would need to mark the start of the second DLL somewhere. Then when needed, load the combined DLL into a stream. Seek to second DLL block, and copy it in a stream. Save that block steam back to the disk as the second DLL name.