Animate a form when minimizing or restoring it

Problem/Question/Abstract:

When I minimize a progam written in Delphi there's no animation on minimizing and restore. How can I enable this?

Answer:

In FormShow:

var
  RecS, RecL: TRect;
begin
  RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
  RecL := ThisForm.BoundsRect;
  DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);
  { ... }
end;

In FormHide:

var
  RecS, RecL: TRect;
begin
  HideTimer.Enabled := False;
  RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
  RecL := ThisForm.BoundsRect;
  DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecL, RecS);
end;

How to split a string when the substrings are separated by more than one space character

Problem/Question/Abstract:

I have a lot of the following lines:

02-07-01 12:05:30  XXX     AAAAAA 100 BBBBB   666666        300
3700     -555.00     4.00

The only way to separate those items in the string is if there are more than 2 spaces between the items. There can also be 3 to 5 spaces actually. If there is one space between strings - it is probably part of the bigger item as shown above: 'AAAAAA 100 BBBBB'. What would be the simplest way to split this string? I looked at delimitedText but I am not sure of if it is going to help me.

Answer:

Solve 1:

See routine below. Is this data you have in a fixed-width column format produced by another program? If so you cannot count on fields being separated by more than one space! In fact you may have cases where there is no space between the fields because a value fills the whole field width! For such files you have to use a different strategy to parse the lines.

{SplitDataString:
Dissect a string of items separated by more than one space character
Param S contains the string to split, param list takes the items obtained from S
Precondition: list <> nil

Description:
An item cannot start or end with a space but it may contain space characters flanked
by non-space characters. The routine does not support multibyte character sets as it
is implemented now.

Created 28.7.2002 by P. Below}

