Change the font of all controls on a form at runtime

Problem/Question/Abstract:

How to change the font of all controls on a form at runtime

Answer:

By default all controls have ParentFont = true, so if you did not change that for specific controls you could just change the forms Font property, e.g. in code attached to the Screen.OnActiveFormChange event. If you cannot rely on all controls having Parentfont = true you would have to loop over all controls on the form and set the font property for each or at least for those that have ParentFont set to false. You can use the routines from unit TypInfo for that, they allow you to access published properties by name. The code, again sitting in a handler for Screen.onActiveFormChange, would be something like this:

ModifyFontsFor(Screen.ActiveControl);

where

procedure ModifyFontsFor(ctrl: TWinControl);

  procedure ModifyFont(ctrl: TControl);
  var
    f: TFont;
  begin
    if IsPublishedProp(ctrl, 'Parentfont') and (GetOrdProp(ctrl, 'Parentfont') =
      Ord(false)) and IsPublishedProp(ctrl, 'font') then
    begin
      f := TFont(GetObjectProp(ctrl, 'font', TFont));
      f.Name := 'Symbol';
    end;
  end;

var
  i: Integer;
begin
  ModifyFont(ctrl);
  for i := 0 to ctrl.controlcount - 1 do
    if ctrl.controls[i] is TWinControl then
      ModifyFontsfor(TWinControl(ctrl.controls[i]))
    else
      Modifyfont(ctrl.controls[i]);
end;

Remember to add TypInfo to your uses clause.

How to use antialising

Problem/Question/Abstract:

You want to use the Antialising effect in your application, but you don't know how.

Answer:

First you have to know how Antialising work. For every pixel in the canvas and it's neighbors must be create the color difference between both color values.  That's all. You just have to go through all pixels of your canvas and do this.

With the following procedure you create your custom Antialising effect. The procedure needs the grade (Percent) of the Antialising effect. If Percent is 0, there will be no effekt, up to 100 there will be a more stronger effect.


procedure Antialising(C: TCanvas; Rect: TRect; Percent: Integer);
var
  l, p: Integer;
  R, G, B: Integer;
  R1, R2, G1, G2, B1, B2: Byte;
