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;