procedure SplitDataString(S: string; list: TStrings);
var
  startindex: Integer;

  function HasNextItem: Boolean;
  begin
    {We do not support a "Item" starting with a space!}
    while (startindex <= Length(S)) and (S[startindex] = #32) do
      Inc(startindex);
    Result := startindex <= Length(S);
  end;

  function GetNextItem: string;
  var
    endindex: Integer;
  begin
    for endindex := startindex + 1 to Length(S) do
    begin
      if S[endindex] = ' ' then
        if S[endindex + 1] = ' ' then
        begin
          {found end of a Item}
          Result := Copy(S, startindex, endindex - startindex);
          startindex := endindex + 2;
          Exit;
        end;
    end;
    {If we end here Item is the last in S}
    Result := Copy(S, startindex, maxint);
    startindex := Length(S) + 1;
  end;

begin
  Assert(Assigned(list));
  {remove whitespace from start and end of string}
  S := Trim(S);
  startindex := 1;
  while HasNextItem do
    list.Add(GetNextItem);
end;

Example of use:

procedure TForm1.Button1Click(Sender: TObject);
begin
  memo1.clear;
  SplitDataString('02-07-01 12:05:30  XXX     AAAAAA 100 BBBBB   666666        300                                            ' + '3700      -555.00     4.00', memo1.lines);
end;


Solve 2:

function SepSpacedOutStr(s: string): string;
var
  i, x: integer;
begin
  s := SysUtils.Trim(s);
  if s <> '' then
  begin
    SetLength(result, Length(s));
    x := 0;
    i := 1;
    while i <= Length(s) do
    begin
      if (s[i] <> #32) or ((i < Length(s)) and (s[i + 1] <> #32)) then
      begin
        Inc(x);
        result[x] := s[i];
      end
      else
      begin
        if (i < Length(s)) and (s[i + 1] = #32) then
        begin
          Inc(x);
          result[x] := ',';
          Inc(x);
          result[x] := #32;
          while (i < Length(s)) and (s[i + 1] = #32) do
            Inc(i);
        end;
      end;
      Inc(i);
    end;
    SetLength(result, x);
  end
  else
    result := '';
end;

Adding an item to the main menu or the tools menu

Problem/Question/Abstract:

You need to add an item into Delphi's IDE for your expert?

Answer:

Here is how I did it for TMultiLang..
If you do not want to use the tools menu, but instead create a new main menu entry, you need to replace the

menMain.FindMenuItem ()

with

menMain.InsertItem(8, '&Test', 'TestMainMenuItem', '', 0, 0, 0, [mfVisible, mfEnabled], nil);

taken from TMultiLang source code

constructor TMultiLangExpert.Create;
var
  menMain: TIMainMenuIntf;
  menToolsGallery: TIMenuItemIntf;
  menToolsMenu: TIMenuItemIntf;
begin { Create }
  inherited Create;
  menMain := ToolServices.GetMainMenu; // get the IDE's main menu
  if Assigned(menMain) then
  try
    // get the

Printing a Memo

Problem/Question/Abstract:

I have a simple editor unit with a TMemo component whose text I want to send to the printer. How can I do this?

Answer:

This is actually much easier that most people think, though you can get pretty fancy. With the procedure that I'll show you below, I will take advantage of the TMemo's Lines property, which is of type TStrings. The procedure will parse each line in the memo, and use Canvas.TextOut to print to the printer. After you see this code, you'll see how simple it is. Let's take a look at the code:

procedure PrintTStrings(Lst: TStrings);
var
  I, Line: Integer;
begin
  I := 0;
  Line := 0;
  Printer.BeginDoc;
  for I := 0 to Lst.Count - 1 do
  begin
    Printer.Canvas.TextOut(0, Line, Lst[I]);

    {Font.Height is calculated as -Font.Size * 72 / Font.PixelsPerInch which returns
     a negative number. So Abs() is applied to the Height to make it a non-negative
     value}
    Line := Line + Abs(Printer.Canvas.Font.Height);
    if (Line >= Printer.PageHeight) then
      Printer.NewPage;
  end;
  Printer.EndDoc;
end;

Basically, all we're doing is sequentially moving from the beginning of the TStrings object to the end with the for loop. At each line, we print the text using Canvas.TextOut then perform a line feed and repeat the process. If our line number is greater than the height of the page, we go to a new page. Notice that I extensively commented before the line feed. That's because feeding a line was the only tricky part of the code. When I first wrote this, I just added the Font height to the line, and thus the code would generate a smaller and smaller negative number. The net result was that I'd only print one line of the memo. Actually TextOut would output to the printer, but it essentially printed from the first line up, not down. So, after carefully reading the help file, I found that Height is the result of the calculation of a negative font size, so I used the Abs() function to make it a non-negative number.

For more complex operations, I suggest you look at the help file under Printer or TPrinter, and also study the TextOut procedure. Now, what is Printer? Well, when you make a call to Printer, it creates a global instance of TPrinter, which is Delphi's interface into the Windows print functions. With TPrinter, you can define everything which describes the page(s) to print: Page Orientation, Font (through the Canvas property), the Printer to print to, the Width and Height of the page, and many more things.

Extract the associated icon of an application

Problem/Question/Abstract:

In my program, I am displaying a set of path and file names on the screen as the user choses them using a TList box. Alongside this list box I would like to display the icon associated with each one (if available). I understand that some icons are embedded in the executable and others are associated by Windows. Can you point me in the right direction for determining what the icon is, programmatically extracting it and placing it into an image array.

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  HIcon: THandle;
  iIcon: Word;
  FilePath: array[0..MAX_PATH] of Char;
begin
  if OpenDialog1.Execute then
  begin
    Label1.Caption := OpenDialog1.FileName;
    Label1.Repaint;
    StrPCopy(FilePath, OpenDialog1.FileName);
    HIcon := ExtractAssociatedIcon(Application.Handle, @FilePath[0], iIcon);
    if HIcon <> 0 then
      Image1.Picture.Icon.Handle := HIcon;
  end;
end;

How to check if a particular button on a TDBNavigator is enabled

Problem/Question/Abstract:

How to check if a particular button on a TDBNavigator is enabled

Answer:

type
  TDBNavCracker = class(TDBnavigator);
  { ... }

if TDBNavCracker(DBNavigator1).Buttons[nbEdit].Enabled then
  { ... }

How to copy a record from one table to another

Problem/Question/Abstract:

Assuming I have Table1 and Table2, that have identical structures (same fields), how can I transfer all of the fields in the current record to a new record in the second table? For example, I want record no. 3 in Table1 to be appended to Table2.

Answer:

Solve 1:

for I := 0 to Table1.FieldCount do
  Table2.Fields[I].AsVariant := Table1.Fields[I].AsVariant;


Solve 2:

Copies a record from a DataSet to a Table by field names. This is much safer than using the Fields property since the order of fields in the Fields array depends on the order of instantiation of the TField objects, not the order of fields in the table. This procedure assumes that the corresponding fields in the source and destination datasets have the same names.

Parameters:
Source = The source dataset
Destination = The destination table

procedure dgCopyRecordByName(Source: TDataSet; Destination: TTable);
var
  LastField, L: Integer;
begin
  Destination.Edit;
  LastField := Source.FieldCount - 1;
  for L := 0 to LastField do
  begin
    {Skip fields that do not exist in the destination table}
    if Destination.FieldDefs.IndexOf(Source.FieldDefs[L].Name) < 0 then
      Continue;
    {Skip fields that are read only in the destination dataset}
    if Destination.FieldByName(Source.FieldDefs[L].Name).ReadOnly then
      Continue;
    {Copy the field}
    Destination.FieldByName(Source.FieldDefs[L].Name).Assign
      (Source.FieldByName(Source.FieldDefs[L].Name));
  end;
end;


Solve 3:

var
  iCount: LongInt;
  sName: string;
begin
  Table2.Insert;
  for iCount := 0 to Table2.FieldCount - 1 do
  begin
    sName := Table2.Fields[iCount].FieldName;
    if (Table1.FindField(sName) <> nil) and (sName <> 'ID') then
      Table2.FieldByName(sName).Assign(Table1.FieldByName(sName));
  end;
  Table2.Post;
end;

If you work with FieldByName, there are 2 advantages: You can copy only the fields you want. In the upper example, the field "ID" would not be copied. The construction of the two tables must not the same. Only fields with the same name would be copied. If you are sure, the construction is the same

for iCount := 0 to Table2.FieldCount - 1 do
  Table2.Fields[iCount].Assign(Table1.Fields[iCount]);

also works.


Solve 4:

procedure CopyRecord(Tabelle: TTable);
var
  feldwert: Variant;
  i: Word;
begin
  with DataModule1 do
  begin
    feldwert := VarArrayCreate([0, Tabelle.FieldCount - 1], varVariant);
    for i := 0 to Tabelle.FieldCount - 1 do
      feldwert[i] := Tabelle.Fields[i].Value;
    Tabelle.Append;
    for i := 0 to Tabelle.FieldCount - 1 do
      Tabelle.Fields[i].Value := feldwert[i];
  end;
end;


Solve 5:

procedure AppendCurrent(Dataset: TDataset);
var
  aField: Variant;
  i: Integer;
begin
  {Create a variant Array}
  aField := VarArrayCreate([0, DataSet.Fieldcount - 1], VarVariant);
  {Read values into the array}
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    aField[i] := DataSet.fields[i].Value;
  end;
  DataSet.Append;
  {Put array values into new the record}
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    DataSet.fields[i].Value := aField[i];
  end;
end;


Solve 6:

The following is a chunk of code that I use to copy TTable rows. This function assumes that you are handling the insert and post calls yourself.

function CopyRow(Source, Dest: TTable): Boolean;
var
  n: Integer;
begin
  Result := False;
  for n := 0 to Source.FieldCount - 1 do
  begin
    try
      Dest.Fields[n].Assign(Source.Fields[n]);
    except
      Exit;
    end;
  end;
  Result := True;
end;

How to get the text width in pixels when a component doesn't have a canvas

Problem/Question/Abstract:

How to get the text width in pixels when a component doesn't have a canvas

Answer:

If a component doesn't have a Canvas property you can use the following function to get the text width based on the font passed.

function GetTextWidth(CanvasOwner: TForm; Text: string; TextFont: TFont): Integer;
var
  OldFont: TFont;
begin
  OldFont := TFont.Create;
  try
    OldFont.Assign(CanvasOwner.Font);
    CanvasOwner.Font.Assign(TextFont);
    Result := CanvasOwner.Canvas.TextWidth(Text);
    CanvasOwner.Font.Assign(OldFont);
  finally
    OldFont.Free;
  end;
end;

Catching ALL mouse events

Problem/Question/Abstract:

I tried to override the MouseDown() method in a subclass of TForm to get every event for a general handler.

Answer:

The Application.OnMessage event will see all mouse messages before they are delivered to the control under the mouse. You work at the API level there, however. If none of the controls needs to do special mouse processing just hook the same event to all OnMouse* events of interest.
The Sender parameter will tell you which control fired the handler.

Start with the example below:

  
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
    procedure MyMouseEvent(var Msg: TMsg; var Handled: Boolean);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyMouseEvent(var Msg: TMsg; var Handled: Boolean);
var
  s: string;
begin
  case Msg.message of
    wm_LButtonDown: s := 'left mouse down';
    wm_LButtonUp: s := 'left mouse up';
    wm_MouseMove: s := 'mouse move';
  else
    s := '';
  end;
  if s <> '' then
    ListBox1.Items.Insert(0, s);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := MyMouseEvent;
end;

end.

Center the Windows "Browse for folder" directory picker on screen

Problem/Question/Abstract:

I am using a function from the ShlObj unit to select a networked computer via a Computer Browser. The browser window is called with SHBrowseForFolder(BrowseInfo), the window displayed always seems to position itself in the lower right of the screen. Is it possible to programatically reposition the window to be centered on the screen?

Answer:

Yes, you provide a browse callback function for this task.

uses
  ActiveX, ShlObj;

function CenterVertical(const rect: TRect; h: Integer): Integer;
begin
  Result := (rect.bottom + rect.top - h) div 2;
end;

function CenterHorizontal(const rect: TRect; w: Integer): Integer;
begin
  Result := (rect.right + rect.left - w) div 2;
end;

function BrowserCallback(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer
  stdcall;
var
  r1, r2: TRect;
begin
  result := 0;
  if uMsg = BFFM_INITIALIZED then
  begin
    GetWindowRect(wnd, r1);
    r2 := Rect(0, 0, Screen.Width, Screen.Height);
    MoveWindow(wnd, CenterHorizontal(r2, r1.Right - r1.left), CenterVertical(r2,
      r1.Bottom - r1.Top),
      r1.Right - r1.Left, r1.Bottom - r1.Top, false);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  browseinfo: TBrowseInfo;
  pidl: PItemIDList;
  buf: array[0..MAX_PATH] of Char;
begin
  fillchar(browseinfo, SizeOf(browseinfo), 0);
  browseinfo.hwndOwner := Handle;
  browseinfo.lpszTitle := 'Select directory';
  browseinfo.ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE;
  browseinfo.lpfn := BrowserCallback;
  pidl := ShBrowseForFolder(browseinfo);
  if Assigned(pidl) then
  begin
    ShGetPathfromIDList(pidl, buf);
    ShowMessage(buf);
    CoTaskMemFree(pidl);
  end;
end;

How to turn off the master volume of a sound card

Problem/Question/Abstract:

How to turn off the master volume of a sound card

Answer:

unit WaveUnit;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  NumDevs: Integer;
  waveCaps: TWaveOutCaps;
  Volume: DWORD;
  Left, Right: Word;
  Version: Word;
begin
  { We should have at least one device }
  NumDevs := waveOutGetNumDevs;
  Edit1.Text := Format('Number of devices is %d', [NumDevs]);
  { for the 1st device (hard-coded) }
  {Get Device Caps}
  waveOutGetDevCaps(0, @waveCaps, SizeOf(waveCaps));
  { Show device caps }
  Memo1.Lines.Add('Device Caps: ' + waveCaps.szPName);
  Version := waveCaps.vDriverVersion;
  Memo1.Lines.Add(Format('Driver Version: %d.%d', [Hi(Version), Lo(Version)]));
  case waveCaps.wChannels of
    1: Memo1.Lines.Add('Left');
    2: Memo1.Lines.Add('Right');
  end;
  { Standard formats }
  if waveCaps.dwFormats and WAVE_FORMAT_1M08 <> 0 then
    Memo1.Lines.Add('11.025 kHz, mono, 8-bit');
  if waveCaps.dwFormats and WAVE_FORMAT_1M16 <> 0 then
    Memo1.Lines.Add('11.025 kHz, mono, 16-bit');

  {
  WAVE_FORMAT_1S08        11.025 kHz, stereo, 8-bit
  WAVE_FORMAT_1S16        11.025 kHz, stereo, 16-bit
  WAVE_FORMAT_2M08        22.05 kHz, mono, 8-bit
  WAVE_FORMAT_2M16        22.05 kHz, mono, 16-bit
  WAVE_FORMAT_2S08        22.05 kHz, stereo, 8-bit
  WAVE_FORMAT_2S16        22.05 kHz, stereo, 16-bit
  WAVE_FORMAT_4M08        44.1 kHz, mono, 8-bit
  WAVE_FORMAT_4M16        44.1 kHz, mono, 16-bit
  WAVE_FORMAT_4S08        44.1 kHz, stereo, 8-bit
  WAVE_FORMAT_4S16        44.1 kHz, stereo, 16-bit
  }

    { If Volume Control Supported }
  if waveCaps.dwSupport and WAVECAPS_VOLUME <> 0 then
  begin
    waveOutGetVolume(0, @Volume);
    Left := LoWord(Volume);
    Right := HiWord(Volume);
    { Show values of WAVE Device on volume control panel }
    Edit2.Text := Format('Left : %d, Right : %d', [Left, Right]);
    waveOutSetVolume(0, $40008000);
  end;
end;

end.

Standard RichEdit component and URL highlighting/navigation

Problem/Question/Abstract:

How can I highlight URLs in RichEdit and how can I detect a mouse click in text where URL is?

Answer:

Very popular question in delphi forums is: how can I highlight URLs in RichEdit and how can I detect a mouse click in text where URL is... And everytime I see the answers like "go to XXXX site and use this superb XXX product instead RichEdit".

Today I want to show how to implement URL highlighting and URL navigation without any third-party components. This functionality is implemented in RichEdit from Microsoft (and MS Outlook use this feature, for example) and  only Borland's developers didn't publish it for us.

So what we need:

1. drop on your form a RichEdit component from win32 page of component palette
2. in OnCreate event of your form write the next code:

var
  mask: Word;
begin
  mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
  SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

  RichEdit1.Text := 'Scalabium Software'#13#10 +
    ' Site is located at www.scalabium.com. Welcome to our site.';
end;

After that your Richedit will convert automatically any URLs in highlighted (blue color and underlined). Even if you'll start to enter any text directly in Richedit, any begings for URL will be converted too (not only existing text string but new too)

3. now we must detect mouse clicks in URL range. For this task we must override WndProc method of our form:

type
  TForm1 = class(TForm)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;
  {... }

procedure TForm1.WndProc(var Message: TMessage);
var
  p: TENLink;
  strURL: string;
begin
  if (Message.Msg = WM_NOTIFY) then
  begin
    if (PNMHDR(Message.LParam).code = EN_LINK) then
    begin
      p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
      if (p.msg = WM_LBUTTONDOWN) then
      begin
        SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, LongInt(@(p.chrg)));
        strURL := RichEdit1.SelText;
        ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
      end
    end
  end;

  inherited;
end;

Now you can compile your project (don't forget to include Richedit and ShellAPI units in uses clause) and your RichEdit component will work like a sharm.

Of course, you can modify a code and process this parsed strURL as you like instead implemented navigation in browser as I did...

Memory leak in TCheckListBox

Problem/Question/Abstract:

I just found a memory leak in TCheckListBox (while using Delphi 3). Every time you check an item at runtime, a wrapper is created in routine TCheckListBox.GetWrapper in CheckLst.pas.

Answer:

These wrappers were supposed to be freed in procedure TCheckListBox.DestroyWnd; but this procedure is never called. Therefore all these pointers will never be freed.

The work around to this is to manually clear the listbox when the form is destroyed:

procedure TForm1.FormDestroy(Sender: TObject);
begin
  CheckListBox1.Items.Clear;
  inherited;
end;

Move a form with the mouse in the client area

Problem/Question/Abstract:

I once saw a very short example of moving a form with the mouse. It's the same like moving the form with the mouse in the caption of the form, but now it is moveable with the mouse in the client area. Has anyone an idea how to do this?

Answer:

In the private declarations of the form add this message handler:

private
{ Private declarations }

procedure WMNCHitTest(var M: TWMNCHitTest); message WM_NCHITTEST;

Then add this procedure

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
  inherited;
  if M.Result = htClient then
  begin
    {Client area is hit - but state it is the Title Bar}
    if ((m.ypos - HelpWin.top) < HelpWin.height) then
      M.Result := htCaption;
  end;
end;

Hidden limitations in TIniFile

Problem/Question/Abstract:

I have an INI file that is approximately 20K with all entries in one section. If I use TIniFile's ReadSection method, only part of the section gets loaded. Why?

Answer:

A reader asked me this question a few days ago, and I must admit that it stumped me at first. He was trying to load an INI file's section that had several lines in it (amounting to over 16K of text) that he needed to load into a combo box. The section contained listings of several modem makes and models that he was going to use in his application so users could pick the modems that were on their machines.

To approach his problem, he created a TIniFile object and used the ReadSection method to read the section containing the list of modems into a TStrings object, which happened to be the Items property of a TComboBox. His code worked fine with one exception: ReadSection got about a third of the way through the list, then mysteriously stopped loading values, and truncated in the middle of a line! Intrigued, I decided to look into it, and much to my surprise, found a very interesting quirk in the code for ReadSection in the IniFiles.pas source file.

An Undocumented Limitation

The first stop in my investigation had me testing some code out in loading a huge section of an INI file into a ComboBox. I used the following procedure adapted from a snippet my reader sent to me:

procedure ComboLoadIniSection(IniFileName, SectionName: string; const List TStrings);
var
  ini: TIniFile;
begin
  list.clear;
  if FileExists(IniFileName) then
    ini := TIniFile.Create(IniFileName);
  with ini do
  try
    ReadSection(SectionName, list);
  finally
    Free;
  end;
end;

The code above looks pretty straightforward. In fact it works incredibly well, with absolutely no errors. I used it on some fairly generic INI files with just a few lines of key values first, and the Items property of my ComboBox was loaded just fine. It was when I used the sample file the reader sent containing the modem listings that things went awry. The procedure still executed fine with no errors, but truncated about a third of the way through the list. It looked like I was going to have to look into the source file.

Here's the listing for the ReadSection code in the IniFiles.Pas VCL Source file:

procedure TIniFile.ReadSection(const Section: string; Strings: TStrings);
const
  BufSize = 8192;
var
  Buffer, P: PChar;
begin
  GetMem(Buffer, BufSize);
  try
    Strings.BeginUpdate;
    try
      Strings.Clear;
      if GetPrivateProfileString(PChar(Section), nil, nil, Buffer, BufSize,
        PChar(FFileName)) <> 0 then
      begin
        P := Buffer;
        while P^ <> #0 do
        begin
          Strings.Add(P);
          Inc(P, StrLen(P) + 1);
        end;
      end;
    finally
      Strings.EndUpdate;
    end;
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

Looks like your basic WinAPI wrapper function. But there's one strange thing about it, and it has to do with the call to GetPrivateProfileString. This is a WinAPI-level call that is used to read a specific section of an INI file and loads one or all of its key values into a buffer. The buffer has the following structure: keyValue#0keyValue#0keyValue#0keyValue#0#0 where keyValue is a specific key value in a section. The WinAPI help file states that if the size of the strings in the section exceed the allocated buffer size, the buffer is truncated to the allocated size and two nulls are appended to the end of the string.

So going back to the code listing above, what do you see? Right! The buffer size is only 8K! So any section that has more than 8K in it will be truncated. That's why only part of the list was added into the ComboBox at runtime. I'm sure there was a good reason for the developer who wrote this wrapper to do this &#8212; probably to save memory space and go on the assumption that no one would ever need to have anything larger than 8K to read. But for those that do need to load in more than 8K, this is a serious limitation.

So how do you work around this? Well, at first thought, I figured upon creating a new descendant class off of TIniFile. But I checked myself because all the methods of TIniFile are static, so in order to do an override of a method, I'd have to write it over completely. Not a big deal, but then I'd have to deal with the overhead of adding the component into the VCL (and if you're like me, you've got a lot of components installed on your pallette). In the end, I decided to copy the source code and make a generic utility routine that I put in a library that I use for all my programs. Here's the code:

procedure INISectLoadList(IniFileName, SectionName: PChar; const list: TStrings);
const
  BufSize = 32768; //Changed from 8192
var
  Buffer, P: PChar;
begin
  GetMem(Buffer, BufSize);
  try
    list.BeginUpdate;
    try
      list.Clear;
      if GetPrivateProfileString(SectionName, nil, nil, Buffer, BufSize,
        IniFileName) <> 0 then
      begin
        P := Buffer;
        while P^ <> #0 do
        begin
          List.Add(P);
          Inc(P, StrLen(P) + 1);
        end;
      end;
    finally
      List.EndUpdate;
    end;
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

This is essentially a replica of the code above, with one exception: It now has a 32K buffer size. If you look up the GetPrivateProfileString in the help system, you'll see that the function is in the API code for backward compatibility with 16-bit applications. And as you may know, there is a 32K resource limit with 16- bit apps. Thus, your buffer can't be bigger than this. But this should be plenty of space to work with for 99 percent of the applications out there. However, for those of you making the move to Win95 and NT, the registry is where you should put runtime parameters.

Stay tuned for an article on the registry coming up. I'm still doing the research on it.

Copy one Excel worksheet to another

Problem/Question/Abstract:

Copy one Excel worksheet to another

Answer:

Call the copy method of that worksheet:

{ ... }
var
  After: OleVariant;
  Sh: _Worksheet;
begin
  Sh := Excel.Worksheets['Sheet1'] as _Worksheet;
  After := Excel.Workbooks[1].Sheets[3];
  Sh.Copy(EmptyParam, After, lcid);
  { ... }

Fast sine and cosine calculations

Problem/Question/Abstract:

How to really speed up sine and cosine calculations

Answer:

If you have ever written applications that require many sine and  cosine calculations over a short time you will have realized that things really start to slow down.

This is an old trick. But if you have never come across it, it really is worth using.

This version uses degrees not radians.

unit sin_Tool;

interface
const
  FULL_CIRCLE = 360;
  HALF_CIRCLE = 180;
  //  TEN_CIRCLES = 3600;
function MySin(x: integer): real; overload;
function MySin(x: real): real; overload; //  allow both reals or integers

function MyCos(x: integer): real; overload;
function MyCos(x: real): real; overload; //  allow both reals or integers

{ ===================================================== }
{ ===================================================== }
implementation

uses
  Math;
const
  MULTIPLIER = 10;
  NUM_ELEMENTS = FULL_CIRCLE * MULTIPLIER;
type
  tArcAnswers = array[0..NUM_ELEMENTS] of real;
var
  SinResults,
    CosResults: tArcAnswers;
  { =====================================================
  function DegToRad(x:real):real; // OK... no need .. its in the math unit...
  ===================================================== }

procedure InitArcAnswers;
var
  c: integer;
begin
  for c := 0 to NUM_ELEMENTS do
  begin
    SinResults[c] := sin(DegToRad(c / MULTIPLIER));
    CosResults[c] := cos(DegToRad(c / MULTIPLIER));
  end;
  c := 1;
end;
{ ===================================================== }

function MySin(x: integer): real; overload;
begin
  while (x > FULL_CIRCLE) do
    x := x - FULL_CIRCLE;
  while (x < 0) do
    x := x + FULL_CIRCLE;

  Result := SinResults[x * MULTIPLIER];
end;

function MySin(x: real): real; overload;
begin
  while (x > FULL_CIRCLE) do
    x := x - FULL_CIRCLE;
  while (x < 0) do
    x := x + FULL_CIRCLE;
  Result := SinResults[round(x * MULTIPLIER)];
end;
{ ===================================================== }

function MyCos(x: integer): real; overload;
begin
  while (x > FULL_CIRCLE) do
    x := x - FULL_CIRCLE;
  while (x < 0) do
    x := x + FULL_CIRCLE;
  Result := CosResults[x * MULTIPLIER];
end;

function MyCos(x: real): real; overload;
begin
  while (x > FULL_CIRCLE) do
    x := x - FULL_CIRCLE;
  while (x < 0) do
    x := x + FULL_CIRCLE;
  Result := CosResults[round(x * MULTIPLIER)];
end;

{ ===================================================== }
{ ===================================================== }
initialization
  begin
    InitArcAnswers;
  end;

end.


Component Download: 3649.zip

How to get the printer port name

Problem/Question/Abstract:

How to get the printer port name

Answer:

Getting the printer port name:

{ ... }

uses
  printers, winspool;

function GetCurrentPrinterHandle: THandle;
const
  Defaults: TPrinterDefaults = (pDatatype: nil; pDevMode: nil; DesiredAccess:
    PRINTER_ACCESS_USE or PRINTER_ACCESS_ADMINISTER);
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, @Defaults) then
    RaiseLastWin32Error;
end;

procedure TForm1.Button1Click(Sender: TObject);

  procedure Display(const prefix: string; S: PChar);
  begin
    memo1.lines.add(prefix + string(S));
  end;

var
  pInfo: PPrinterInfo2;
  bytesNeeded: DWORD;
  hPrinter: THandle;
  i: Integer;
begin
  for i := 0 to printer.Printers.Count - 1 do
  begin
    Printer.PrinterIndex := i;
    hPrinter := GetCurrentPrinterHandle;
    try
      GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
      pInfo := AllocMem(bytesNeeded);
      try
        GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded);
        Display('ServerName: ', pInfo^.pServerName);
        Display('PrinterName: ', pInfo^.pPrinterName);
        Display('ShareName: ', pInfo^.pShareName);
        Display('PortName: ', pInfo^.pPortName);
      finally
        FreeMem(pInfo);
      end;
    finally
      ClosePrinter(hPrinter);
    end;
  end;
end;

How to do a text search in a TMemoField

Problem/Question/Abstract:

How to do a text search in a TMemoField

Answer:

Here is an example of how to search a memo field. The field skills is a memo field:

procedure tdmdistbt.ANDFindSkills(SkillList, PeopleList: TStrings);
var
  I, h, foundcount: Integer;
  Skills: string;
begin
  peoplelist.clear;
  with tblTeamMember do
  begin
    first;
    for I := 1 to recordcount do
    begin
      foundcount := 0;
      Skills := uppercase(tblTeamMember.fieldbyname('Skills').asstring);
      for h := 0 to skilllist.count - 1 do
      begin
        if Pos(uppercase(Skilllist[h]), Skills) > 0 then
          inc(foundcount, 1);
      end;
      if foundcount = skilllist.count then
        PeopleList.add(tblTeamMemberFullName.value);
      next;
    end;
  end;
end;

Give Your Forms a Background

Problem/Question/Abstract:

Web pages use tiled bitmaps to create backgrounds. Is it possible to do this in Delphi?

Answer:

Before I learned how to do this, to create a background on a form, I'd drop a TImage on my form, then set its Align property to alClient. For low-resolution bitmaps, the pixelation that would occur at times was absolutely terrible! But with the method that I'll show you here (Note: this is merely ONE way of doing it), you can easily tile bitmaps on the surface of your form. The trick is in trapping the WM_ERASEBKGND message in a handler, creating a bitmap at runtime, then writing a quick bit of code in the OnPaint event handler. Let's go through the steps.

1. In the private section of your code place the following:

private
{ Private declarations }
MyBitmap: TBitmap;

procedure WMEraseBkgnd(var m: TWMEraseBkgnd);
�� message WM_ERASEBKGND;

Notice the declaration of MyBitmap. We'll be creating an instance for it below. The message handler for WM_ERASEBKGND looks like this:

procedure TBmpform.WMEraseBkgnd(var m: TWMEraseBkgnd);
begin
  � m.Result := LRESULT(False);
end;

2. Then, create the following code for the OnPaint event handler Note: In the original article, the "x := x + MyBitmap.Width" is a bit inefficient in that continuously accessing the Bitmap.Width or .Height properties can slow things down - especially when you've got code in the OnPaint method. So what I did here was to simply set a couple of variables to store the Width and Height property values of the bitmap.

procedure TBmpForm.FormPaint(Sender: TObject);
var
  x, y: Integer;
  iBMWid, iBMHeight: Integer;
begin
  iBMWid := MyBitmap.Width;
  iBMHeight := MyBitmap.Height;
  y := 0;
  while y < Height do
  begin
    x := 0;
    while x < Width do
    begin
      Canvas.Draw(x, y, MyBitmap);
      x := x + iBMWid;
    end;
    y := y + iBMHeight;
  end;
end;

3. Finally, create an instance of the bitmap you want to tile in the background in the OnCreate event of your form:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnHint := ShowHint;
  MyBitmap := TBitmap.Create;
  MyBitmap.LoadFromFile('Brick4.bmp');
end;

4. Whoops, almost forgot! You need to destroy the bitmap when you exit!

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
  bmpBackground.Free;
end;

Well, that's it. Don't you just love the quick and dirty ones?

Assign a password to a Paradox table

Problem/Question/Abstract:

Assign a password to a Paradox table

Answer:

To assign a password to a Paradox table, use the following unit and call function TablePasswort like this:

uses Unit2;
// ..
TablePasswort(Table1, 'secret');

unit Unit2;

interface

uses
  BDE, SysUtils, DBTables, Windows;

function TablePasswort(var table: TTable; password: string): Boolean;

implementation

function StrToOem(const AnsiStr: string): string;
begin
  SetLength(result, Length(AnsiStr));
  if Length(result) > 0 then
    CharToOem(PChar(AnsiStr), PChar(result))
end;

function TablePasswort(var table: ttable; password: string): Boolean;
var
  pTblDesc: pCRTblDesc;
  hDb: hDBIDb;
begin
  result := false;
  with table do
  begin
    if Active and (not Exclusive) then
      Close;
    if (not Exclusive) then
      Exclusive := true;
    if (not Active) then
      Open;
    hDb := DBHandle;
    Close
  end;
  GetMem(pTblDesc, sizeof(CRTblDesc));
  FillChar(pTblDesc^, sizeof(CRTblDesc), 0);
  with pTblDesc^ do
  begin
    StrPCopy(szTblName, StrToOem(table.tablename));
    szTblType := szParadox;
    StrPCopy(szPassword, StrToOem(password));
    bPack := true;
    bProtected := true
  end;
  if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, false) <> DBIERR_NONE then
    exit;
  if pTblDesc <> nil then
    FreeMem(pTblDesc, sizeof(CRTblDesc));
  result := true
end;

end.

Fake the caption bar of a borderless form

Problem/Question/Abstract:

How to fake the caption bar of a borderless form

Answer:

procedure TForm1.FormPaint(Sender: TObject);
var
  r: TRect;
begin
  r := Clientrect;
  DrawEdge(canvas.handle, r, EDGE_RAISED, BF_RECT or BF_ADJUST);
  r.bottom := r.top + GetSystemMetrics(SM_CYCAPTION);
  DrawCaption(self.handle, canvas.handle, r, DC_ACTIVE or DC_ICON or DC_TEXT);
  InflateRect(r, -2, -2);
  r.Left := r.right - GetSystemMetrics(SM_CXSIZE) + 2;
  DrawFrameControl(canvas.handle, r, DFC_CAPTION, DFCS_CAPTIONCLOSE);
  r.right := r.left - 2;
  r.Left := r.right - GetSystemMetrics(SM_CXSIZE) + 2;
  DrawFrameControl(canvas.handle, r, DFC_CAPTION, DFCS_CAPTIONMAX);
  r.right := r.left;
  r.Left := r.right - GetSystemMetrics(SM_CXSIZE) + 2;
  DrawFrameControl(canvas.handle, r, DFC_CAPTION, DFCS_CAPTIONMIN);
end;

How to get a zoomed preview of a full-size TScrollBox

Problem/Question/Abstract:

I have a TScrollBox. In it are between 10 to 300 other components (TCustomControls and TGraphic descendants) which are moveable and resizeable. For a better overview of the large scrollbox workspace I would like to write a small zoombox component showing an overview of the whole workspace in a small 50x50 pixel (or whatever size) area. Is there any easy Windows function for doing this fast? Or do I have to write an own routine?

Answer:

You have to write your own. Following is a little example that shows a 50% reduced preview of the full scrollbox. The controls edit1, edit2, shape1, shape2, image1, memo1 are all on the scrollbox, image2 is used for the preview, button1 triggers the painting of the preview. The main problem here is the way I use to paint a TWinControl owned by the scrollbox. The WM_PRINT message used is supported by all standard and common Windows controls, but not by pure VCL controls like TPanel or the grid classes. For those you may have to use WM_PAINT instead, or the PaintTo method.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ScrollBox1: TScrollBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Image1: TImage;
    Shape1: TShape;
    Shape2: TShape;
    Memo1: TMemo;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure PaintControl(aControl: TWinControl; aCanvas: TCanvas; offsetx, offsety: Integer);
begin
  SaveDC(aCanvas.handle);
  try
    SetWindowOrgEx(aCanvas.handle, -(acontrol.left + offsetx), -(acontrol.top + offsety), nil);
    acontrol.perform(WM_PRINT, acanvas.handle, PRF_CHILDREN or PRF_CLIENT or
      PRF_NONCLIENT or PRF_ERASEBKGND);
  finally
    RestoreDC(aCanvas.handle, -1);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBitmap;
  i: integer;
begin
  bmp := TBitmap.Create;
  try
    bmp.width := scrollbox1.HorzScrollBar.Range div 2;
    bmp.height := scrollbox1.VertScrollBar.Range div 2;
    bmp.canvas.lock;
    SetMapMode(bmp.canvas.handle, MM_ISOTROPIC);
    SetWindowExtEx(bmp.canvas.handle, 200, 200, nil);
    SetViewportExtEx(bmp.canvas.handle, 100, 100, nil);
    try
      SetWindowOrgEx(bmp.canvas.handle, -scrollbox1.HorzScrollBar.Position,
        -scrollbox1.VertScrollBar.POsition, nil);
      scrollbox1.perform(WM_PAINT, bmp.canvas.handle, 1);
      SetWindowOrgEx(bmp.canvas.handle, 0, 0, nil);
      for i := 0 to scrollbox1.controlcount - 1 do
        if scrollbox1.controls[i] is TWincontrol then
          Paintcontrol(TWincontrol(scrollbox1.Controls[i]), bmp.canvas,
            scrollbox1.horzscrollBar.Position, scrollbox1.vertScrollBar.Position);
    finally
      bmp.canvas.unlock;
    end;
    image2.picture.bitmap := bmp;
  finally
    bmp.free;
  end;
end;

end.

How to change the appearance of the focus rectangle in a TDBGrid

Problem/Question/Abstract:

I would like to be able to change the colour of the focus rectangle for certain cells and also to prevent it from being drawn for certain cells even when they have focus - is this possible? I have a graphic displayed in a column and I don't want it to be obscured by the blue focus rectangle - a transparent focus rectangle would be ok.

Answer:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
var
  x: string;
begin
  if Field.value = Null then
    x := ''
  else
    x := FloatToStr(field.value);
  with Sender as TDbGrid do
  begin
    if gdFocused in State then
    begin
      Canvas.Brush.Color := clYellow;
      Canvas.Font.color := ClBlack;
    end;
    Canvas.FillRect(Rect);
    Canvas.TextOut(Rect.Left + Canvas.Font.Size, Rect.Top + 2, x);
    if gdFocused in State then
      Canvas.DrawFocusRect(Rect);
  end;
end;

Determine the type of an EXE file

Problem/Question/Abstract:

Determine the type of an EXE file

Answer:

Here's a function to return the platform the executable was designed for (16/32 bit Windows or DOS). Read the comment for the usage. This function works as well with DLLs, COMs, and maybe others. Thanks to Peter Below for this code.

Use it as shown at the bottom of the code snippet.

//-------------------------------------------------------------------------
//  function to return the type of executable or dll (DOS, 16-bit, 32-bit).
//-------------------------------------------------------------------------

type
  TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});