begin
  with c do
  begin
    for l := Rect.top to Rect.Bottom do
    begin
      for p := Rect.left to Rect.right do
      begin
        R1 := GetRValue(Pixels[p, l]);
        G1 := GetGValue(Pixels[p, l]);
        B1 := GetBValue(Pixels[p, l]);

        R2 := GetRValue(Pixels[p - 1, l]);
        G2 := GetGValue(Pixels[p - 1, l]);
        B2 := GetBValue(Pixels[p - 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p - 1, l] := RGB(R, G, B);
        end;

        R2 := GetRValue(Pixels[p + 1, l]);
        G2 := GetGValue(Pixels[p + 1, l]);
        B2 := GetBValue(Pixels[p + 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p + 1, l] := RGB(R, G, B);
        end;

        R2 := GetRValue(Pixels[p, l - 1]);
        G2 := GetGValue(Pixels[p, l - 1]);
        B2 := GetBValue(Pixels[p, l - 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l - 1] := RGB(R, G, B);
        end;

        R2 := GetRValue(Pixels[p, l + 1]);
        G2 := GetGValue(Pixels[p, l + 1]);
        B2 := GetBValue(Pixels[p, l + 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l + 1] := RGB(R, G, B);
        end;
      end;
    end;
  end;
end;


Note: There must be some lines or something else on the canvas, otherwise there is no effect.

Check if Delphi is running

Problem/Question/Abstract:

How to check if Delphi is running

Answer:

function DelphiRunning: Boolean;
var
  H1, H2, H3, H4: HWnd;
const
  A1: array[0..12] of char = \ 'TApplication\'#0;
  A2: array[0..15] of char = \ 'TAlignPalette\'#0;
  A3: array[0..18] of char = \ 'TPropertyInspector\'#0;
  A4: array[0..11] of char = \ 'TAppBuilder\'#0;
  T1: array[0..6] of char = \ 'Delphi\'#0;
begin
  H2 := FindWindow(A2, nil);
  H3 := FindWindow(A3, nil);
  H4 := FindWindow(A4, nil);
  Result := (H2 <> 0) and (H3 <> 0) and (H4 <> 0);
end;

When TCanvas.StretchDraw is not enough

Problem/Question/Abstract:

In some cases, the StretchDraw method of TCanvas can produce unsatisfying results. This article presents an alternative that can be better under some circumstances.

Answer:

One of the things I wanted the toolbar to do was to display the icons of the programs that it launches at a size smaller than that of ordinary icons. After retrieving the icon for a program and putting it in a bitmap.  I first tried to use TCanvas.StretchDraw to stretch the bitmap onto another bitmap which I would then assign to a TImage.  Although this worked, the icons came out looking bad.  It looked like StretchDraw droped pixels when it needed to make a bitmap smaller.  For large images this is probably a good idea but for my purpose, it wasn't adequate.  Instead I retrieved the color for each pixel in the source bitmap, calculated the fraction of each pixel in the destination bitmap that the source would cover and then assigned the final color of the pixel in the destination based on the proportions of pixels in the source that covered them.

unit ManipulateBitmaps;

interface

uses ShellAPI, Windows, SysUtils, Graphics, ExtCtrls;

procedure StretchBitmap(const Source, Destination: TBitmap);
{
This proceedure takes stretches the image in Source
and puts it in Destination.
The width and height of Destination must be specified before
calling StretchBitmap.
The PixelFormat of both Source and Destination are changed to pf32bit.
}

implementation

type
  PLongIntArray = ^TLongIntArray;
  TLongIntArray = array[0..16383] of longint;

procedure GetIndicies(const DestinationLength, SourceLength,
  DestinationIndex: integer;
  out FirstIndex, LastIndex: integer;
  out FirstFraction, LastFraction: double);
{
This proceedure compares the length of two pixel arrays and determines
which pixels in the destination are covered by those in the source.
It also determines what fraction of the first and last pixels are covered
in the destination.
}
var
  Index1A: double;
  Index2A: double;
  Index2B: integer;
begin
  Index1A := DestinationIndex / DestinationLength * SourceLength;
  FirstIndex := Trunc(Index1A);
  FirstFraction := 1 - Frac(Index1A);
  Index2A := (DestinationIndex + 1) / DestinationLength * SourceLength;
  Index2B := Trunc(Index2A);
  if Index2A = Index2B then
  begin
    LastIndex := Index2B - 1;
    LastFraction := 1;
  end
  else
  begin
    LastIndex := Index2B;
    LastFraction := Frac(Index2A);
  end;
  if FirstIndex = LastIndex then
  begin
    FirstFraction := FirstFraction - (1 - LastFraction);
    LastFraction := FirstFraction;
  end;
end;

procedure StretchBitmap(const Source, Destination: TBitmap);
{
This proceedure takes stretches the image in Source
and puts it in Destination.
The width and height of Destination must be specified
before calling StretchBitmap.
The PixelFormat of both Source and Destination are changed to pf32bit.
}
var
  P, P1, P2: PLongIntArray;
  X, Y: integer;
  FirstY, LastY, FirstX, LastX: integer;
  FirstYFrac, LastYFrac, FirstXFrac, LastXFrac: double;
  YFrac, XFrac: double;
  YIndex, XIndex: integer;
  AColor: TColor;
  Red, Green, Blue: integer;
  RedTotal, GreenTotal, BlueTotal, FracTotal: double;
begin
  Source.PixelFormat := pf32bit;
  Destination.PixelFormat := Source.PixelFormat;

  for Y := 0 to Destination.height - 1 do
  begin
    P := Destination.ScanLine[y];

    GetIndicies(Destination.Height, Source.Height, Y,
      FirstY, LastY, FirstYFrac, LastYFrac);

    for x := 0 to Destination.width - 1 do
    begin

      GetIndicies(Destination.width, Source.width, X,
        FirstX, LastX, FirstXFrac, LastXFrac);

      RedTotal := 0;
      GreenTotal := 0;
      BlueTotal := 0;
      FracTotal := 0;

      for YIndex := FirstY to LastY do
      begin
        P1 := Source.ScanLine[YIndex];
        if YIndex = FirstY then
        begin
          YFrac := FirstYFrac;
        end
        else if YIndex = LastY then
        begin
          YFrac := LastYFrac;
        end
        else
        begin
          YFrac := 1;
        end;

        for XIndex := FirstX to LastX do
        begin
          AColor := P1[XIndex];
          Red := AColor mod $100;
          AColor := AColor div $100;
          Green := AColor mod $100;
          AColor := AColor div $100;
          Blue := AColor mod $100;

          if XIndex = FirstX then
          begin
            XFrac := FirstXFrac;
          end
          else if XIndex = LastX then
          begin
            XFrac := LastXFrac;
          end
          else
          begin
            XFrac := 1;
          end;

          RedTotal := RedTotal + Red * XFrac * YFrac;
          GreenTotal := GreenTotal + Green * XFrac * YFrac;
          BlueTotal := BlueTotal + Blue * XFrac * YFrac;
          FracTotal := FracTotal + XFrac * YFrac;
        end;
      end;

      Red := Round(RedTotal / FracTotal);
      Green := Round(GreenTotal / FracTotal);
      Blue := Round(BlueTotal / FracTotal);

      AColor := Blue * $10000 + Green * $100 + Red;

      P[X] := AColor;
    end;
  end;
end;

end.


I recently wrote a freeware toolbar (http://www.mindspring.com/~rbwinston/launcher.htm)

How to rearrange items within a TListBox

Problem/Question/Abstract:

Can someone point me to a document on how to drag items around (reposition) within a TListbox?

Answer:

Solve 1:

It is easier than you might think. Set the DragMode property to dmAutomatic, then provide these event-handlers for OnDragDrop and OnDragOver:

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender = Source);
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  DropIndex: Integer;
begin
  DropIndex := ListBox1.ItemAtPos(Point(X, Y), True);
  ListBox1.Items.Exchange(ListBox1.ItemIndex, DropIndex);
end;

Solve 2:

There is no build-in method. Try that:


procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Sender is TListBox;
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  iTemp: integer;
  ptTemp: TPoint;
  szTemp: string;
begin
  { change the x, y coordinates into a TPoint record }
  ptTemp.x := x;
  ptTemp.y := y;
  { Use a while loop instead of a for loop due to items possible being removed
   from listboxes this prevents an out of bounds exception }
  iTemp := 0;
  while iTemp <= TListBox(Source).Items.Count - 1 do
  begin
    { look for the selected items as these are the ones we wish to move }
    if TListBox(Source).selected[iTemp] then
    begin
      { use a with as to make code easier to read }
      with Sender as TListBox do
      begin
        { need to use a temporary variable as when the item is deleted the indexing will change }
        szTemp := TListBox(Source).items[iTemp];
        { delete the item that is being dragged  }
        TListBox(Source).items.Delete(iTemp);
        { insert the item into the correct position in the listbox that it was dropped on }
        items.Insert(itemAtPos(ptTemp, true), szTemp);
      end;
    end;
    inc(iTemp);
  end;
end;

Adding an icon to the Windows About dialog

Problem/Question/Abstract:

Adding an icon to the Windows About dialog

Answer:

If you want to bring up the standard Windows 'About..' dialog box, then you can use ShellAbout() from the ShellAPI unit and customize the appearance by adding your own text, application name and an icon.

The downside to this technique is that it will say '(c) Microsoft' in the box.

The upside is that you see the registered user and some system parameters (free space..). It's a quick-and-dirty solution for an About-box.

  
uses
  Windows, ShellAPI;

procedure TForm1.About1Click(Sender: TObject);
begin
  ShellAbout(Application.MainForm.Handle,
    'Address Book Application',
    'Version 1.23.3beta' + #13#10 +
    'Compiled 2001-08-03 15:25:10',
    Application.Icon.Handle);
end;

Antialiased line drawer using scanline

Problem/Question/Abstract:

How to draw antialiased lines using a TBitmap's scanlines

Answer:

procedure AALine(x1, y1, x2, y2: single; color: tcolor; bitmap: tbitmap);
  function CrossFadeColor(FromColor, ToColor: TColor; Rate: Single): TColor;
  var
    r, g, b: byte;
  begin
    r := Round(GetRValue(FromColor) * Rate + GetRValue(ToColor) * (1 - Rate));
    g := Round(GetGValue(FromColor) * Rate + GetGValue(ToColor) * (1 - Rate));
    b := Round(GetBValue(FromColor) * Rate + GetBValue(ToColor) * (1 - Rate));
    Result := RGB(b, g, r);
  end;

type
  intarray = array[0..1] of integer;
  pintarray = ^intarray;

  procedure hpixel(x: single; y: integer);
  var
    FadeRate: single;
  begin
    FadeRate := x - trunc(x);
    with bitmap do
    begin
      if (x >= 0) and (y >= 0) and (height > y) and (width > x) then
        pintarray(bitmap.ScanLine[y])[trunc(x)] := CrossFadeColor(Color,
          pintarray(bitmap.ScanLine[y])[trunc(x)], 1 - FadeRate);
      if (trunc(x) + 1 >= 0) and (y >= 0) and (height > y) and (width > trunc(x) + 1)
        then
        pintarray(bitmap.ScanLine[y])[trunc(x) + 1] := CrossFadeColor(Color,
          pintarray(bitmap.ScanLine[y])[trunc(x) + 1], FadeRate);
    end;
  end;

  procedure vpixel(x: integer; y: single);
  var
    FadeRate: single;
  begin
    FadeRate := y - trunc(y);
    with bitmap do
    begin
      if (x >= 0) and (trunc(y) >= 0) and (height > trunc(y)) and (width > x) then
        pintarray(bitmap.ScanLine[trunc(y)])[x] := CrossFadeColor(Color,
          pintarray(bitmap.ScanLine[trunc(y)])[x], 1 - FadeRate);
      if (x >= 0) and (trunc(y) + 1 >= 0) and (height > trunc(y) + 1) and (width > x)
        then
        pintarray(bitmap.ScanLine[trunc(y) + 1])[x] := CrossFadeColor(Color,
          pintarray(bitmap.ScanLine[trunc(y) + 1])[x], FadeRate);
    end;
  end;

var
  i: integer;
  ly, lx, currentx, currenty, deltax, deltay, l, skipl: single;
begin
  if (x1 <> x2) or (y1 <> y2) then
  begin
    bitmap.PixelFormat := pf32Bit;
    currentx := x1;
    currenty := y1;
    lx := abs(x2 - x1);
    ly := abs(y2 - y1);

    if lx > ly then
    begin
      l := trunc(lx);
      deltay := (y2 - y1) / l;
      if x1 > x2 then
      begin
        deltax := -1;
        skipl := (currentx - trunc(currentx));
      end
      else
      begin
        deltax := 1;
        skipl := 1 - (currentx - trunc(currentx));
      end;
    end
    else
    begin
      l := trunc(ly);
      deltax := (x2 - x1) / l;
      if y1 > y2 then
      begin
        deltay := -1;
        skipl := (currenty - trunc(currenty));
      end
      else
      begin
        deltay := 1;
        skipl := 1 - (currenty - trunc(currenty));
      end;
    end;

    currentx := currentx + deltax * skipl;
    currenty := currenty + deltay * skipl; {}

    for i := 1 to trunc(l) do
    begin
      if lx > ly then
        vpixel(trunc(currentx), currenty)
      else
        hpixel(currentx, trunc(currenty));
      currentx := currentx + deltax;
      currenty := currenty + deltay;
    end;
  end;
end;

How to search for a certain font style in a TRichEdit

Problem/Question/Abstract:

How to search for a certain font style in a TRichEdit

Answer:

Finding all bold-faced words in a TRichEdit control:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    ListBox1: TListBox;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  wordstart, wordend: Integer;
begin
  listbox1.clear;
  listbox1.setfocus;
  S := richedit1.text;
  wordstart := 0;
  repeat
    {find start of next word}
    repeat
      Inc(wordstart);
    until
      (wordstart > Length(S)) or IsCharAlpha(S[wordstart]);
    if wordstart <= Length(S) then
    begin
      {find end of word}
      wordend := wordstart;
      repeat
        Inc(wordend);
      until
        (wordend > Length(S)) or not IsCharAlpha(S[wordend]);
      {we have a word, select it in the rich edit}
      with richedit1 do
      begin
        selstart := wordstart - 1; {character index is 0 based!}
        sellength := wordend - wordstart;
        {check the attributes}
        if (fsBold in SelAttributes.Style) and (caBold in
          SelAttributes.ConsistentAttributes) then
          {we have a winna, add it to the listbox}
          listbox1.items.add(Copy(S, wordstart, wordend - wordstart));
      end;
      wordstart := wordend;
    end;
  until
    wordstart >= Length(S);
end;

end.

Long file names - short file names

Problem/Question/Abstract:

Long file names - short file names

Answer:

Here's a way to convert between short (8.3 DOS file names) and long file names:


{$APPTYPE console}

program LongShrt;

uses
  Windows, SysUtils;

function GetShortName(sLongName: string): string;
var
  sShortName: string;
  nShortNameLen: integer;
begin
  SetLength(sShortName, MAX_PATH);

  nShortNameLen := GetShortPathName(PChar(sLongName),
    PChar(sShortName), MAX_PATH - 1);

  if nShortNameLen = 0 then
  begin
    { handle errors... }
  end;

  SetLength(sShortName, nShortNameLen);

  Result := sShortName;
end;

function GetLongName(sShortName: string; var bError: boolean): string;
var
  bAddSlash: boolean;
  SearchRec: TSearchRec;
  nStrLen: integer;
begin
  bError := False;
  Result := sShortName;
  nStrLen := Length(sShortName);
  bAddSlash := False;

  if sShortName[nStrLen] = '\' then
  begin
    bAddSlash := True;
    SetLength(sShortName, nStrLen - 1);
    dec(nStrLen);
  end;

  if ((nStrLen - Length(ExtractFileDrive(sShortName))) > 0) then
  begin
    if FindFirst(sShortName, faAnyFile, SearchRec) = 0 then
    begin
      Result := ExtractFilePath(sShortName) + SearchRec.name;
      if bAddSlash then
      begin
        Result := Result + '\';
      end;
    end
    else
    begin
      // handle errors...       bError := True;
    end;
    FindClose(SearchRec);
  end;
end;

function GetLongName(sShortName: string): string;
var
  s: string;
  p: integer;
  bError: boolean;
begin
  Result := sShortName;

  s := '';
  p := Pos('\', sShortName);
  while (p > 0) do
  begin
    s := GetLongName(s + Copy(sShortName, 1, p), bError);
    Delete(sShortName, 1, p);
    p := Pos('\', sShortName);

    if (bError) then
      Exit;
  end;
  if sShortName <> '' then
  begin
    s := GetLongName(s + sShortName, bError);
    if bError then
      Exit;
  end;
  Result := s;
end;

const
  csTest = 'C:\program Files';

var
  sShort,
    sLong: string;

begin
  sShort := GetShortName(csTest);
  WriteLn('Short name for "' + csTest +
    '" is "' + sShort + '"');

  WriteLn;

  sLong := GetLongName(sShort);
  WriteLn('Long name for "' + sShort + '" is "' + sLong + '"');
end.

Sort Order of Internet Explorer Favorites

Problem/Question/Abstract:

You can easily get the list of favorites from the directory, but how can you emulate the same sort order showing in Internet Explorer?

Answer:

I could not find this information anywhere on the Microsoft site or on Google Groups, so I had to just start digging in the registry and in the binary.

The registry path for favorites is

HKey_Current_User\Software\Microsoft\Windows\CurrentVersion\Explorer\MenuOrder\Favorites\

containing the directory structure mirroring the structure in your favorites.

The registry key "order" is a binary containing the visible name, order number, and DOS filename.  The start of the registry binary looks like:

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

Position 16 contains a count of the number of items, 22 in this case. (This is Hex, remember!)

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

Position 17 starts data, with 3 nulls and the count of total data (Hex 48 or 68 in decimal) and 3 more nulls and the order number (position 7, relative to the data start and "D" or 13).

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

Relative position 20 is the count of the name, including the DOS filename.

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

Relative position 25 begins the name, terminated by a null

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

Then a DOS filename, 3 nulls, then a hex value 5 as a terminator.

08 00 00 00 02 00 00 00 24 06 00 00 01 00 00 00
16 00 00 00 48 00 00 0D 00 00 00 00 39 00 32 00
98 00 00 00 B1 2C 74 B5 20 00 42 65 6E 20 5A 65
69 67 6C 65 72 27 73 20 44 65 6C 70 68 69 20 50
61 67 65 2E 75 72 6C 00 42 45 4E 5A 45 49 7E 31
2E 55 52 4C 00 00 00 00 05 ...(continues)

And the next record starts after the #5 terminator.

An ugly little chunk of code to pull this data and put it in a TMemo out would be:

const
  REGLEN = 5000;
var
  I, A, B: Integer;
  reg: TRegistry;
  buf: array[0..REGLEN] of char;
  itembuf: array[0..1000] of char;
  lastpos: Integer;
  order: Integer;
  name, dosfile: array[0..200] of char;
  namecount, count: Integer;

begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\MenuOrder\Favorites\Delphi', FALSE);
  reg.ReadBinaryData('Order', buf, REGLEN);

  count := ord(buf[16]);
  Memo1.Lines.Add('How Many: ' + intToStr(count));

  lastpos := 17;
  for I := 0 to count - 1 do // Iterate
  begin
    for a := lastpos to lastpos + 999 do // Iterate
    begin
      itembuf[a - lastpos] := buf[a];
    end; // for

    order := ord(itembuf[7]);
    Memo1.Lines.Add('This order ' + intToStr(order));

    namecount := ord(itembuf[20]);
    for a := 25 to namecount + 25 do // Iterate
    begin
      name[a - 25] := itembuf[a];
      if itembuf[a] = #0 then
        break;
    end; // for
    Memo1.Lines.Add('Name ' + name);

    for b := a to a + 13 do // Iterate
    begin
      dosfile[b - a - 1] := itembuf[b];
    end; // for
    if dosfile = '' then
      dosfile := name;

    Memo1.Lines.Add('DOS File ' + dosfile);

    lastpos := ord(itembuf[3]) + lastpos;
  end; // for
  reg.free;

How to set all events of an object to NIL at runtime

Problem/Question/Abstract:

Is there a way to enumerate all of an objects events at runtime and set them to nil?

Answer:

You can use RTTI to accomplish your goal, but only for published, not public, events. Using RTTI is pretty complex, so I've written a working utility procedure for you which takes any object instance and assigns nil to its published events:

unit uNilEvent;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  TypInfo;

procedure NilEvents(Instance: TObject);
var
  TypeInfo: PTypeInfo;
  I, Count: Integer;
  PropList: PPropList;
  PropInfo: PPropInfo;
  Method: TMethod;
begin
  TypeInfo := Instance.ClassInfo;
  Method.Code := nil;
  Method.Data := nil;
  Count := GetPropList(TypeInfo, [tkMethod], nil);
  GetMem(PropList, Count * SizeOf(Pointer));
  try
    GetPropList(TypeInfo, [tkMethod], PropList);
    for I := 0 to Count - 1 do
    begin
      PropInfo := PropList^[I];
      SetMethodProp(Instance, PropInfo, Method);
    end;
  finally
    FreeMem(PropList);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  sText = 'The 2nd time you click Button1 the event will not fire';
begin
  NilEvents(Button1);
  ShowMessage(sText);
end;

end.

How to change the node order of a TTreeNode

Problem/Question/Abstract:

Say I have a TOutline with these nodes:

Parent1
Node1
Node2
Node3
Parent2
Parent3

And I need to change the order of the nodes. How can I for example step Node2 down one step at a time and disable any movement when there are no more nodes to move past at that level (just after Node3). I need to restrict the stepping inside a group/ level and that it don't move to another parent.

Answer:

Look in the help file for the TTreeNode methods GetNextSibling, GetPrevSibling and MoveTo. Say you have a form with a tree view and two buttons, labelled up and down. The code for the onclick events of the up button would look something like this:

procedure UpOnClick
var
  PrevSibling: TTreeNode;
begin
  {If no node is selected, exit the procedure}
  if MyTreeView.Selected = nil then
    Exit;
  {If the node the user is trying to move is not a child node, exit the procedure}
  if MyTreeView.Selected.Level <> 1 then
    Exit;
  with MyTreeView.Selected do
  begin
    PrevSibling := GetPrevSibling;
    if PrevSibling <> nil then
      MoveTo(PrevSibling, naInsert);
  end;
end;

procedure DownOnClick
var
  NextSibling: TTreeNode;
begin
  {If no node is selected, exit the procedure}
  if MyTreeView.Selected = nil then
    Exit;
  {If the node the user is trying to move is not a child node, exit the procedure}
  if MyTreeView.Selected.Level <> 1 then
    Exit;
  with MyTreeView.Selected do
  begin
    NextSibling := GetNextSibling;
    if NextSibling <> nil then
      NextSibling.MoveTo(MyTreeView.Selected, naInsert);
  end;
end;

How to print the contents of a TRichEdit to a printer canvas

Problem/Question/Abstract:

I have a TRichEdit Control that I want to print as part of a document. There is other information that needs to go on the printed page. The Print method seems to start a separate document. How do I print the rich edits contents to the printer canvas of my document. As well I need to anticipate that there could be one or two pages of printed depending on the information in the TRichEdit.

Answer:

You have to use the EM_FORMATRANGE message to print the richedits content in code. Printing rich edit contents using EM_FORMATRANGE:


procedure TForm1.Button2Click(Sender: TObject);
var
  printarea: TRect;
  x, y: Integer;
  richedit_outputarea: TRect;
  printresX, printresY: Integer;
  fmtRange: TFormatRange;
begin
  Printer.beginDoc;
  try
    with Printer.Canvas do
    begin
      printresX := GetDeviceCaps(handle, LOGPIXELSX);
      printresY := GetDeviceCaps(handle, LOGPIXELSY);
      Font.Name := 'Arial';
      Font.Size := 14;
      Font.Style := [fsBold];
      printarea :=
        Rect(printresX, {1 inch left margin}
        printresY * 3 div 2, {1.5 inch top margin}
        Printer.PageWidth - printresX, {1 inch right margin}
        Printer.PageHeight - printresY * 3 div 2 {1.5 inch bottom margin}
        );
      x := printarea.left;
      y := printarea.top;
      TextOut(x, y, 'A TRichEdit print example');
      y := y + TextHeight('Ag');
      Moveto(x, y);
      Pen.Width := printresY div 72; {1 point}
      Pen.Style := psSolid;
      Pen.Color := clBlack;
      LineTo(printarea.Right, y);
      Inc(y, printresY * 5 div 72);
      {Define a rectangle for the rich edit text. The height is set to the maximum.
                        But we need to convert from device units to
                 twips, 1 twip = 1/1440 inch or 1/20 point.}
      richedit_outputarea := Rect((printarea.left + 2) * 1440 div printresX,
        y * 1440 div printresY, (printarea.right - 4) * 1440 div printresX,
        (printarea.bottom) * 1440 div printresY);
      {Tell rich edit to format its text to the printer.
                         First set up data record for message:}
      fmtRange.hDC := Handle; {printer handle}
      fmtRange.hdcTarget := Handle; {ditto}
      fmtRange.rc := richedit_outputarea;
      fmtRange.rcPage := Rect(0, 0, Printer.PageWidth * 1440 div printresX,
        Printer.PageHeight * 1440 div printresY);
      fmtRange.chrg.cpMin := 0;
      fmtRange.chrg.cpMax := richedit1.GetTextLen - 1;
      {first measure the text, to find out how high the format rectangle will be.
                        The call sets fmtrange.rc.bottom to the actual height required,
                        if all characters in the selected range will fit into a smaller rectangle}
      richedit1.Perform(EM_FORMATRANGE, 0, Longint(@fmtRange));
      {Draw a rectangle around the format rectangle}
      Pen.Width := printresY div 144; {0.5 points}
      Brush.Style := bsClear;
      Rectangle(printarea.Left, y - 2, printarea.right, fmtrange.rc.bottom * printresY div 1440 + 2);
      {Now render the text}
      richedit1.Perform(EM_FORMATRANGE, 1, Longint(@fmtRange));
      y := fmtrange.rc.bottom * printresY div 1440 + printresY * 5 div 72;
      {Free cached information}
      richedit1.Perform(EM_FORMATRANGE, 0, 0);
      TextOut(x, y, 'End of example.');
    end;
  finally
    Printer.EndDoc;
  end;
end;


This example assumes that anything will fit on one page but it is no problem to extend it to multiple pages. The richedit1.perform( EM_FORMATRANGE) call returns the index of the last character that could be fitted into the passed fmtrange.rc, + 1. So if multiple pages are required one repeats with fmtrange.chrg.cpMin set to this value, until all characters have been printed.

Note that the rich edit control strips blanks and linebreaks off the end of the text so the number of characters to output may be < richedit.gettextLen!

How to get the width and height of a MDI child form while dragging

Problem/Question/Abstract:

I need to know how to get the width and height of a MDI child window (or of an aligned component) before (!) and after scaling it with mouse dragging (e.g. dragging on the right bottom corner of the window). Which event provides these values at which time?

Answer:

There is no event directly usable for this but it can be done with a bit of API mixed in. When the user starts to drag on the border the window gets a WM_ENTERSIZEMOVE message, when the mouse goes up again it gets a WM_EXITSIZEMOVE message. So these are ideally suited to record old and new size. Note that the messages (as their name implies) are also send when the user moves the window by dragging on the caption. In that case the two sizes will simply be equal, so that is easy to test.

{ ... }
private
FOldSize, FNewSize: TRect;

procedure WMEnterSizeMove(var msg: TMessage); message WM_ENTERSIZEMOVE;
procedure WMExitSizeMove(var msg: TMessage); message WM_EXITSIZEMOVE;
{ ... }

procedure TProdBuilderMainForm.WMEnterSizeMove(var msg: TMessage);
begin
  FOldSize := BoundsRect;
end;

procedure TProdBuilderMainForm.WMExitSizeMove(var msg: TMessage);
begin
  FNewSize := BoundsRect;
  { ... do something with the sizes}
end;

How to open a CSV file and assign each of its lines to a variable

Problem/Question/Abstract:

What is the easiest way to import a comma delimited text file and assign the different elements of a line of data in that file to variables?

Answer:

function GetNextField(var Line: string; Sep: Char = '|'): string;
{Extracts the first field from Line, delimited by Sep, using the
pipe character as the default delimeter}
var
  SepPos: Integer;
begin
  {Finds the position of the first occurrence of Sep in Line}
  SepPos := Pos(Sep, Line);
  {If found...}
  if SepPos > 0 then
  begin
    {There are fields; copy the first to Result}
    Result := Copy(Line, 1, SepPos - 1);
    {Delete first field from Line, including the delimeter}
    Delete(Line, 1, SepPos);
  end
  else
  begin
    {No more fields; copy entire Line to Result}
    Result := Line;
    {Return a null Line}
    Line := '';
  end;
end;

This function can be used with TextFiles, FileStreams, MemoryStreams, StringLists, arrays of strings, etc. I will give you a very basic example of how I write and then read back text files. Here is a writer:

procedure WriteToFile;
var
  Line: string;
  TempFile: TextFile;
begin
  {Initialize the file}
  AssignFile(TempFile, 'Some\Path\Here');
  {Open the file for output}
  Rewrite(TempFile);
  try
    {Scan source table until EOF}
    MyTable.First;
    while not MyTable.EOF do
    begin
      {Build the line}
      Line := MyTableAINTEGERFIELD.AsString + '|';
      Line := Line + MyTableAFLOATFIELD.AsString + '|';
      Line := Line + MyTableASTRINGFIELD.AsString + '|';
      {Write the line}
      Writeln(TempFile, Line);
      {Move to next record}
      MyTable.Next;
    end;
  finally
    {Close the file}
    CloseFile(TempFile);
  end;
end;

And here is a reader:

procedure ReadFromFile;
var
  AInteger: Integer;
  AFloat: Extended;
  AString, Line: string;
  TempFile: TextFile;
begin
  {Initialize the file}
  AssignFile(TempFile, 'Some\Path\Here');
  {Open the file for input}
  Reset(TempFile);
  try
    {Read lines until EOF}
    while not Eof(TempFile) do
    begin
      {Read a line}
      Readln(TempFile, Line);
      {Assign fields to variables}
      AInteger := StrToInt(GetNextField(Line));
      AFloat := StrToFloat(GetNextField(Line));
      AString := GetNextField(Line);
    end;
  finally
    {Close the file}
    CloseFile(ArqTexto);
  end;
end;

These are only basic examples. You must fine tune the error handling to your needs. And, of course, the examples assume your table is allready open and you know in advance how many fields there are in a line.

How to open the printer properties window

Problem/Question/Abstract:

Is there any API call that opens the printer properties window? You can open it clicking the right mouse button in a printer icon and choosing properties from the context menu.

Answer:

uses
  WinSpool;

procedure TForm1.Button2Click(Sender: TObject);
var
  hPrinter: THandle;
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  {can use other index than default or omit this statement if printer
                already selected}
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if WinSpool.OpenPrinter(@Device, hPrinter, nil) then
  try
    PrinterProperties(Handle, hPrinter);
  finally
    WinSpool.ClosePrinter(hPrinter);
  end;
end;

InterBase: What is the SQL command to create new users?

Problem/Question/Abstract:

InterBase: What is the SQL command to create new users?

Answer:

There is no SQL command to create new users in InterBase.

The only way to create users is with the Server Manager:

(Tasks | User Security).

Catch the TPageControl.HotTrack event

Problem/Question/Abstract:

When the HotTrack property of a TPageControl is True the tabsheet captions light blue for example when the mouse hovers over them. How can I display the TabSheets hint when this event occurs (the TabSheet hint should be displayed only when the mouse hovers over the TabSheet caption)?

Answer:

Use the pagecontrol's OnMouseMove event:

{tabindex may be <> pageindex if some pages have tabvisible = false!}

function FindPageforTabIndex(pagecontrol: TPageControl; tabindex: Integer): TTabSheet;
var
  i: Integer;
begin
  Assert(Assigned(pagecontrol));
  Assert((tabindex >= 0) and (tabindex < pagecontrol.pagecount));
  Result := nil;
  for i := 0 to pagecontrol.pagecount - 1 do
    if pagecontrol.pages[i].tabVisible then
    begin
      Dec(tabindex);
      if tabindex < 0 then
      begin
        result := pagecontrol.pages[i];
        break;
      end;
    end;
end;

function HintForTab(pc: TPageControl; tabindex: Integer): string;
var
  tabsheet: TTabsheet;
begin
  tabsheet := FindPageforTabIndex(pc, tabindex);
  if assigned(tabsheet) then
    result := tabsheet.hint
  else
    result := '';
end;

procedure TForm1.PageControl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  tabindex: Integer;
  pc: TPageControl;
  newhint: string;
begin
  pc := Sender as TPageControl;
  tabindex := pc.IndexOfTabAt(X, Y);
  if tabindex >= 0 then
  begin
    newhint := HintForTab(pc, tabindex);
    if newhint <> pc.Hint then
    begin
      pc.Hint := newhint;
      application.CancelHint;
    end;
  end
  else
    pc.Hint := '';
end;

{Attach this to every tabsheets OnMouseMove event}

procedure TForm1.TabSheetMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
begin
  pagecontrol1.Hint := '';
end;

How to enable / disable single items in a TRadioGroup

Problem/Question/Abstract:

How can I set single Items.Strings in RadioGroups to Enabled := True or Enabled := False ?

Answer:

Solve 1:

TControl(RadioGroup1.Components[0]).Enabled := false;
TControl(RadioGroup1.Components[1]).Enabled := true;


Solve 2:

This function allows you to modify TRadioButtons in a given RadioGroup. Of course you can modify this to search not for a caption but for an index:

function ButtonOfGroup(rg: TRadioGroup; SearchCaption: string): TRadioButton;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to rg.ComponentCount - 1 do
    if (rg.Components[i] is TRadioButton) and
      (CompareStr(TRadioButton(rg.Components[i]).Caption, SearchCaption) = 0) then
    begin
      Result := TRadioButton(rg.Components[i]);
      Break;
    end;
end;

How to create a modal form that does not stop the execution of the program

Problem/Question/Abstract:

I would like to create a form in my program that is a please wait type of form. I need the form to have the same behaviour as a modal form, but not to stop the execution of the program.

Answer:

So use Show to show the dialog and disable all other forms in your application using the same function a modal dialog uses:

function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
procedure EnableTaskWindows(WindowList: Pointer);

Both are exported by the forms unit but are not documented. You use them like this:

var
  p: Pointer;

  waitform.show;
  application.processmessages; {needed to get form to paint}
  p := DisableTaskWindows(waitform.handle);
try
  { ... do stuff here }
finally
  EnableTaskWindows(p);
  waitform.close;
end;

How to fix the incorrect painting of an ActiveX control, which occurs when a web page is scrolled

Problem/Question/Abstract:

How to fix the incorrect painting of an ActiveX control, which occurs when a web page is scrolled

Answer:

In Delphi 4, when an ActiveForm is larger than the browser window the control is on top of IE's scroll bars. In Delphi 5 they changed the code to fix this but didn't get it quite right resulting in the painting problem when scrolling. You need to edit the Delphi 5 AxCtrls unit as follows:


function TActiveXControl.SetObjectRects(const rcPosRect: TRect;
  const rcClipRect: TRect): HResult;
var
  WinRect: TRect;
begin
  try
    IntersectRect(WinRect, rcPosRect, rcClipRect);
    {BEGIN FIX}
    WinRect := Bounds(rcPosRect.left, rcPosRect.Top, WinRect.Right - WinRect.Left +
      rcClipRect.Left - rcPosRect.Left, WinRect.Bottom - WinRect.Top +
      rcClipRect.Top - rcPosRect.Top);
    {END FIX}
    FWinControl.BoundsRect := WinRect;
    Result := S_OK;
  except
    Result := HandleException;
  end;
end;

Reading Unix ASCII files

Problem/Question/Abstract:

Reading Unix ASCII files

Answer:

Do you need to read ASCII files that originate from a UNIX system? While DOS/ Windows environments separate lines with a #10#13 combination (^J^M), in UNIX systems only a #10 is inserted.

The regular Readln() does not recognize these line breaks.

A quick-and-dirty solution is loading the file into a TStringList. The TStringList.LoadFromFile() method will break up the lines - see below:


with TStringlist.Create do
begin
  LoadFromFile(myfile);
  SaveToFile(myfile);
end;

Read and write I/O ports

Problem/Question/Abstract:

Read and write I/O ports

Answer:

In Borland Pascal and Delphi 1, there is a predefined pseudo variable Port.

In the 32bit versions of Delphi you need 2 lines of assembler code..


function InPort(PortAddr: word): byte;
{$IFDEF WIN32}
assembler; stdcall;
asm
  mov dx,PortAddr
  in al,dx
end;
{$ELSE}
begin
  Result := Port[PortAddr];
end;
{$ENDIF}

Minimize an application when modal forms are present (2)

Problem/Question/Abstract:

My application is a non-MDI application. We use form.showmodal to call our application forms because we do not want more than one window at a time to be open. Problem: When our users minimize a window opened with showmodal, instead of minimizing the application, the showmodal window is minimized on the desktop. We need to restrict multiple windows from being open simultaneously in this application.

Answer:

Have a look at this unit, this form will do what you want. When minimizing the modal form it will minimize the app, and when restoring from the taskbar it will restore the app and bring the modal window back to front.

unit testunit;

interface

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

type
  TFormTest = class(TForm)
  private
    { Private declarations }
    OldRestore: TNotifyEvent;
    procedure MyMinimize(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
    procedure DoRestore(Sender: TObject);
  public
    { Public declarations }
  end;

implementation

{$R *.DFM}

procedure TFormTest.MyMinimize(var msg: TWMSysCommand);
begin
  if (msg.cmdtype and $FFF0) = SC_MINIMIZE then
  begin
    { the following line only for D5, not for D3, due to a bug(?) in forms.pas }
    EnableWindow(Application.handle, true);
    Application.Minimize;
    OldRestore := Application.OnRestore;
    Application.OnRestore := DoRestore;
    msg.Result := 0;
  end
  else
    inherited;
end;

procedure TFormTest.DoRestore(Sender: TObject);
begin
  Application.OnRestore := OldRestore;
  SetForegroundWindow(Handle);
end;

end.

Emulating a console on TForms

Problem/Question/Abstract:

Implementing a console within a windows application without resorting to an external console application.

Answer:

Consoles are usefull for giving a user access to an application's more complex features without cluttering the interface. If you've ever coded a windowed console, you realise the "messiness" of the code involved. This class allows you to forget about all input/output routines with a few lines of code. The console supports most of the input/output routines available in console (dos) applications such as WriteLn, ReadLn, ReadKey, GotoXY and many, many more.

Using it is simple, Create a TConsole variable and pass it the form on witch you want to display the console. The console's default colors will be the same as the form's color and font.color.

Simply place a "with Console do begin end;" block and put all your console application code in it. I've placed an example with a string parser at the end of the article.

There are also some great features:

cutomizable width/height(in characters), borders
easily load and copy displays with CopyContext and SetContext
user can copy text by dragging the mouse over it like mIRC
user can paste into a read or readln input with CTRL+V
form's properties are adjusted on Create and restored on Free
form's event handler are still processed

and there are some quirks:

you cannot create a TConsole on it's form's OnCreate event
if the form has visible components they will hide the console
you cannot close the form while a read/readln is in progress
read/readln only allow up to 250 chars to avoid glitches
extended characters are not supported for input
text copying with the mouse provides no visual feedback


NOTES

GotoXY,GotoEndOfLine,GetX,GetY,GetLastLine,GetChar,GetText(y:byte), and ClearLn all refer to x,y coordinates starting at position 1,1 (like in console applications)
TConsole has not been tested with other fonts. If you want to tinker with different fonts you should set all properties of Canvas.Font (in the Create procedure) and constants CONSOLE_FONT_HEIGHT, CONSOLE_FONT_WIDTH accordingly.
I was unable to code a suitable visual feedback such as highlighting for the auto-text-copying feature. The main problem is the TForm.OnMouseMove event is only called once. Running a loop through the OnMouseDown even did not work either. I could have implemented the loop in a seperate thread but that seems like overkill. Besides, I want all TConsole functions suspended until the mouse is released so the user isn't fumbled by the application changing the displayed text. If anyone knows how mIRC did it, please email me and I'll add it in.

Here is unit Console.pas
(please forgive the broken lines)

unit Console;

interface
uses Forms, Graphics, SysUtils, ExtCtrls, Classes, Controls, ClipBrd;

const
  CONSOLE_WIDTH = 70;
  CONSOLE_HEIGHT = 25;
  CONSOLE_CARET_SPEED = 500;
  CONSOLE_OFFSET_X = 5;
  CONSOLE_OFFSET_Y = 5;
  CONSOLE_FONT_HEIGHT = 14;
  CONSOLE_FONT_WIDTH = 7;

type
  TConsoleContext = record
    Name: string;
    Lines: array[0..CONSOLE_HEIGHT - 1] of string[CONSOLE_WIDTH];
    PosX, PosY, CaretPosX, CaretPosY: word;
    LastKey: char;
    ShiftKeys: TShiftState;
    KeyPressed: boolean;
    ShowCaret: boolean;
  end;
  PConsoleContext = ^TConsoleContext;

  TConsole = class
    constructor Create(AForm: TForm);
    destructor Destroy; override;
  private
    Context: PConsoleContext;
    Caret: TTimer;
    Canvas: TCanvas;
    Form: TForm;
    Background, Forground: TColor;
    StartDragX, StartDragY: word;
    PreviousOnPaint: TNotifyEvent;
    PreviousOnKeyPress: TKeyPressEvent;
    PreviousOnMouseDown, PreviousOnMouseUp: TMouseEvent;
    PreviousWidth, PreviousHeight: word;
    procedure PaintLine(y: byte);
    procedure Refresh(Sender: TObject);
    procedure EraseCaret;
    procedure PaintCaret;
    procedure ToggleCaret(Sender: TObject);
    procedure KeyPress(Sender: TObject; var Key: char);
    procedure OnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
      x, y: Integer);
    procedure OnMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; x,
      y: Integer);
  public
    procedure CopyContext(var AContext: TConsoleContext);
    procedure SetContext(var AContext: TConsoleContext);
    procedure Update;
    procedure SetColors(FgColor, BgColor: TColor);
    procedure GotoXY(x, y: byte);
    procedure GotoEndOfLine(y: byte);
    function GetX: byte;
    function GetY: byte;
    function GetLastLine: byte;
    function GetChar(x, y: byte): char;
    function GetText(y: byte): string;
    procedure Clear;
    procedure ClearLn(y: byte);
    procedure LineFeed;
    procedure Write(Str: string);
    procedure WriteLn(Str: string);
    function ReadKey: char;
    function ReadLength(Len: byte): string;
    function Read: string;
    function ReadLn: string;
    function ReadLnLength(Len: byte): string;
  end;

implementation

constructor TConsole.Create(AForm: TForm);
begin
  Form := AForm;
  Canvas := Form.Canvas;
  Canvas.Font.Name := 'Courier New';
  Canvas.Font.Size := 8;
  Canvas.Font.Height := -11;
  Canvas.Brush.Color := Form.Color;
  Canvas.Font.Color := Form.Font.Color;

  Background := Form.Color;
  Forground := Form.Font.Color;
  PreviousOnPaint := Form.OnPaint;
  PreviousOnKeyPress := Form.OnKeyPress;
  PreviousOnMouseDown := Form.OnMouseDown;
  PreviousOnMouseUp := Form.OnMouseUp;
  Form.OnMouseDown := OnMouseDown;
  Form.OnMouseUp := OnMouseUp;

  GetMem(Context, Sizeof(TConsoleContext));

  PreviousWidth := AForm.ClientWidth;
  PreviousHeight := AForm.ClientHeight;
  Form.ClientWidth := (CONSOLE_OFFSET_X * 2) + (CONSOLE_WIDTH * CONSOLE_FONT_WIDTH);
  Form.ClientHeight := (CONSOLE_OFFSET_Y * 2) + (CONSOLE_HEIGHT *
    CONSOLE_FONT_HEIGHT);
  Form.OnPaint := Refresh;

  Caret := TTimer.Create(nil);
  with Caret do
  begin
    Enabled := false;
    Interval := CONSOLE_CARET_SPEED;
    OnTimer := ToggleCaret;
  end;
  Context^.ShowCaret := false;

  Clear;
end;

destructor TConsole.Destroy;
begin
  Caret.Free;
  FreeMem(Context);
  Form.OnPaint := PreviousOnPaint;
  Form.OnKeyPress := PreviousOnKeyPress;
  Form.OnMouseDown := PreviousOnMouseDown;
  Form.OnMouseUp := PreviousOnMouseUp;
  Form.ClientWidth := PreviousWidth;
  Form.ClientHeight := PreviousHeight;
  inherited;
end;

procedure TConsole.PaintLine(y: byte);
begin
  Canvas.FillRect(Rect(CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y + (y *
    (CONSOLE_FONT_HEIGHT)), CONSOLE_OFFSET_X + (CONSOLE_WIDTH) * (CONSOLE_FONT_WIDTH),
    CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
  Canvas.TextOut(CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)),
    Context^.Lines[y]);
end;

procedure TConsole.Refresh(Sender: TObject);
var
  y: byte;
begin
  if (CONSOLE_OFFSET_X <> 0) and (CONSOLE_OFFSET_Y <> 0) then
  begin
    Canvas.FillRect(Rect(0, 0, Canvas.ClipRect.Right, CONSOLE_OFFSET_Y));
    Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y, CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y +
      ((CONSOLE_HEIGHT - 1) * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
    Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y + ((CONSOLE_HEIGHT - 1) *
      (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT, Canvas.ClipRect.Right,
      Canvas.ClipRect.Bottom));
    Canvas.FillRect(Rect(CONSOLE_OFFSET_X + (CONSOLE_WIDTH) * (CONSOLE_FONT_WIDTH),
      CONSOLE_OFFSET_Y, Canvas.ClipRect.Right, CONSOLE_OFFSET_Y + ((CONSOLE_HEIGHT - 1)
      * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
  end;
  with Context^ do
    for y := 0 to CONSOLE_HEIGHT - 1 do
      PaintLine(y);
  PaintCaret;
  if Assigned(PreviousOnPaint) then
    PreviousOnPaint(Sender);
end;

procedure TConsole.EraseCaret;
begin
  with Context^ do
    if Length(Lines[CaretPosY]) > CaretPosX then
      Canvas.TextOut(CONSOLE_OFFSET_X + (CaretPosX * (CONSOLE_FONT_WIDTH)),
        CONSOLE_OFFSET_Y + (CaretPosY * (CONSOLE_FONT_HEIGHT)), Lines[CaretPosY,
        CaretPosX + 1])
    else
      Canvas.TextOut(CONSOLE_OFFSET_X + (CaretPosX * (CONSOLE_FONT_WIDTH)),
        CONSOLE_OFFSET_Y + (CaretPosY * (CONSOLE_FONT_HEIGHT)), ' ');
end;

procedure TConsole.PaintCaret;
begin
  with Context^ do
  begin
    if Caret.Enabled = false then
      Exit;
    if ShowCaret = true then
    begin
      if (CaretPosX <> PosX) or (CaretPosY <> PosY) then
        EraseCaret;
      Canvas.Brush.Color := Forground;
      Canvas.FillRect(Rect(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
        CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)) + 10, CONSOLE_OFFSET_X + (PosX
        * (CONSOLE_FONT_WIDTH)) + CONSOLE_FONT_WIDTH, CONSOLE_OFFSET_Y + (PosY *
        (CONSOLE_FONT_HEIGHT)) + 13));
      Canvas.Brush.Color := Background;
      CaretPosX := PosX;
      CaretPosY := PosY;
    end
    else
      EraseCaret;
  end;
end;

procedure TConsole.ToggleCaret(Sender: TObject);
begin
  with Context^ do
    ShowCaret := not ShowCaret;
  PaintCaret;
end;

procedure TConsole.KeyPress(Sender: TObject; var Key: char);
begin
  with Context^ do
  begin
    LastKey := Key;
    KeyPressed := true;
  end;
  if Assigned(PreviousOnKeyPress) then
    PreviousOnKeyPress(Form, Key);
end;

procedure TConsole.OnMouseDown(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; x, y: Integer);
begin
  if Button <> mbLeft then
    Exit;
  StartDragX := (X - CONSOLE_OFFSET_X) div CONSOLE_FONT_WIDTH;
  StartDragY := (Y - CONSOLE_OFFSET_Y) div CONSOLE_FONT_HEIGHT;
  if StartDragX >= CONSOLE_WIDTH then
    StartDragX := CONSOLE_WIDTH - 1;
  if StartDragY >= CONSOLE_HEIGHT then
    StartDragY := CONSOLE_HEIGHT - 1;
  if Assigned(PreviousOnMouseDown) then
    PreviousOnMouseDown(Sender, Button, Shift, x, y);
end;

procedure TConsole.OnMouseUp(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; x, y: Integer);
var
  EndDragX, EndDragY, Temp: word;
  Str: string;
begin
  if Button <> mbLeft then
    Exit;
  EndDragX := (x - CONSOLE_OFFSET_X) div CONSOLE_FONT_WIDTH;
  EndDragY := (y - CONSOLE_OFFSET_Y) div CONSOLE_FONT_HEIGHT;
  if EndDragX >= CONSOLE_WIDTH then
    EndDragX := CONSOLE_WIDTH - 1;
  if EndDragY >= CONSOLE_HEIGHT then
    EndDragY := CONSOLE_HEIGHT - 1;
  if (StartDragX = EndDragX) and (StartDragY = EndDragY) then
    Exit;
  if EndDragY < StartDragY then
  begin
    Temp := EndDragX;
    EndDragX := StartDragX;
    StartDragX := Temp;
    Temp := EndDragY;
    EndDragY := StartDragY;
    StartDragY := Temp;
  end
  else if (EndDragY = StartDragY) and (EndDragX < StartDragX) then
  begin
    Temp := EndDragX;
    EndDragX := StartDragX;
    StartDragX := Temp;
  end;
  Inc(StartDragX, 1);
  Inc(EndDragX, 1);

  with Context^ do
  begin
    if StartDragY = EndDragY then
      Str := Copy(Lines[StartDragY], StartDragX, EndDragX - StartDragX + 1)
    else
    begin
      Str := Copy(Lines[StartDragY], StartDragX, CONSOLE_WIDTH - StartDragX);
      if EndDragY - StartDragY > 1 then
        for y := StartDragY + 1 to EndDragY - 1 do
          Str := Str + Lines[y];
      Str := Str + Copy(Lines[EndDragY], 1, EndDragX);
    end;
  end;
  ClipBoard.SetTextBuf(PChar(Str));
  if Assigned(PreviousOnMouseUp) then
    PreviousOnMouseUp(Sender, Button, Shift, x, y);
end;

procedure TConsole.CopyContext(var AContext: TConsoleContext);
begin
  Move(Context^, AContext, Sizeof(TConsoleContext));
end;

procedure TConsole.SetContext(var AContext: TConsoleContext);
begin
  Move(AContext, Context^, Sizeof(TConsoleContext));
  Update;
end;

procedure TConsole.Update;
begin
  Refresh(Form);
end;

procedure TConsole.SetColors(FgColor, BgColor: TColor);
begin
  Forground := FgColor;
  Background := BgColor;
  Canvas.Font.Color := FgColor;
  Canvas.Brush.Color := BgColor;
  Canvas.FillRect(Canvas.ClipRect);
  Update;
end;

procedure TConsole.GotoXY(x, y: byte);
begin
  with Context^ do
  begin
    if x > CONSOLE_WIDTH then
      x := CONSOLE_WIDTH
    else if x = 0 then
      Inc(x, 1);
    if y > CONSOLE_HEIGHT then
      y := CONSOLE_HEIGHT
    else if y = 0 then
      Inc(y, 1);
    PosX := x - 1;
    PosY := y - 1;
  end;
end;

procedure TConsole.GotoEndOfLine(y: byte);
begin
  if y > CONSOLE_HEIGHT then
    y := CONSOLE_HEIGHT
  else if y = 0 then
    Inc(y, 1);
  with Context^ do
  begin
    PosY := y - 1;
    PosX := Length(Lines[PosY]);
  end;
end;

function TConsole.GetX: byte;
begin
  Result := Context^.PosX + 1;
end;

function TConsole.GetY: byte;
begin
  Result := Context^.PosY + 1;
end;

function TConsole.GetLastLine: byte;
begin
  Result := CONSOLE_HEIGHT;
end;

function TConsole.GetChar(x, y: byte): char;
begin
  with Context^ do
  begin
    if (x > CONSOLE_WIDTH) or (x = 0) or (y > CONSOLE_HEIGHT) or (y = 0) then
      Result := #0
    else
    begin
      Dec(y, 1);
      if x > Length(Lines[y]) then
        Result := ' '
      else
        Result := Lines[y - 1, x];
    end;
  end;
end;

function TConsole.GetText(y: byte): string;
begin
  if (y > CONSOLE_HEIGHT) or (y = 0) then
    Result := ''
  else
    Result := Context^.Lines[y - 1];
end;

procedure TConsole.Clear;
var
  y: byte;
begin
  with Context^ do
  begin
    for y := 0 to CONSOLE_HEIGHT - 1 do
      Lines[y] := '';
    PosX := 0;
    PosY := 0;
    KeyPressed := false;
    LastKey := #0;
    Canvas.FillRect(Rect(0, 0, (CONSOLE_OFFSET_X * 2) + (CONSOLE_FONT_WIDTH *
      CONSOLE_WIDTH), (CONSOLE_OFFSET_Y * 2) + (CONSOLE_FONT_HEIGHT * CONSOLE_HEIGHT)));
  end;
end;

procedure TConsole.ClearLn(y: byte);
begin
  if y > CONSOLE_HEIGHT then
    y := CONSOLE_HEIGHT
  else if y = 0 then
    Inc(y, 1);
  Dec(y, 1);
  with Context^ do
  begin
    Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)),
      (CONSOLE_OFFSET_X * 2) + (CONSOLE_WIDTH - 1) * (CONSOLE_FONT_WIDTH + 1),
      (CONSOLE_OFFSET_Y * 2) + (y * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
    Lines[y] := '';
    PosX := 0;
    PosY := y;
  end;
end;

procedure TConsole.LineFeed;
var
  y: byte;
begin
  with Context^ do
  begin
    PosX := 0;
    if PosY = CONSOLE_HEIGHT - 1 then
    begin
      for y := 0 to CONSOLE_HEIGHT - 2 do
        Lines[y] := Lines[y + 1];
      Lines[CONSOLE_HEIGHT - 1] := '';
      Update;
    end
    else
      Inc(PosY, 1);
  end;
end;

procedure TConsole.Write(Str: string);
var
  StrLen, SubPos, SubLen, y, StartPosY: word;
begin
  with Context^ do
  begin
    StartPosY := PosY;
    StrLen := Length(Str);
    SubPos := 1;
    if StrLen + PosX < CONSOLE_WIDTH then
    begin
      SetLength(Lines[PosY], PosX + StrLen);
      Move(Str[1], Lines[PosY, PosX + 1], StrLen);
      Inc(PosX, StrLen);
    end
    else if StrLen + PosX = CONSOLE_WIDTH then
    begin
      SetLength(Lines[PosY], CONSOLE_WIDTH);
      Move(Str[1], Lines[PosY, PosX + 1], StrLen);
      LineFeed;
    end
    else
    begin
      SubLen := CONSOLE_WIDTH - Length(Lines[PosY]);
      repeat
        if PosX + 1 + SubLen > Length(Lines[PosY]) then
          SetLength(Lines[PosY], PosX + SubLen);
        Move(Str[SubPos], Lines[PosY, PosX + 1], SubLen);
        Inc(SubPos, SubLen);
        if SubPos < StrLen then
        begin
          LineFeed;
          if (StartPosY <> 0) and (PosY = CONSOLE_HEIGHT - 1) then
            Dec(StartPosY, 1);
        end
        else
          Inc(PosX, SubLen);
        SubLen := StrLen - SubPos + 1;
        if SubLen > CONSOLE_WIDTH then
          SubLen := CONSOLE_WIDTH;
      until ((SubLen + Length(Lines[PosY]) <= CONSOLE_WIDTH) and (SubPos >= StrLen))
        or (SubLen = 0);
      if SubPos < StrLen then
      begin
        SetLength(Lines[PosY], PosX + SubLen);
        Move(Str[SubPos], Lines[PosY, PosX + 1], SubLen);
        Inc(PosX, SubLen);
      end;
    end;
    for y := StartPosY to PosY do
      PaintLine(y);
  end;
end;

procedure TConsole.WriteLn(Str: string);
begin
  Write(Str);
  LineFeed;
end;

function TConsole.ReadKey: char;
begin
  with Context^ do
  begin
    KeyPressed := false;
    repeat
      Application.HandleMessage;
    until KeyPressed = true;
    Result := LastKey;
  end;
end;

function TConsole.ReadLength(Len: byte): string;
var
  StartPosX, StartPosY: byte;
  ClipBoardStr: array[0..255] of char;
  Key: char;
begin
  with Context^ do
  begin
    Form.OnKeyPress := KeyPress;
    Caret.Enabled := true;
    StartPosX := PosX;
    StartPosY := PosY;
    Result := '';
    repeat
      Key := ReadKey;
      if Key = #8 then
      begin
        if PosY > StartPosY then
        begin
          if PosX > 0 then
          begin
            Dec(PosX, 1);
            SetLength(Lines[PosY], Length(Lines[PosY]) - 1);
            SetLength(Result, Length(Result) - 1);
            Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
              CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
          end
          else
          begin
            Lines[PosY] := '';
            Dec(Posy, 1);
            PosX := CONSOLE_WIDTH - 1;
            SetLength(Lines[PosY], CONSOLE_WIDTH - 1);
            SetLength(Result, Length(Result) - 1);
            Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
              CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
          end;
        end
        else if PosX > StartPosX then
        begin
          Dec(PosX, 1);
          SetLength(Lines[PosY], Length(Lines[PosY]) - 1);
          SetLength(Result, Length(Result) - 1);
          Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
            CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
        end;
      end
      else if Key = #22 then
      begin
        ClipBoard.GetTextBuf(@ClipBoardStr, Len - Length(Result));
        Result := Result + StrPas(ClipBoardStr);
        Write(StrPas(ClipBoardStr));
      end
      else if (Key <> #13) and (Length(Result) <= Len) and (Key > #31) and (Key < #127)
        then
      begin
        Result := Result + Key;
        Lines[PosY] := Lines[PosY] + Key;
        Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
          CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), Key);
        Inc(PosX, 1);
        if PosX = CONSOLE_WIDTH then
        begin
          if StartPosY <> 0 then
            Dec(StartPosY, 1)
          else
            StartPosX := 0;
          LineFeed;
          Refresh(Canvas);
        end;
      end;
      PaintCaret;
    until Key = #13;
    ShowCaret := false;
    Caret.Enabled := false;
    Form.OnKeyPress := PreviousOnKeyPress;
  end;
end;

function TConsole.Read: string;
begin
  Result := ReadLength(250);
end;

function TConsole.ReadLn: string;
begin
  Result := ReadLength(250);
  LineFeed;
end;

function TConsole.ReadLnLength(Len: byte): string;
begin
  if Len > 250 then
    Len := 250;
  Result := ReadLength(Len);
  LineFeed;
end;

end. //UNIT CONSOLE.PAS FINISHED

//*************************************************************************
//*************************** EXAMPLE ***************************************
//*************************************************************************

//Call: AConsole:=TConsole.Create(Form1); before calling TForm1.CommandPrompt;

procedure TForm1.CommandPrompt;
var
  Command: string;
  Parameters: array[0..9] of string;
  ParameterCount: byte;

  procedure ParseLine(c: string);
  var
    i: byte;
    Param: byte;
    Brackets: boolean;
  begin
    try
      Brackets := false;
      Param := 0;
      for i := 0 to 9 do
        Parameters[i] := '';
      for i := 1 to Length(c) do
      begin
        if c[i] = '"' then
        begin
          Brackets := not Brackets;
          if Brackets = false then
            Inc(Param, 1);
        end
        else if Brackets = true then
          Parameters[Param] := Parameters[Param] + c[i]
        else if (c[i] = ' ') and (c[i - 1] <> ' ') then
        begin
          Inc(Param, 1);
          if Param = 10 then
            Exit;
        end
        else
          Parameters[Param] := Parameters[Param] + c[i];
      end;
    finally
      ParameterCount := Param + 1;
      Parameters[0] := LowerCase(Parameters[0]);
    end;
  end;

  procedure CommandRun;
  begin
    with AConsole do
    begin
      if ParameterCount < 2 then
      begin
        Writeln('Use: run <path>');
        Writeln('   ex: run "c:\program files\myprogram.exe"');
        Writeln('');
        Exit;
      end;
      case WinExec(PChar(Parameters[1]), SW_SHOWNORMAL) of
        0: Writeln('The system is out of memory or resources.');
        ERROR_BAD_FORMAT:
          Writeln('The .EXE file is invalid (non-Win32 .EXE or error in .EXE image).');
        ERROR_FILE_NOT_FOUND: Writeln('The specified file was not found.');
        ERROR_PATH_NOT_FOUND: Writeln('The specified path was not found.');
      end;
    end;
  end;

  procedure CommandOpen;
  begin
    with AConsole do
    begin
      if ParameterCount < 2 then
      begin
        Writeln('Use: open <path>');
        Writeln('   ex: open "c:\my documents\finance.doc"');
        Writeln('');
        Exit;
      end;
      case ShellExecute(Application.Handle, 'open', PChar(Parameters[1]), nil, nil,
        SW_NORMAL) of
        0: Writeln('The operating system is out of memory or resources.');
        ERROR_FILE_NOT_FOUND: Writeln('The specified file was not found.');
        ERROR_PATH_NOT_FOUND: Writeln('The specified path was not found.');
        ERROR_BAD_FORMAT:
          Writeln('The .EXE file is invalid (non-Win32 .EXE or error in .EXE image).');
        SE_ERR_ACCESSDENIED:
          Writeln('The operating system denied access to the specified file.');
        SE_ERR_ASSOCINCOMPLETE:
          Writeln('The filename association is incomplete or invalid.');
        SE_ERR_DDEBUSY:
          Writeln('The DDE transaction could not be completed because other DDE transactions were being processed.');
        SE_ERR_DDEFAIL: Writeln('The DDE transaction failed.');
        SE_ERR_DDETIMEOUT:
          Writeln('The DDE transaction could not be completed because the request timed out.');
        SE_ERR_DLLNOTFOUND:
          Writeln('The specified dynamic-link library was not found.');
        SE_ERR_NOASSOC:
          Writeln('There is no application associated with the given filename extension.');
        SE_ERR_OOM: Writeln('There was not enough memory to complete the operation.');
        SE_ERR_SHARE: Writeln('A sharing violation occurred.');
      end;
    end;
  end;

  procedure CommandHelp;
  begin
    with AConsole do
    begin
      Writeln('The following commands are available:');
      Writeln('   run <path>     (starts an application)');
      Writeln('   open <path>    (opens a file with the associated application)');
      Writeln('   help           (displays this message)');
      Writeln('   exit           (ends the console session)');
      Writeln('');
    end;
  end;

begin
  with AConsole do
  begin
    GotoXY(0, GetLastLine);
    WriteLn('Welcome to DrMungkee''s demo console.');
    WriteLn('   Type ''help'' for a list of available commands.');
    repeat
      Write('>');
      Command := ReadLn;
      ParseLine(Command);
      if Parameters[0] = 'clear' then
        Clear
      else if Parameters[0] = 'run' then
        CommandRun
      else if Parameters[0] = 'open' then
        CommandOpen
      else if Parameters[0] = 'help' then
        CommandHelp
      else if Parameters[0] <> 'exit' then
      begin
        Writeln('Unknow Command (' + Parameters[0] + ')');
      end;
    until Parameters[0] = 'exit';
    AConsole.Free;
  end;
end;

How to set the port for a specific printer

Problem/Question/Abstract:

I want to change the default printer and its settings (port) under Win 9x so that it affects all other applications for automated document printing to files (not from my application, from others like CorelDraw and Word...). I tried to this by changing the registry entries for the printers, but these changes only take effect after rebooting the system. Is there an API function that causes windows to update the printer settings from the registry? Or any other API function that directly affects the system wide printer settings?

Answer:

Setting a port for a specific printer:

uses
  WinSpool;

{ Function SetPrinterToPort
  Parameters :
    hPrinter: handle of printer to change, obtained from OpenPrinter
    port: port name to use, e.g. LPT1:, COM1:, FILE:
  Returns:
    The name of the previous port the printer was attached to.
  Description:
    Changes the port a printer is attached to using Win32 API functions.
                The changes made are NOT local to this process, they will affect all
                other processes that try to use this printer! It is recommended to set the
                port back to the old port returned by this function after
                the end of the print job.
  Error Conditions:
   Will raise EWin32Error exceptions if SetPrinter or GetPrinter fail.
  Created:
    21.10.99 by P. Below}

function SetPrinterToPort(hPrinter: THandle; const port: string): string;
var
  pInfo: PPrinterInfo2;
  bytesNeeded: DWORD;
begin
  {Figure out how much memory we need for the data buffer. Note that GetPrinter is
  supposed to fail with a specific error code here. The amount of memory will
        be larger than Sizeof(TPrinterInfo2) since variable amounts of data are appended
        to the record}
  SetLastError(NO_ERROR);
  GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
  if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
    RaiseLastWin32Error;
  pInfo := AllocMem(bytesNeeded);
  try
    if not GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded) then
      RaiseLastWin32Error;
    with pInfo^ do
    begin
      Result := pPortname;
      pPortname := @port[1];
    end;
    if not SetPrinter(hPrinter, 2, pInfo, 0) then
      RaiseLastWin32Error;
  finally
    FreeMem(pInfo);
  end;
end;

function GetCurrentPrinterHandle: THandle;
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, nil) then
    RaiseLastWin32Error;
end;

Optimization of work with standard TTreeView/TListView components

Problem/Question/Abstract:

Have a bad performance with standard TTreeView/TListView? Read this tip and implement the hints...

Answer:

If you uses the TTreeView and/or TListView from Win32 page of default component palette, then you must know that if you have the large amount nodes, you have a very bad performance...

Of course, at same moment you'll try to find a some other third-party component that allow to work with your very large data but I want to give you the few hints which allows to increase a performance without any third-party components. Only using of optimized code.

Tip1:

if you need add a lot of nodes in same time (for example, after button click to load the 10000 nodes in tree from some source) then you must call:

yourTreeView.Items.BeginUpdate;

yourTreeView.Items.EndUpdate;

This constuction will disable a repainting when you append the nodes - it's save a lot of time!

Tip2:

if you uses the some navigation by nodes, you must use the GetFirst and GetNext methods instead Items[i] using!

For example:

var
  node: TTreeNode;
begin
  node := yourTreeView.Items.GetFirstNode;
  repeat
    node := Result.GetNext;
  until node = nil;
end;

It's save a lot of time too! The GetFirstNode/GetNext is faster than standard

for i := 0 to yourTreeView.Items.Count - 1 do
begin
  node := yourTreeView.Items[i];
end;

Tip3:

Also, when adding lots of items, you could do

MyObj.AllocBy := 10000;

This will cause fewer allocations as it allocates more items each time.

For example, in own warehouse system I have a treeview with 5000 nodes which I load from Oracle resultset. After applying of these tips, the time of execution of procedure with append was decreased from 4-5 minutes to 15-20
seconds! Trust me :-)

I don't sure but I think that it's a bad work of Borland when team developed the envelope for Win's treeview/listview. But maybe I'm wrong.

PS: of course, if you have a very-very large data with few billions of nodes or after applying of tips above all the same you have a bad performance, you must use the virtual mode of control or really select the other third-party
control. But I suggest to change the your interface logic - to navigate thru few billions of nodes in same time is very hard task for user! Not only for you :-)

How to lock a CD-ROM drive

Problem/Question/Abstract:

How can I prevent a CD from being ejected from a CD-ROM drive through code?

Answer:

The code below only works with Windows NT 4, 2000 and XP:

{NTStyle}

function CTL_Code(DeviceType, _Function, Method, Access: Integer): DWord;
begin
  Result := (DeviceType shl 16) or (Access shl 14) or (_Function shl 2) or Method;
end;

type
  TPreventMediaRemoval = packed record
    PreventMediaRemoval: Boolean;
  end;

const
  METHOD_BUFFERED = 0;
  FILE_READ_ACCESS = 1;
  IOCTL_STORAGE_BASE = $2D;
  IOCTL_STORAGE_MEDIA_REMOVAL_FUNCTION = $201;

procedure NTStyleTrayLock(Drive: Char; Lock: Boolean);
var
  Device: THandle;
  IOCTL_STORAGE_MEDIA_REMOVAL: DWord;
  BytesReturned: Cardinal;
  InBuffer: TPreventMediaRemoval;
begin
  IOCTL_STORAGE_MEDIA_REMOVAL := CTL_Code(IOCTL_STORAGE_BASE,
    IOCTL_STORAGE_MEDIA_REMOVAL_FUNCTION,
    METHOD_BUFFERED, FILE_READ_ACCESS);

  Device := CreateFile(PChar(Format('\\.\%s:', [UpCase(Drive)])), GENERIC_ALL,
    FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  if Device = INVALID_HANDLE_VALUE then
    RaiseLastWin32Error;
  try
    InBuffer.PreventMediaRemoval := Lock;
    Win32Check(DeviceIoControl(Device, IOCTL_STORAGE_MEDIA_REMOVAL, @InBuffer,
      sizeof(InBuffer), nil, 0, BytesReturned, nil));
  finally
    FileClose(Device);
  end;
end;

{UI (here: Drive W:)}

procedure TForm1.btnLockClick(Sender: TObject);
begin
  NTStyleTrayLock('W', True);
end;

procedure TForm1.btnUnLockClick(Sender: TObject);
begin
  NTStyleTrayLock('W', False);
end;