function GetExeType(const FileName: string): TExeType;
var
  Signature,
    WinHdrOffset: Word;
  fexe: TFileStream;
begin
  Result := etUnknown;
  try
    fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
    try
      fexe.ReadBuffer(Signature, SizeOf(Signature));
      if Signature = $5A4D { 'MZ' } then
      begin
        Result := etDOS;
        fexe.Seek($18, soFromBeginning);
        fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
        if WinHdrOffset >= $40 then
        begin
          fexe.Seek($3C, soFromBeginning);
          fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
          fexe.Seek(WinHdrOffset, soFrombeginning);
          fexe.ReadBuffer(Signature, SizeOf(Signature));
          if Signature = $454E { 'NE' } then
            Result := etWinNE
          else if Signature = $4550 { 'PE' } then
            Result := etWinPE;
        end;
      end;
    finally
      fexe.Free;
    end;
  except
  end;
end;

begin
  case GetExeType(aFileName) of
    etUnknown: Label3.Caption := 'Unknown file type';
    etDOS: Label3.Caption := 'DOS executable';
    etWinNE: {16-bit} Label3.Caption := 'Windows 16-bit executable';
    etWinPE: {32-bit} Label3.Caption := 'Windows 32-bit executable';
  end;
end;

How to create a TScrollBox with an own background

Problem/Question/Abstract:

How to create a TScrollBox with an own background

Answer:

unit NScroll;

interface

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

type
  TMyScrollBox = class(TScrollBox)
  private
    FNHBitmap: TBitmap;
    FNHCanvas: TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure SetBitmap(Value: TBitmap);
  protected
    procedure Painting;
    procedure PaintWindow(DC: HDC); override;
  published
    property BackBitmap: TBitmap read FNHBitmap write SetBitmap;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

constructor TMyScrollBox.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  FNHBitmap := TBitmap.Create;
  FNHCanvas := TControlCanvas.Create;
  TControlCanvas(FNHCanvas).Control := Self;
end;

destructor TMyScrollBox.Destroy;
begin
  FNHBitmap.Destroy;
  FNHCanvas.Destroy;
  inherited Destroy;
end;

procedure TMyScrollBox.SetBitmap(Value: TBitmap);
begin
  FNHBitmap.Assign(Value);
  invalidate;
end;

procedure TMyScrollBox.WMPaint(var Message: TWMPaint);
begin
  PaintHandler(Message);
end;

procedure TMyScrollBox.PaintWindow(DC: HDC);
begin
  FNHCanvas.Handle := DC;
  try
    Painting;
  finally
    FNHCanvas.Handle := 0;
  end;
end;

procedure TMyScrollBox.Painting;
var
  FDrawHeight, FDrawWidth: Integer;
  Row, Column, xl, xt, xw, xh: Integer;
  xdl, xdt: Integer;
  xRect: TRect;
  i: integer;
  xhdl: Word;
begin
  if (FNHBitmap.width <> 0) and (FNHBitmap.Height <> 0) then
  begin
    xRect := ClientRect;
    FDrawHeight := xRect.Bottom - xRect.Top;
    FDrawWidth := xRect.Right - xRect.Left;
    xdl := (HorzScrollBar.Position mod FNHBitmap.Width);
    xdt := (VertScrollBar.Position mod FNHBitmap.Height);
    for Row := 0 to (FDrawHeight div FNHBitmap.Height) + 1 do
    begin
      for Column := 0 to (FDrawWidth div FNHBitmap.Width) + 1 do
      begin
        xl := Column * FNHBitmap.Width + xRect.Left - xdl;
        xt := Row * FNHBitmap.Height + xRect.Top - xdt;
        xw := FNHBitmap.Width;
        if (FDrawWidth - xl + xRect.Left) < xw then
          xw := (FDrawWidth - xl + xRect.Top);
        xh := FNHBitmap.Height;
        if (FDrawHeight - xt + xRect.Top) < xh then
          xh := (FDrawHeight - xt + xRect.Top);
        FNHCanvas.CopyRect(Rect(xl, xt, xl + xw, xt + xh), FNHBitmap.Canvas, Rect(0, 0, xw, xh));
      end;
    end;
  end;
end;

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

end.

How to store TForms and / or their properties in a Paradox blob field

Problem/Question/Abstract:

How to store TForms and / or their properties in a Paradox blob field

Answer:

procedure SaveToField(FField: TBlobField; Form: TComponent);
var
  Stream: TBlobStream;
  FormName: string;
begin
  FormName := Copy(Form.ClassName, 2, 99);
  Stream := TBlobStream.Create(FField, bmWrite);
  try
    Stream.WriteComponentRes(FormName, Form);
  finally
    Stream.Free;
  end;
end;

procedure LoadFromField(FField: TBlobField; Form: TComponent);
var
  Stream: TBlobStream;
  I: integer;
begin
  try
    Stream := TBlobStream.Create(FField, bmRead);
    try
      {delete all components}
      for I := Form.ComponentCount - 1 downto 0 do
        Form.Components[I].Free;
      Stream.ReadComponentRes(Form);
    finally
      Stream.Free;
    end;
  except
    on EFOpenError do {nothing}
      ;
  end;
end;

How to wallpaper the client area of a MDI parent form

Problem/Question/Abstract:

How to wallpaper the client area of a MDI parent form

Answer:

Solve 1:

Here are the basics of how it is done:

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FClientInstance,
      FPrevClientProc: TFarProc;
    procedure ClientWndProc(var Message: TMessage);
  public
  end;

implementation

procedure TForm1.ClientWndProc(var Message: TMessage);
var
  MyDC: hDC;
  Ro, Co: Word;
begin
  with Message do
    case Msg of
      WM_ERASEBKGND:
        begin
          MyDC := TWMEraseBkGnd(Message).DC;
          for Ro := 0 to ClientHeight div Image1.Picture.Height do
            for Co := 0 to ClientWIDTH div Image1.Picture.Width do
              BitBlt(MyDC, Co * Image1.Picture.Width, Ro * Image1.Picture.Height,
                Image1.Picture.Width,
                Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0,
                  SRCCOPY);
          Result := 1;
        end;
    else
      Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if FileExists(ExtractFilePath(Application.ExeName) + 'backgrnd.bmp') then
  begin
    Image1.Picture.Bitmap.LoadFromFile(ExtractFilePath(Application.ExeName) +
      'backgrnd.bmp');
    FClientInstance := MakeObjectInstance(ClientWndProc);
    FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
    SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if (FPrevClientProc <> nil) then
  begin
    FClientInstance := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
    SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FPrevClientProc));
    FreeObjectInstance(FClientInstance);
  end;
end;


Solve 2:

You need to do some Windows API level stuff to hook the window proc of MDI client window. This client window occupies the client area of an MDI main from - that's why you can't see the results of your painting.

Here's an example of how you do that. It also illustrates how to create a temporary canvas using a supplied Device Context to facilitate painting the image bitmap. The code looks for the file argyle.bmp in the Windows directory. If you don't have that bitmap, substitute another. Make sure you create an OnDestroy handler and copy the code from FormDestroy here into that handler.

{Example of painting the background of an MDI form}

unit MDIPaint;

interface

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

type
  TForm1 = class(TForm)
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FClientInstance: pointer;
    FOldClientProc: pointer;
    FBackground: TBitmap;
    procedure ClientProc(var Message: TMessage);
  public
    { Public declarations }
    procedure CreateWnd; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ClientProc(var Message: TMessage);
var
  ARect: TRect;
  x, y: integer;
  SrcRect: TRect;
begin
  {if the message is to erase background, tile with the background bitmap}
  with Message do
  begin
    if Msg = WM_ERASEBKGND then
    begin
      WinProcs.GetClientRect(ClientHandle, ARect);
      with TCanvas.Create do
      try
        Handle := wParam;
        SrcRect := Rect(0, 0, FBackground.Width, FBackground.Height);
        y := 0;
        while y < ARect.Bottom do
        begin
          x := 0;
          while x < ARect.Right do
          begin
            CopyRect(Bounds(x, y, FBackground.Width, FBackground.Height),
              FBackground.Canvas, SrcRect);
            inc(x, FBackground.Width);
          end;
          inc(y, FBackground.Height);
        end;
        Result := 1;
      finally
        Handle := 0;
        Free;
      end;
    end
    else
      {otherwise call the original window proc}
      Result := CallWindowProc(FOldClientProc, ClientHandle, Msg, wParam, lParam);
  end;
end;

procedure TForm1.CreateWnd;
begin
  inherited CreateWnd;
  if FormStyle = fsMDIForm then
  begin
    FBackground := TBitmap.Create;
    FBackground.LoadFromFile('c:\windows\argyle.bmp');
    FClientInstance := MakeObjectInstance(ClientProc);
    FOldClientProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
      longint(FClientInstance)));
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {reset the original client proc, free the client instance and the bitmap}
  SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FOldClientProc));
  FreeObjectInstance(FClientInstance);
  FBackground.Free;
end;

end.


Solve 3:

Here are the steps to add a wallpaper to the client area of of a MDI parent form:


1. Create a new project

2. Set the form's FormStyle to fsMDIForm

3. Drop an image on the form and select a bitmap into it.

4. Find the { Private Declarations } comment in the form's definition and add these lines right after it:


FClientInstance, FPrevClientProc: TFarProc;

procedure ClientWndProc(var Message: TMessage);


5. Find the "implementation" line and the {$R *.DFM} line that follows it. After that line, enter this code:


procedure TForm1.ClientWndProc(var Message: TMessage);
var
  MyDC: hDC;
  Ro, Co: Word;
begin
  with Message do
    case Msg of
      WM_ERASEBKGND:
        begin
          MyDC := TWMEraseBkGnd(Message).DC;
          for Ro := 0 to ClientHeight div Image1.Picture.Height do
            for Co := 0 to ClientWIDTH div Image1.Picture.Width do
              BitBlt(MyDC, Co * Image1.Picture.Width, Ro * Image1.Picture.Height,
                Image1.Picture.Width,
                Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0,
                  SRCCOPY);
          Result := 1;
        end
    else
      Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);
    end;
end;


6. Start an OnCreate method for the form and put these lines in it:


FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));


7. Add a new form to your project and set its FormStyle to fsMDIChild.


Now you have a working MDI project with "wallpaper". The image component is not visible, but its bitmap is replicated to cover the MDI form's client area. There is still one problem; when you minimize the child window its icon will be drawn against a gray rectangle.

How to copy text from a TRichEdit to the clipboard with a different font than the original

Problem/Question/Abstract:

I need to ensure that when my TRichEdit copies text to the clipboard, it is copied in a certain font, colour and size. My problem is that my TRichEdit is defaulted to one font and the users are not given the ability to change it. But I want it to pasted into Word (for example) in another font.

Answer:

You can of course compose a rich text file in code and copy that into the clipboard using the standard rich edit clipboard format, but it's a lot of work. A somewhat simpler approach may be to take the rich text as it is in the control (stream to a TMemoryStream, load into a String) and then modify the \fonttbl tag in the file.

procedure TForm1.Button3Click(Sender: TObject);
var
  S: string;
  ss: TStringstream;
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    richedit1.Lines.SaveToStream(ms);
    SetString(S, Pchar(ms.Memory), ms.size);
  finally
    ms.free
  end;
  memo1.text := S; {view raw rtf in TMemo to see font table}
  S := Stringreplace(S, 'Times New Roman', 'Verdana', []);
  ss := TStringstream.Create(S);
  try
    richedit1.Lines.LoadFromStream(ss);
  finally
    ss.free
  end;
end;

To get the new text into the clipboard proceed as below:

uses
  Richedit, Clipbrd;

{$R *.dfm}

procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var
  hMem: THandle;
  pMem: Pointer;
begin
  {Rewind stream position to start}
  S.Position := 0;
  {Allocate a global memory block the size of the stream data}
  hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
  if hMem <> 0 then
  begin
    {Succeeded, lock the memory handle to get a pointer to the memory}
    pMem := GlobalLock(hMem);
    if pMem <> nil then
    begin
      {Succeeded, now read the stream contents into the memory the pointer points at}
      try
        S.Read(pMem^, S.Size);
        {Rewind stream again, caller may be confused if the stream position is
                         left at the end}
        S.Position := 0;
      finally
        {Unlock the memory block}
        GlobalUnlock(hMem);
      end;
      {Open clipboard and put the block into it. The way the Delphi clipboard
                        object is written this will clear the clipboard first.
                         Make sure the clipboard is closed even in case of an exception. If left open
      it would become unusable for other apps.}
      Clipboard.Open;
      try
        Clipboard.SetAsHandle(fmt, hMem);
      finally
        Clipboard.Close;
      end;
    end
    else
    begin
      {Could not lock the memory block, so free it again and raise an out of
                        memory exception}
      GlobalFree(hMem);
      OutOfMemoryError;
    end;
  end
  else
    {Failed to allocate the memory block, raise exception}
    OutOfMemoryError;
end;

var
  CF_RTF: Word = 0; {set in Initialization section}

procedure TForm1.Button3Click(Sender: TObject);
var
  S: string;
  ss: TStringstream;
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    richedit1.Lines.SaveToStream(ms);
    SetString(S, Pchar(ms.Memory), ms.size);
  finally
    ms.free
  end;
  S := Stringreplace(S, 'Times New Roman', 'Verdana', []);
  ss := TStringstream.Create(S);
  try
    // richedit1.Lines.LoadFromStream(ss);
    CopyStreamToClipboard(CF_RTF, ss);
  finally
    ss.free
  end;
end;

initialization
  CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);
end.

Retrieve all directories contained in a path string

Problem/Question/Abstract:

Suppose I have a path string, for example: 'c:\programs\borland\Delphi' , how can I retrieve each single directory name contained in the path (creating a tree of directories)?

Answer:

uses
  SysUtils;

procedure GetDirList(const Root: AnsiString; Dirs: TStrings);
var
  Found: TSearchRec;

  function IsDirectory(F: TSearchRec): Boolean
  begin
    Result := F.Name <> '.';
    Result := Result or (F.Name) <> '..';
    Result := Result and (F.Attr and faDirectory = faDirectory);
  end;

begin
  Dirs.Clear;
  if FindFirst(Root + '\*.*', faAnFile, Found) = 0 then
  begin
    try
      if IsDirectory(Found) then
        Dirs.Add(Root + '\' + Found.Name);
      while FindNext(Found) = 0 do
      begin
        if IsDirectory(Found) then
          Dirs.Add(Root + '\' + Found.Name);
      end;
    finally
      FindFree
    end;
  end;
end;

Number in french plain text

Problem/Question/Abstract:

Converting integer to plain text in French

Answer:

function IntToLetters(N: Integer): string;

  function Mille(N: Integer; P: Integer): string;

    // Calcul des nombre de 0..99
    function Cent(N: Integer): string;
    const
      X: array[0..20] of string =
      ('zero', 'un', 'deux', 'trois', 'quatre', 'cinq', 'six', 'sept', 'huit', 'neuf',
        'dix',
        'onze', 'douze', 'treize', 'quatorze', 'quinze', 'seize', 'dix-sept',
          'dix-huit', 'dix-neuf', 'vingt');
      Y: array[2..10] of string =
      ('vingt', 'trente', 'quarante', 'cinquante', 'soixante', 'soixante',
        'quatre-vingt', 'quatre-vingt', 'cent');
    var
      A, B: Integer;
      R, C: string;
    begin
      // Si le nombre est inferieur ou egal a 20 on a la solution directe
      if (N <= 20) then
      begin
        R := X[N];
      end;
      // Si le nombre est superieur a 20
      if (N > 20) and (N < 100) then
      begin
        // on prend la dizaine
        A := N div 10;
        // on pend l'unit�
        B := N mod 10;
        // si l'unit� est un, le s�parateur est 'et'
        if (B = 1) and (A in [2, 3, 4, 5, 6, 7]) then
          C := ' et '
        else
          C := ' ';
        // si l'unite est sup�rieure a 1, le s�parateur est un '-'
        if (B > 1) and (A in [2, 3, 4, 5, 6, 7, 8, 9]) then
          C := '-';
        // si la dizaine est 7 ou 9 on compte les unit�s de 10 ? 19
        if (A = 7) or (A = 9) then
          B := B + 10;
        // On calcule la solution
        if (B = 0) then
          R := Y[A]
        else
          R := Y[A] + C + X[B];
      end;
      Result := R;
    end;

    // Calcul des nombres de 100..999
  var
    A, B: Integer;
    R: string;
  begin
    if (N >= 100) then
    begin
      // on prend la centaine
      A := N div 100;
      // on prend le reste
      B := N mod 100;
      if (A = 0) or (A = 1) then
      begin
        // si la centaine est 0 ou 1
        // on calcule et on 'cent' est au singulier
        if (B = 0) then
          R := 'cent '
        else
          R := 'cent ' + Cent(B);
      end
      else
      begin
        // si la centaine est > 1
        if (P = 0) then
        begin
          // si c'est la fin d'un nombre (P=0)
          // on mets 'cents' au pluriel si pas d'unit� sinon on met 'cent' au singulier
          if (B = 0) then
            R := Cent(A) + ' cents '
          else
            R := Cent(A) + ' cent ' + Cent(B);
        end
        else
        begin
          // si ce n'est pas la fin d'un nombre 'cent' est au singulier
          if (B = 0) then
            R := Cent(A) + ' cent '
          else
            R := Cent(A) + ' cent ' + Cent(B);
        end;
      end;
    end
    else
    begin
      // si le nombre est inf�rieur a 100 on le calcule directement
      R := Cent(N);
    end;
    Result := R;
  end;

  // Function principale
const
  Z: array[0..3] of string =
  ('', 'mille', 'million', 'milliard');
var
  B, I: Integer;
  R, M: string;
begin
  R := '';
  I := 0;
  // On va d�composer en tranche de 1000 en partant de la droite
  while (N > 0) do
  begin
    // prend une tranche (reste de la division par 1000)
    B := N mod 1000;
    // le pluriel est utilis� a partir des milliers
    if (I = 0) then
      M := ' '
    else
      M := 's ';
    if I = 1 then
    begin
      // on calcule la tranche des milliers
      // si le nombre de milliers est sup�rieur a 1 on ecrit le nombre et 'milles'
      if (B > 1) then
        R := Mille(B, I) + ' ' + Z[I] + M + R;
      // sinon on �ecrit 'mille' et pas 'un mille'
      if (B = 1) then
        R := Z[I] + ' ' + R;
    end
    else
    begin
      // on calcule les millions et suivants
      // on mets un 's' au pluriel
      if (B > 1) then
        R := Mille(B, I) + ' ' + Z[I] + M + R;
      // on n'en met pas au singulier
      if (B = 1) then
        R := Mille(B, I) + ' ' + Z[I] + ' ' + R;
    end;
    // on decale de 3 rangs vers la droite
    N := N div 1000;
    I := I + 1;
  end;
  if (R = '') then
    R := 'z�ro';
  Result := R;
end;