How to draw a line in a RichEdit (just like in the Deplhi Editor)

Problem/Question/Abstract:

How to draw a line in a RichEdit (just like in the Delphi editor)

Answer:

procedure DrawLine;

var
  aCanvas: Tcanvas;
  X1, X2, Y1: Integer;
  byLineLength: BYTE;

begin
  byLineLength := 80; // Draw the line after 80 chars on the RichEdit
  aCanvas := TCanvas.Create;
  Y1 := RichEdit1.Height;
  try
    aCanvas.Handle := GetDC(RichEdit1.Handle);
    aCanvas.Font := RichEdit1.Font;
    X1 := aCanvas.TextWidth('W');
    X2 := aCanvas.TextWidth('i');
    aCanvas.Pen.color := clSilver; // Color of line
    if X1 = X2 then // Check for fixed or variable font
    begin
      aCanvas.MoveTo(byLineLength * X1, 0);
      aCanvas.LineTo(byLineLength * X1, Y1);
    end;
  finally
    ReleaseDC(RichEdit1.Handle, aCanvas.Handle);
    aCanvas.Free;
  end;
end;

How to do scaling while keeping the aspect ratio

Problem/Question/Abstract:

Currently I am using a whole bunch of if..then statements to compare the width and height of two rectangles and determine the scaling factor by dividing the original rect size (width or height) by the second rectangle size. If the second is smaller than the first, the scaling factor is 1. There must be a better way and I'm thinking of StretchDIBits(). Remember, I am trying to reduce the rectangle size while keeping the aspect ratio.

Answer:

Even using StretchDIBits, you have to calculate the scaling factor.


var
  XScale: Single;
  YScale: Single;
  Scale: Single;
begin
  XScale := 1.0;
  YScale := 1.0;
  if TargetWidth < SourceWidth then
    XScale := TargetWidth / SourceWidth;
  if TargetHeight < SourceHeight then
    YScale := TargetHeight / SourceHeight;
  Scale := XScale;
  if YScale < Scale then
    Scale := YScale;
end;


Now use Scale as your scaling factor.

How to control where text is dropped into a TMemo

Problem/Question/Abstract:

How can I control where text is dropped into a TMemo? In other words, I am in the middle of a drag operation and want to drop selected text into a TMemo based on the mouse position of where I drop. How can I tell the caret to go to the mouse location prior to the drop action?

Answer:

Send a EM_CHARFROMPOS message to the control, passing the mouse position (in client coordinates).

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  ret: Longint;
begin
  ret := memo1.perform(EM_CHARFROMPOS, 0, MakeLParam(X, Y));
  label1.caption := format('row: %d, character index: %d', [HiWord(ret),
    LoWord(ret)]);
end;

That is the first step, it gives you the mouse position in "character coordiantes". You still need to convert that to a character index, which you assign to SelStart to set the caret to that position.

with memo1 do
  selstart := perform(EM_LINEINDEX, row, 0) + col;

You can now assign the dropped text to the memos SelText property to insert it.

Note that the EM_CHARFROMPOS message can also be used with TRichedit but the parameters
are different!

How to convert a bitmap or icon to Hex code

Problem/Question/Abstract:

If you load an image into a Delphi component at design time, then view the form as Text, you can see the hex code that makes up the image. I assume this is how Windows/ Delphi stores the image. How can I get the data in the same format, at runtime, as a string, to save to a text file?

Answer:

function StreamToHexStr(Stream: TStream; LineSize: Integer = 80): TStringList;
var
  Value: Byte;
begin
  Result := TStringList.Create;
  if Result.Count = 0 then
    Result.Add('');
  repeat
    Stream.Read(Value, 1);
    Result[Result.Count - 1] := Result[Result.Count - 1] + IntToHex(Value, 2);
    if Length(Result[Result.Count - 1]) >= LineSize then
      Result.Add('');
    Stream.Seek(1, soFromCurrent);
  until
    Stream.Position >= Stream.Size - 1;
  if Result[Result.Count - 1] = '' then
    Result.Delete(Result.Count - 1);
end;

Cannot single step into VCL source code anymore

Problem/Question/Abstract:

All of a sudden I cannot single step into the VCL source code anymore. The path to $(DELPHI)\Source\Vcl is in the Environment Options Directory and I also tried to add it to the Project Options > Debug Source Path but it did not help.
It appears that $(DELPHI)\ is correct since I added a absolute path to the list and D5 recognized this was the $(DELPHI)\ path and changed it back to $(DELPHI)\Source\Vcl automatically. What happened?

Answer:

Here are two possible reasons for your situation:

You may accidentally have unchecked "Use Debug DCUs" in Project | Options Compiler.

Perhaps you have switched "Build with run-time packages" on.

How to set focus on a MessageDlg button

Problem/Question/Abstract:

Is there a way to set the focus on a certain button when using MessageDlg? I want to be able to set focus to the No button when the dialog executes. By default the focus is always on the Yes button, no matter what order I code them in the function.

Answer:

Solve 1:

I had a similar situation come up and I wanted to specify which button was considered the default when pressing ENTER and which one would be the default for pressing ESCAPE. Also, I wanted other text in the buttons. So instead of Yes/ No I would have liked Save File/ Skip Save.

Then it becomes easier for the user to determine which button to press. They don't have to read the whole message, they can just look at the button. So, I will give you my code for that. I call it MultiMessageDlg, you can specify up to 4 buttons. Here is the source for my form:


unit MultiAsk;

interface

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

type
  TMultiAskMenu = class(TForm)
    LAsk: TLabel;
    PButtons: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Panel1: TPanel;
    Image1: TImage;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Setup(MsgType: TMsgDlgType; Num: Integer; Title, Ask, S1, S2, S3, S4: string);
  end;

var
  MultiAskMenu: TMultiAskMenu;

implementation

uses
  GlobalRW;

{$R *.DFM}

procedure ButtonCode(const Butt1: TButton; var Cap: string);
begin
  Butt1.Cancel := False;
  Butt1.Tag := 0;
  if Pos(' + ', Cap) = 1 then
  begin
    Butt1.Tag := 1;
    Delete(Cap, 1, 1);
  end;
  if Pos(' - ', Cap) = 1 then
  begin
    Butt1.Cancel := True;
    Delete(Cap, 1, 1);
  end;
  Butt1.Caption := Cap;
end;

procedure TMultiAskMenu.Setup(MsgType: TMsgDlgType; Num: Integer;
  Title, Ask, S1, S2, S3, S4: string);
var
  TmpBmp: TBitMap;
  IconID: PChar;
  X, W1, W2, W3, W4: Integer;
  NonClientMetrics: TNonClientMetrics;
  HIcon1: HIcon;
const
  IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK,
    IDI_QUESTION, nil);
begin
  case MsgType of
    mtInformation:
      begin
        Self.Caption := ' Information ';
      end;
    mtWarning: b
      begin
        Self.Caption := ' Warning ';
      end;
    mtError:
      begin
        Self.Caption := ' Error ';
      end;
  end;
  if Title <> '' then
    Self.Caption := Title;
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    LAsk.Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
  IconID := IconIDs[MsgType];
  if IconID <> nil then
  begin
    with Image1 do
    begin
      HIcon1 := LoadIcon(0, IconID);
      Picture.Icon.ReleaseHandle;
      Picture.Icon.Handle := HIcon1;
    end;
  end;
  TmpBmp := TBitMap.Create;
  TmpBmp.Canvas.Font := Button1.Font;
  W1 := TmpBmp.Canvas.TextWidth(S1) + 10;
  Button1.Width := W1;
  W2 := TmpBmp.Canvas.TextWidth(S2) + 10;
  Button2.Width := W2;
  W3 := TmpBmp.Canvas.TextWidth(S3) + 10;
  Button3.Width := W3;
  W4 := TmpBmp.Canvas.TextWidth(S4) + 10;
  Button4.Width := W4;
  TmpBmp.Free;
  LAsk.Caption := Ask;
  PButtons.Top := LAsk.Top + LAsk.Height + 30;
  case Num of
    1:
      begin
        Button1.Left := Button2.Left;
        Button2.Visible := False;
        Button3.Visible := False;
        Button4.Visible := False;
        Button1.Left := (Self.Width - W1) div 2;
      end;
    2:
      begin
        Button2.Left := Button3.Left;
        Button3.Visible := False;
        Button4.Visible := False;
        Button1.Caption := S1;
        X := (Self.Width - W1 - W2) div 3;
        Button1.Left := X;
        Button2.Left := X + W1 + X;
      end;
    3:
      begin
        Button4.Visible := False;
        X := (Self.Width - W1 - W2 - W3) div 4;
        Button1.Left := X;
        Button2.Left := X + W1 + X;
        Button3.Left := X + W1 + X + W2 + X;
      end;
    4:
      begin
        X := (Self.Width - W1 - W2 - W3 - W4) div 5;
        Button1.Left := X;
        Button2.Left := Button1.Left + W1 + X;
        Button3.Left := Button2.Left + W2 + X;
        Button4.Left := Button3.Left + W3 + X;
      end;
  end;
  {Take into Account pressing ESCAPE and Default buttons!!!
  +Yes  + = Default
  -No  - = Escape}
  ButtonCode(Button1, S1);
  ButtonCode(Button2, S2);
  ButtonCode(Button3, S3);
  ButtonCode(Button4, S4);
  Self.AutoSize := True;
end;

procedure TMultiAskMenu.Button1Click(Sender: TObject);
begin
  ModalResult := 1;
end;

procedure TMultiAskMenu.Button2Click(Sender: TObject);
begin
  ModalResult := 2;
end;

procedure TMultiAskMenu.Button3Click(Sender: TObject);
begin
  ModalResult := 3;
end;

procedure TMultiAskMenu.Button4Click(Sender: TObject);
begin
  ModalResult := 4;
end;

procedure TMultiAskMenu.FormShow(Sender: TObject);
begin
  if Button1.Tag = 1 then
    Button1.SetFocus;
  if Button2.Tag = 1 then
    Button2.SetFocus;
  if Button3.Tag = 1 then
    Button3.SetFocus;
  if Button4.Tag = 1 then
    Button4.SetFocus;
end;

procedure TMultiAskMenu.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Self.Image1.Picture.Icon.ReleaseHandle;
end;

end.

So in order to use it you would do something like this:


if MultiMessageDlg('',
  ' It has been awhile since you last checked for updates. Do you  wish to check the TurboView Internet site for updates to TurboView?',
  mtInformation, 2, ' + Check NOW ', ' - Check Next Month', '', '') = 1 then
begin
  {code to do checking for the latest version of program}
end;


So the format is MultiMessageDlg(TitleText, MessageText, MessageType, NumberOfButtons, Button1Text, Button2Text, Button3Text, Button4Text);

The return value is which button was pressed [1..4];

TitleText is optional, if not title is given then the normal MessageDlg title will be used for window dialog title.

MessageText is what message you want displayed

MessageType is the same thing you provide to the normal MessageDlg function

NumberOfButtons is how many buttons to actually display

ButtonText, you can provide text for up to 4 buttons.

Note: If you want a certain button to be the DEFAULT button, then you would put a "+" plus sign in front of the text. For example: "+Save File" . And if you want a button to be the default ESCAPE button, then put a "-" minus in front, like so: "-Dont Save".


Solve 2:

The following function will let you define the default button, then center the dialog above the OwnerWnd, and then play the sound associated with the message type:


function MessageDlgEx(OwnerWnd: HWND; DefButton: Integer; const Msg: string;
  DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer;
var
  vButton: TButton;
  vRect: TRect;
  vWidth: Integer;
  vHeight: Integer;
  vTop: Integer;
  vLeft: Integer;
  I: Integer;
begin
  with CreateMessageDialog(Msg, DlgType, Buttons) do
  begin
    try
      { Get the TRect }
      GetWindowRect(OwnerWnd, vRect);
      { Center the dialog }
      vWidth := vRect.Right - vRect.Left;
      vHeight := vRect.Bottom - vRect.Top;
      vTop := vRect.Top;
      vLeft := vRect.Left;
      Top := vTop + ((vHeight - Height) div 2);
      Left := vLeft + ((vWidth - Width) div 2);
      { Set the default button }
      for I := 0 to Pred(ComponentCount) do
      begin
        if Components[I] is TButton then
        begin
          vButton := TButton(Components[I]);
          vButton.Default := (vButton.ModalResult = DefButton);
          if vButton.Default then
          begin
            ActiveControl := vButton;
          end;
        end;
      end;
      { Play the sound associated with the DlgType }
      case DlgType of
        mtConfirmation: MessageBeep(MB_ICONQUESTION);
        mtError: MessageBeep(MB_ICONERROR);
        mtInformation: MessageBeep(MB_ICONINFORMATION);
        mtWarning: MessageBeep(MB_ICONWARNING);
      end;
      { Show the dialog }
      Result := ShowModal;
    finally
      free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if MessageDlgEx(Handle, mrNo, 'Do you wan''t this program to erase all of your files?',
    mtWarning, [mbYes, mbNo]) = mrYes then
    ShowMessage('Okay...');
end;

Draw text in the node of a TTreeView in bold style

Problem/Question/Abstract:

I would like to write the text of each node in a TTreeview by including the text in the standard way with a trailing number written in bold and color blue.

Answer:

This is a code snippet of a descendant of a TTreeView that handles the bold state of a treenode:

function TTreeView1.GetNodeBoldState(Node: TTreeNode): boolean;
var
  TVItem: TTVItem;
begin
  result := false;
  if not Assigned(Node) then
    exit;
  with TVItem do
  begin
    mask := TVIF_STATE;
    hitem := Node.ItemId;
    result := TreeView_GetItem(Node.Handle, TVItem) and ((State and TVIS_BOLD) <> 0);
  end;
end;

procedure TTreeView1.SetNodeBoldState(Node: TTreeNode; value: boolean);
var
  TVItem: TTVItem;
begin
  if not Assigned(Node) then
    exit;
  fillchar(TVItem, sizeof(TVItem), 0);
  with TVItem do
  begin
    mask := TVIF_STATE or TVIF_HANDLE;
    hitem := Node.ItemId;
    StateMask := TVIS_BOLD;
    if value then
      State := TVIS_BOLD;
    TreeView_SetItem(Node.Handle, TVItem);
  end;
end;

Display the window of another application in a Delphi form

Problem/Question/Abstract:

I would like to have an application (f.e. notepad.exe) to run in a specified frame (TPanel,..) within my application.

Answer:

It does not work well but you can try this:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure ApplicationEvents1Activate(Sender: TObject);
  private
    { Private declarations }
    FNotepad: HWND;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  wnd: HWND;
  tries: Integer;
begin
  WinExec('notepad.exe', SW_HIDE);
  tries := 0;
  repeat
    wnd := Findwindow('notepad', nil);
    if wnd = 0 then
    begin
      inc(tries);
      sleep(100);
    end;
  until
    (wnd <> 0) or (tries > 10);
  if wnd <> 0 then
  begin
    windows.setparent(wnd, handle);
    application.title := 'Notepad';
    MoveWindow(wnd, 0, 0, clientwidth, clientheight, false);
    ShowWindow(wnd, SW_SHOW);
    SetForegroundWindow(wnd);
    FNotepad := wnd;
  end
  else
    showmessage('Failed');
end;

procedure TForm1.ApplicationEvents1Activate(Sender: TObject);
begin
  if IsWindow(FNotepad) then
    SetForegroundWindow(FNotepad)
  else
    Close;
end;

end.

To wire the notepad window to a panel you would simlpy use the panels handle in the SetParent call.

How to do a SHIFT TAB through code

Problem/Question/Abstract:

I use SendMessage(EditHandle, WM_KEYDOWN, VK_TAB, 0) to mimic pressing TAB key, but how about SHIFT-TAB? I know I can use WM_NEXTDLGCTL, but that is exactly what I try to avoid.

Answer:

You can do both by sending the WM_KEYDOWN message to the control or generate the keyboard event through the keybd_event function. See the example below for details:

{ ... }
var
  XKeyState, XNewKeyState: TKeyboardState;
begin
  try
    {set shift key down}
    GetKeyboardState(XKeyState);
    XNewKeyState := XKeyState;
    XNewKeyState[VK_SHIFT] := $81;
    SetKeyboardState(XNewKeyState);
    {post tab key down message}
    PostMessage(YourComponent.Handle, WM_KEYDOWN, VK_TAB, 0);
    Application.ProcessMessages;
  finally
    {return old keyboard state back}
    SetKeyboardState(XKeyState);
  end;
end;

or you use

{ ... }
keybd_event(VK_SHIFT, 0, 0, 0);
keybd_event(VK_TAB, 0, 0, 0);
keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);
end;

Sort a TStringGrid using the Bubblesort algorithm

Problem/Question/Abstract:

Does anyone know an easy way to sort TStringGrids, preferably by the first column?

Answer:

Here is a quick Bubblesort:

procedure TForm1.Button1Click(Sender: TObject);
var
  pass, j: integer;
  hold: TStringList;
begin
  hold := TStringList.Create;
  {sorting is based on first column, '0'}
  for pass := 1 to StringGrid1.RowCount - 1 do
  begin
    for j := 0 to StringGrid1.RowCount - 2 do
      if StringGrid1.Cells[0, j] > StringGrid1.Cells[0, j + 1] then
      begin
        hold.Assign(StringGrid1.Rows[j]);
        StringGrid1.Rows[j].Assign(StringGrid1.Rows[j + 1]);
        StringGrid1.Rows[j + 1].Assign(hold);
      end;
  end;
  hold.Free;
end;

Delphi .NET: Get computer IP address

Problem/Question/Abstract:

How to get the list of the computer IP addresses

Answer:

One of the many namespaces in the Base Class Framework is the System.Net namespace. It provides a simple programming interface to many of the protocols found on the network today. One of the classes of the namespace is DNS which provides simple domain name resolution functionality.

{$APPTYPE CONSOLE}
program getip;

uses
  System,
  System.Net,
  Borland.Delphi.SysUtils;

var
  strMachineName: string;
  ipHost: IPHostEntry;
  ipAddr: array of IPAddress;
  count: Integer;
begin

  //Get the Host Name
  strMachineName := Dns.GetHostName();
  Console.WriteLine('Host Name: ' + strMachineName);

  //Get the Host by Name
  ipHost := Dns.GetHostByName(strMachineName);

  //You can also query the DNS database for info on a
  //website like users.chello.be
  //In that case replace the above line as:
  //ipHost := Dns.GetHostByName('users.chello.be')

  //Get the list of addresses associated with the host in an array
  ipAddr := ipHost.AddressList;

  //Enumerate the IP Addresses
  for count := 0 to length(ipAddr) - 1 do

    Console.Write(Format('IP Addresses %d: %s ', [count, ipAddr[count].ToString]));
end.

Use the GetKerningPairs function

Problem/Question/Abstract:

I want to display text with the correct kerning (spacing). GetKerningPairs is a function I need for that, but I have no clue how to use it.

Answer:

{ ... }
type
  TKerningpairarray = array[0..600] of Kerningpair;
  { ... }

var
  kpa: TKerningpairarray;

  { ... }
var
  i, Num: Integer;
begin
  Canvas.Font.Name := 'Arial';
  Num := GetKerningPairs(Canvas.Handle, 600, kpa);
  Memo1.Text := '';
  for i := 0 to Num - 1 do
    Memo1.Lines.Add(IntToStr(kpa[i].wfirst) + ', ' + IntToStr(kpa[i].wsecond) + ', '
      + IntToStr(kpa[i].ikernamount));
end;

SQL monitor magic

Problem/Question/Abstract:

Having problems with SQL monitor? Need better monitoring? How about multi-threaded monitoring? SQL monitor infrastructure provides this and more.

Answer:

Introduction

SQL monitor is one of the most useful tools in Delphi, when you develop a database application. It allows the programmer to debug the connection between an application and a Database. It is very useful when you have automatic SQL generation. The tool provides the time it takes for each SQL to run, so you can use it to profile you&#8217;re DB side of the application.

SQL monitor paints a nice picture. However, SQL monitor has some problems:

You must start SQL monitor before you start the client application. This is a problem with applications that need to run non-stop for long durations.

The tool is not designed to work with multithreaded applications. It can trace only one session at a time, and that session is the last one opened. You cannot select what thread to monitor, nor can you monitor more then one thread.

Some applications use an automatic trouble tickets (TT) in case of errors. When you have a DB related problem, it is useful to add the SQL trace to the TT. However, the SQL monitor is an external tool, and does not allow this kind of trace.

The SQL monitor tool uses an infrastructure provided by Delphi and the BDE to trace SQLs. We can connect to this infrastructure without the SQL monitor tool, in order to get an SQL trace internally to the application, with out any of the problems above.

How the SQL trace works

We need to tell the BDE that we want an SQL trace. We do that by registering a callback function with the BDE (Callback is the equivalent of an event in non Object Oriented systems). The BDE provides SQL trace by setting a memory buffer with some text, and then notifying us with a callback. The callback function gets one parameter &#8211; a pointer to a TtraceDesc type (defined in the BDE unit). In that structure is the text we see in the SQL monitor tool.

Setting a BDE SQL Trace

In order to set a trace on the BDE, we need to register a BDE callback using the DbiRegisterCallback function in the DBE unit. The unit takes a number of parameters that sound like gibberish when you look at them in the online help. The VCL provides a nice wrapper for this call with the TBDECallback Class in the DBTables unit. This class takes a number of parameters in its constructor, and sets the appropriate callback. When we free an object of this class, the callback is freed.

To use the TBDECallback object, we need to do a number of things:

The TBDECallback object can register all kinds of DBE callbacks. In order to trace SQL, we need a cbTRACE callback (the value of the CBType parameter in Create).

We need to create a callback function with the following prototype:

function(CBInfo: Pointer): CBRType of object;

We need to create a memory buffer of smTraceBufSize size. (smTraceBufSize is a constant defined in the DBTables unit).

The code to set a trace can look like this:

var
  FSMBuffer: PTraceDesc;
  TraceCallback: TBDECallback;
begin
  GetMem(FSMBuffer, smTraceBufSize);
  TraceCallback := TBDECallback.Create(Self, nil, cbTRACE,
    FSMBuffer, smTraceBufSize, SqlTraceCallBack, False);
end;

The sqlTraceCallBack is a function defined in Delphi. It can look like this:

function TInternalSQLMonitor.SqlTraceCallBack(CBInfo: Pointer): CBRType;
var
  Data: Pointer;
  S: string;
begin
  Data := @PTraceDesc(CBInfo).pszTrace;
  SetLength(S, StrLen(Data));
  StrCopy(PChar(S), Data);

  //  S holds the trace text!

  Result := cbrUSEDEF;
end;

Stopping the trace

In order to stop the trace, all you need to do is

FreeMem(FSMBuffer, smTraceBufSize);
TraceCallback.Free;

And now for the advanced staff&#8230;

In the last section I explained how to setup an SQL trace. However, in the start of this article, a complained that the SQL monitor tool does not provide good support for multiple sessions and threads. In fact, the code in the last section has exactly the same problems. We need to overcome those problems.

If you look at the code in the last section, you will see that I do not specify what session and what database to trace. I also do not setup what are the trace options (as we have in the SQL monitor options window).

The problem is that we are opening a trace on the default session, default database and using the default settings (from the BDE driver).

When we run the above code, it registers a trace with the BDE current session. The current session is accessed via the sessions.CurrentSession global object property. By changing the current session, we can register a trace for any session we want. The callback function is registered per session, allowing us multi-threading trace. Don&#8217;t confuse the default session with the current session. The default session is one that is automatically opened by Delphi, and cannot be changed. The current session is current from the BDE point of view. It is the session that BDE functions work with. Because the current session is a global definition, we need some thread locking  mechanism when we set a trace. The code for setting a trace can now look like:

var
  ActivationLock: TCriticalSection;

procedure SetTrace;
begin
  ActivationLock.Enter;
  try
    // set the current session to be the session we want to trace.
    SaveCurrentSession := Sessions.CurrentSession;
    Sessions.CurrentSession := Session;
    // set the trace.
    GetMem(FSMBuffer, smTraceBufSize);
    TraceCallback := TBDECallback.Create(Self, nil, cbTRACE,
      FSMBuffer, smTraceBufSize, SqlTraceCallBack, True);
    // restore the current session to the saved session.
    Sessions.CurrentSession := SaveCurrentSession;
  finally
    ActivationLock.Leave;
  end;
end;

We need the same structure when we release the trace.

procedure CloseTrace;
begin
  ActivationLock.Enter;
  try
    // set the current session to be the session we want to trace.
    SaveCurrentSession := Sessions.CurrentSession;
    Sessions.CurrentSession := Session;
    // close the trace.
    FreeMem(FSMBuffer, smTraceBufSize);
    TraceCallback.Free;
    // restore the current session to the saved session.
    Sessions.CurrentSession := SaveCurrentSession;
  finally
    ActivationLock.Leave;
  end;
end;

What about the trace options?

The trace options come from the driver configuration of the BDE. However, you can override them from Delphi by setting the TraceFlags property of a Tdatabase component. There is one fine point to notice. You must set the value of TraceFlags AFTER you open the database. For some reason, if you set the options before you open the database, this has no affect.

Example

The following example is a component providing SQL trace for one session and one database. The component fires a Delphi event for each SQL trace event, with the trace text as a parameter. In order to use this component, all you need to do is attach it to a Tsession and Tdatabase, set the trace options, set the event and activate the trace.
Note that you can only activate a trace on an open database.

Code

unit InternalSQLMonitor_thread;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  dbTables, bde, syncobjs;

const
  cDefaultTraceOptions = [tfQPrepare, tfQExecute, tfError, tfStmt, tfDataIn];

type
  TSQLTraceEvent = procedure(Sender: TObject; const SQLTrace: string) of object;

  TInternalSQLMonitor = class(TComponent)
  private
    FActive: Boolean;
    FOnSQLTraceEvent: TSQLTraceEvent;
    FSMBuffer: PTraceDesc;
    TraceCallback: TBDECallback;
    FSession: TSession;
    FDatabase: TDatabase;
    FTraceOptions: TTraceFlags;
    procedure ReplaceComponent(var Reference: TComponent; const Value: TComponent);
    procedure SetActive(const Value: Boolean);
    procedure SetOnSQLTraceEvent(const Value: TSQLTraceEvent);
    procedure SetSession(const Value: TSession);
    procedure SetDatabase(const Value: TDatabase);
    function CanOpenTrace: Boolean;
    procedure SetTraceOptions(const Value: TTraceFlags);
  protected
    function SqlTraceCallBack(CBInfo: Pointer): CBRType;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
  published
    property OnSQLTraceEvent: TSQLTraceEvent read FOnSQLTraceEvent write
      SetOnSQLTraceEvent;
    property Active: Boolean read FActive write SetActive;
    property Session: TSession read FSession write SetSession;
    property Database: TDatabase read FDatabase write SetDatabase;
    property TraceOptions: TTraceFlags read FTraceOptions write SetTraceOptions default
      cDefaultTraceOptions;
  end;

procedure Register;

implementation

var
  ActivationLock: TCriticalSection;

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

{ TInternalSQLMonitor }

function TInternalSQLMonitor.CanOpenTrace: Boolean;
begin
  Result := (Session <> nil) and
    (Session.Active) and
    (Database <> nil) and
    (Database.Connected);
end;

procedure TInternalSQLMonitor.Close;
begin
  SetActive(False);
end;

constructor TInternalSQLMonitor.Create(AOwner: TComponent);
begin
  inherited;
  TraceOptions := cDefaultTraceOptions;
end;

destructor TInternalSQLMonitor.Destroy;
begin
  inherited;
  SetActive(False);
end;

procedure TInternalSQLMonitor.Open;
begin
  SetActive(True);
end;

procedure TInternalSQLMonitor.SetActive(const Value: Boolean);
var
  SaveCurrentSession: TSession;
begin
  // create the critical section, if needed.
  if ActivationLock = nil then
    ActivationLock := TCriticalSection.Create;
  if FActive <> Value then
  begin
    // check that all the preconditions needed to set a trace are met.
    if (Value = True) and (not CanOpenTrace) then
      raise
        Exception.Create('Cannot open trace when the session or database are closed');

    // prevent other threads from hampering. If other trace objects are opened
    // at the same time, prevent them from changing the current session until
    // we finish with it.
    ActivationLock.Enter;
    try
      FActive := Value;
      // set the current session to be the session we want to trace.
      SaveCurrentSession := Sessions.CurrentSession;
      Sessions.CurrentSession := Session;
      if FActive then
      begin
        // set the trace.
        GetMem(FSMBuffer, smTraceBufSize);
        TraceCallback := TBDECallback.Create(Self, nil, cbTRACE,
          FSMBuffer, smTraceBufSize, SqlTraceCallBack, True);
        // Set the trace Flags to the database
        FDatabase.TraceFlags := TraceOptions;
      end
      else
      begin
        // release the trace.
        FreeMem(FSMBuffer, smTraceBufSize);
        TraceCallback.Free;
      end;
      // restore the current session to the saved session.
      Sessions.CurrentSession := SaveCurrentSession;
    finally
      ActivationLock.Leave;
    end;
  end;
end;

procedure TInternalSQLMonitor.SetDatabase(const Value: TDatabase);
begin
  if FDatabase <> Value then
  begin
    if Active then
      Active := False;
    if Assigned(FDatabase) then
      FDatabase.RemoveFreeNotification(Self);
    FDatabase := Value;
    if Assigned(FDatabase) then
      FDatabase.FreeNotification(Self);
  end;
end;

procedure TInternalSQLMonitor.SetOnSQLTraceEvent(
  const Value: TSQLTraceEvent);
begin
  FOnSQLTraceEvent := Value;
end;

procedure TInternalSQLMonitor.SetSession(const Value: TSession);
begin
  if FSession <> Value then
  begin
    if Active then
      Active := False;
    if Assigned(FSession) then
      FSession.RemoveFreeNotification(Self);
    FSession := Value;
    if Assigned(FSession) then
      FSession.FreeNotification(Self);
    if (FDatabase <> nil) and (FDatabase.Session <> FSession) then
      FDatabase := nil;
  end;
end;

procedure TInternalSQLMonitor.SetTraceOptions(const Value: TTraceFlags);
begin
  if FTraceOptions <> Value then
  begin
    FTraceOptions := Value;
    if Active then
      FDatabase.TraceFlags := Value;
  end;
end;

function TInternalSQLMonitor.SqlTraceCallBack(CBInfo: Pointer): CBRType;
var
  Data: Pointer;
  S: string;
begin
  try
    if Assigned(FOnSQLTraceEvent) then
    begin
      Data := @PTraceDesc(CBInfo).pszTrace;
      SetLength(S, StrLen(Data));
      StrCopy(PChar(S), Data);
      FOnSQLTraceEvent(Self, S);
    end;
  except
  end;
  Result := cbrUSEDEF;
end;

procedure TInternalSQLMonitor.ReplaceComponent(var Reference: TComponent;
  const Value: TComponent);
begin
  if Assigned(Value) then
    Reference.RemoveFreeNotification(Self);
  Reference := Value;
  if Assigned(Reference) then
    Value.FreeNotification(Self);
end;

procedure TInternalSQLMonitor.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
  begin
    if (AComponent = FDatabase) then
      Database := nil;
    if (AComponent = FSession) then
      Session := nil;
  end;
end;

initialization

finalization
  if ActivationLock <> nil then
    FreeAndNil(ActivationLock);

end.

Check if the PC is connected to the Internet

Problem/Question/Abstract:

I just want to know a better way for checking an internet connection. One possible way is just to try to connect to a server with a TClientSocket or something like that. I can make this in a time interval. Is there a registry value or something like that which is changed if the computer goes online?

Answer:

Solve 1:

uses
  wininet

function Connected: boolean;
var
  flags: DWORD;
begin
  Flags := INTERNET_CONNECTION_MODEM or INTERNET_CONNECTION_LAN or
    INTERNET_CONNECTION_PROXY or INTERNET_CONNECTION_MODEM_BUSY;
  result := InternetGetConnectedState(@Flags, 0);
end;


Solve 2:

function TestIsOnline(var IPAddress: string): Boolean;
type
  TaPInAddr = array[0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: array[0..63] of Char;
  i: Integer;
  GInitData: TWSAData;
  IP: string;
begin
{$IFDEF OFFLINETEST}
  IPAddress := '127.0.0.1';
  Result := True;
{$ELSE}
  WSAStartup($101, GInitData);
  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(Buffer);
  if phe = nil then
    Exit;
  pPtr := PaPInAddr(phe^.h_addr_list);
  i := 0;
  while pPtr^[i] <> nil do
  begin
    IP := inet_ntoa(pptr^[i]^);
    Inc(i)
  end;
  WSACleanup;
  Result := (IP <> '') and (IP <> '127.0.0.1');
  if Result then
    IPAddress := IP
  else
    IPAddress := '';
{$ENDIF}
end;


Solve 3:

I use this with Delphi 6, but I think it works too with Delphi 2:

Other connection Value are

INTERNET_CONNECTION_MODEM = 1;
INTERNET_CONNECTION_LAN = 2;
INTERNET_CONNECTION_PROXY = 4;
INTERNET_CONNECTION_MODEM_BUSY = 8;

unit InternetConnected;

interface

uses
  Windows;

const
  INTERNET_CONNECTION_LAN = 2;

function InternetGetConnectedState(lpdwFlags: LPDWORD; dwReserved: DWORD): BOOL;
  stdcall;

implementation

uses
  SysUtils;

var
  winetdllHandle: THandle = 0;

const
  winetdll = 'wininet.dll';

function InternetGetConnectedState(lpdwFlags: LPDWORD; dwReserved: DWORD): BOOL;
  stdcall;
var
  fn_InternetGetConnectedState: function(lpdwFlags: LPDWORD; dwReserved: DWORD):
  BOOL; stdcall;
begin
  if (winetdllHandle = 0) then
    winetdllHandle := SafeLoadLibrary(winetdll);
  if (winetdllHandle <> 0) then
  begin
    @fn_InternetGetConnectedState := GetProcAddress(winetdllHandle,
      'InternetGetConnectedState');
    if (@fn_InternetGetConnectedState <> nil) then
      Result := fn_InternetGetConnectedState(lpdwFlags, dwReserved)
    else
      raise Exception.Create('Unable to locate function InternetGetConnectedState
        in library' + winetdll);
  end
  else
    raise Exception.Create('Unable to load library ' + winetdll);
end;

initialization

finalization
  try
    if (winetdllHandle <> 0) then
      FreeLibrary(winetdllHandle);
  except
  end;

end.


Solve 4:

function FuncAvail(VLibraryname, VFunctionname: string; var VPointer: pointer):
  boolean;
//
// this function check if VFunctionname exists in VLibraryname
//
var
  Vlib: tHandle;
begin
  Result := false;
  if LoadLibrary(PChar(VLibraryname)) = 0 then
    exit;
  Vlib := GetModuleHandle(PChar(VLibraryname));
  if Vlib <> 0 then
  begin
    VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
    if VPointer <> nil then
      Result := true;
  end;
end;

Code Button1 on a Form1:

procedure TForm1.Button1Click(Sender: TObject);
//
// Call shell32.dll for highter Win98
//       else call url.dll
//
var
  InetIsOffline: function(dwFlags: DWORD): BOOL; stdcall;
begin
  if FuncAvail('url.dll', 'InetIsOffline', @InetIsOffline) then
    if InetIsOffLine(0) then
      ShowMessage('Not connected')
    else
      ShowMessage('Connected!');
end;

What's left of Delphi in Delphi 8?

Problem/Question/Abstract:

What's new in Delphi 8 and what do developers have to consider when migrating from Delphi 7 (or lower) to Delphi 8 (.NET)?

Answer:

The IDE itself differs a lot from previous Delphi versions and looks a bit like Visual Studio .NET. Although the menus have not changed and all "old" shortcuts work, the Object Inspector, the Project Manager and the Component Palette and even the design of the Help did change a lot.

There are two possibilities to create applications with Delphi 8 - VCL Forms Applications and Win Forms Applications. Both create IML (intermediate language code) and are .NET Applications, which means that they can only be deployed on a computer with the .NET framework installed.

VCL Forms Applications

A VCL Forms Applications have - at a first glance - most in common with a normal Delphi application. You will find known VCL components and the structure of your units is very familiar. Borland tries to hide the .NET framework from the programmer as far as it is possible.

The first (visual) point you come across is the References-Node in the Project Manager. It contains the dependencies of your application from existing .NET components.  In an empty project they are by default: System.Data.dll, System.dll,
System.Drawing.dll and System.XML.dll. As soon as you drag a component (e.g. a button) to your form the following references will be added to your project: Borland.Delphi.dll, Borland.Vcl.dll and Borland VclRtl.dll.

This is the first point you come in contact with the .NET framework and its dogma of namespaces. The unit concept of Delphi is represented by the namespace concept of the .NET framework. In Delphi each class is referenced by its file (unit) &#8211; in the .NET environment each class is identified by its namespace (a unique string divided by dots). Therefore the dlls are named e.g. Borland.Vcl.dll, which means that from now on dots are allowed in unit names: e.g. unit Borland.Vcl.Forms.

To be able to work with the "old" VCL components Borland moved them (partially) to the .NET framework, wich means that the VCL components are based on pure .NET components (e.g. TPersistent = System.MarshalByRefObject, TObject = System.Object or Exception = System.Exception) whenever it was possible - in all other cases they included Win32 API calls (unmanaged code in the eyes of .NET). But that also means that your VCL applications are platform dependent while pure .NET Applications are not (theoretically).

The next difference is that forms are no longer saved in a .dfm file. In VCL Applications the file has the extension .nfm, in Winforms Applications there is no file - the code for generating the form is within the unit file.

Win Forms Applications

The structure of your units within Win Forms Applications is quite different from those in VCL Forms Applications. The differences start in the uses-clause, where .NET components (namespaces) are referenced. All .NET components start with the namespace System.* whereas namespaces of the Borland VCL components begin with Borland.*.

uses
System.Drawing, System.Collections, System.ComponentModel,
System.Windows.Forms, System.Data;

Additionally there are code segments that are under the control of the form designer, because all information for the design is within the unit (no more in an extra .pas file).
In the type definition:

type
TWinForm = class(System.Windows.Forms.Form)
{$REGION 'Designer controlled code:'}
strict private
Components: System.ComponentModel.Container;
procedure InitializeComponent;
{$ENDREGION}
strict protected
procedure Dispose(Disposing: Boolean); override;
private
{ Private-Deklarationen }
public
constructor Create;
end;

The procedure InitializeComponent holds all information about the visual design of the form. This procedure is called in the constructor of the unit.

procedure TWinForm.InitializeComponent;
begin
Self.Components := System.ComponentModel.Container.Create;
Self.Size := System.Drawing.Size.Create(300, 300);
Self.Text := 'WinForm';
end;

constructor TWinForm.Create;
begin
inherited Create;
InitializeComponent;
//
// TODO: Add own constructor code after the call of InitializeComponent.
//
end;

The .NET framework "renamed" the destructor to Dispose, and there is also code added automatically by the designer to this procedure.

procedure TWinForm.Dispose(Disposing: Boolean);
begin
if Disposing then
begin
if Components <> nil then
Components.Dispose();
end;
inherited Dispose(Disposing);
end;

Examples for differences between VCL Forms Applications and Win Forms Applications

In Win Forms Applications you might have different components from these in VCL Forms Applications. But the differences are quite small because the designer of the .NET framework components and the designer of the VCL components is the same person. Learning how to use the .NET framework merely means learning how to use the components and their properties and events - and that&#8217;s not
very difficult for a Delphi programmer.

E.g. difference of TButton (VCL component) and Button (.NET component)

Button1: TButton;
Button1.Caption := 'Hello World';

Button1: System.Windows.Forms.Button;
Button1.Text := 'Hello World';

An other benefit of Win Forms Applications is that you can have multipe event handlers for one event. The default (designed) event handler is created in the procedure InitializeComponents e.g.:

Self.Button1.Location := System.Drawing.Point.Create(104, 72);
{  ... }
Include(Self.Button1.Click, Self.Button1_Click);

But you can add even more components by calling the Include procedure like:

Include(Button1.Click, Self.MyButtonClick);

The same procedure (Include) is available in VCL Forms Applications, too, but the event handler called with the last Include call is always executed.

General Differences

Migrating from Delphi to the .NET Framework means to lose control over the object lifecycle (the .NET Framework has a garbage collector) and the code execution (you create intermediate language which is compiled at runtime with the JIT). But on the other hand you get new benefits/new features from the .NET Framework itself and you work with the latest Windows technology (the next Windows OS - Longhorn - will be totally based on .NET) - and all Delphi programmers build Windows applications. In my opinion these benefits only take effect if you build Win Forms Application.

Theoretically with VCL Forms Applications it is possible to move existing Delphi applications to the .NET Framework. I don't think that this will work for most applications, for I don't think that there are many applications built with the common Delphi VCL components

Looking at Win Forms components the .NET Framework shows its details. To develop such applications you have to learn using the framework - which is easy for a Delphi programmer - and a few new techniques (e.g. multiple event handlers). You keep your favorite programming language and additional Borland components (microsoft independent data providers e.g. for Interbase or DB2).

Additionally Borland integrated UML support for designing classes named ECO (BoldSoft under Delphi 7). The components for ECO give you the possibility to treat your objects like relational data - e.g. displaying properties of all instances of a class in a grid.

Conclusion

To answer the heading question of this article "What's left of Delphi in Delphi 8?" we must look differently at VCL Applications and Win Forms Applications. With VCL Applications Borland tried to make the move from traditional Windows programming to .NET programming as easy as possible for the developer in providing many known and common components, techniques and structures. So, looking at VCL Forms Applications, I would say that Delphi 8 has much in common with Delphi - on the surface.

Whats left overall is the programming language (object Pascal) and its whole structure, a "microsoft-independent" product and Borland&#8217;s aim of building and providing a wide range of components (like ECO, Component One or providers for other databases).

...delete a file permanently?

Problem/Question/Abstract:

delete a file permanently?

Answer:


If you want to get rid of a file normally you just delete it.
But someone else can undelete it if the file hasn't been wiped correctly.
For security purposes, to insure that certain files are permanently
gone, the WipeFile procedure writes over the data in the file with
random characters and then erases it.

Wenn man eine Datei nicht mehr braucht, l�scht man sie einfach.
Aber jemand anders kann die Datei wieder herstellen, wenn sie
nicht "richtig" gel�scht wurde.
Aus Sicherheitsgr�nden, um sicherzustellen, dass eine Datei permanent
gel�scht wird, �berschreibt die WipeFile Prozedur eine Datei mit
Zufalls-Zeichen und l�scht sie anschliessend.
}

procedure WipeFile(FileName: string);
var
buffer: array [0..4095] of Byte;
max, n: LongInt;
i: Integer;
fs: TFileStream;

procedure RandomizeBuffer;
var
i: Integer;
begin
for i := Low(buffer) to High(buffer) do
buffer[i] := Random(256);
end;
begin
fs := TFilestream.Create(FileName, fmOpenReadWrite or fmShareExclusive);
try
for i := 1 to 3 do
begin
RandomizeBuffer;
max := fs.Size;
fs.Position := 0;
while max > 0 do
begin
if max > SizeOf(buffer) then
n := SizeOf(buffer)
else
n := max;
fs.Write(Buffer, n);
max := max - n;
end;
FlushFileBuffers(fs.Handle);
end;
finally
fs.Free;
end;
Deletefile(FileName);
end;

Split and freeze rows and columns in Excel

Problem/Question/Abstract:

How to split and freeze rows and columns in Excel

Answer:

{ ... }
ExcelApplication1.Connect;
ExcelApplication1.Workbooks.Add(Null, 0);
ExcelApplication1.ActiveWindow.SplitColumn := 5;
ExcelApplication1.ActiveWindow.SplitRow := 10;
ExcelApplication1.ActiveWindow.FreezePanes := True;
{ ...}

How to create a TRichEdit with a tiled background

Problem/Question/Abstract:

Does anyone know how to use a tiled picture as the background for a TRichEdit control?

Answer:

For a standard TRichEdit there seems to be no way to make it transparent or paint its background with a tiled bitmap. But there is a workaround if you're using the Win2000 operating system. There you can make your control transparent by setting the WS_EX_LAYERED constant to the window extended style and then calling the SetLayeredWindowAttributes Win API function.

The example listed below is a TRichEdit control with a DrawStyle property. Depending on its value, the control will have a transparent background or will draw itself with an alpha transparency.

{ ... }
type
  TDrawStyle = (ds_Transparent, ds_NotDistinctly, dsNormal);

  MyTransparentRichEdit = class(TRichEdit)
  protected
    FDrawStyle: TDrawStyle;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetDrawStyle(AValue: TDrawStyle);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property DrawStyle: TDrawStyle read FDrawStyle write SetDrawStyle;
  end;

  { ... }

constructor MyTransparentRichEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDrawStyle := dsNormal;
end;

procedure MyTransparentRichEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if not (csDesigning in ComponentState) then
  begin
    Params.Style := Params.Style or WS_POPUP;
    Params.ExStyle := Params.ExStyle + WS_EX_LAYERED;
  end;
end;

procedure MyTransparentRichEdit.CreateWnd;
var
  XPoint: TPoint;
begin
  if not (csDesigning in ComponentState) then
  begin
    XPoint := TWinControl(Owner).ClientToScreen(POINT(Left, Top));
    Left := XPoint.X;
    Top := XPoint.Y;
  end;
  inherited CreateWnd;
  case FDrawStyle of
    ds_Transparent:
      SetLayeredWindowAttributes(Handle, ColorToRGB(Color), 255, LWA_COLORKEY);
    ds_NotDistinctly:
      SetLayeredWindowAttributes(Handle, 0, 150, LWA_ALPHA);
  end;
end;

procedure MyTransparentRichEdit.SetDrawStyle(AValue: TDrawStyle);
begin
  if FDrawStyle <> AValue then
  begin
    FDrawStyle := AValue;
    RecreateWnd;
  end;
end;

How to determine if a TListBox has a scrollbar

Problem/Question/Abstract:

I'm trying to ensure that a TListBox is wide enough to hold the items in it. However, I see no method for determining if a scroll bar exists, and if so how wide it is.

Answer:

procedure TForm1.FormShow(Sender: TObject);
var
  LBStyle: Longint;
begin
  LBStyle := GetWindowLong(ListBox1.Handle, GWL_STYLE);
  if (LBStyle and WS_VSCROLL) <> 0 then
    ShowMessage(' ScrollBar visible, its width is ' + IntToStr(GetSystemMetrics(SM_CYVSCROLL))
      + ' pixels ')
  else
    ShowMessage('ScrollBar not visible');
end;

Adjust the column width in a TStringGrid to fit the widest text in a cell

Problem/Question/Abstract:

In the column of a TStringGrid, how do I assign as ColWidth the widest text inside its corresponding cells?

Answer:

You measure the text using the TStringGrid's canvas:

procedure SetGridColumnWidths(Grid: TStringGrid; const Columns: array of Integer);
const
  DEFBORDER = 8;
var
  max, temp, i, n: Integer;
begin
  with Grid do
  begin
    Canvas.Font := Font;
    for n := Low(Columns) to High(Columns) do
    begin
      max := 0;
      for i := 0 to RowCount - 1 do
      begin
        temp := Canvas.TextWidth(Cells[Columns[n], i]) + DEFBORDER;
        if temp > max then
          max := temp;
      end;
      if max > 0 then
        ColWidths[Columns[n]] := max;
    end;
  end;
end;

Use this like:

SetGridColumnWidths(stringgrid1, [1, 4]);

This would adjust the widths of columns 1 and 4 to fit the contents.

How to load HTML pages from a resource file into a TWebBrowser

Problem/Question/Abstract:

How I can save HTML pages, including *.jpg and *.gif images, into a resource file? Finally all of this stuff will be inside one compiled application. The canvas for my HTML pages will be a TWebBrowser.

Answer:

MY_HTMLFILE.RC contents: MY_HTMLFILE 23 "my_htmlfile.html"
Compiled using BRCC32 to MY_HTMLFILE.RES.

Do not ask me what the 23 resource identifier is, I got it from the MS web site.

To load into a TWebBrowser from a resource:

procedure TForm1.Button1Click(Sender: TObject);
var
  Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
  WebBrowser1.Navigate('res://' + Application.ExeName + '/MY_HTMLFILE', Flags,
    TargetFrameName, PostData, Headers);
end;

Highlight an entire row in a TStringGrid

Problem/Question/Abstract:

Using Delphi 4 and a TStringGrid component: How do I highlight the entire row in the grid where the cursor is currently? In other words, if the user clicks their mouse cursor on row 3, I want the entire row 3 to be highlighted pale yellow. When they then move the cursor to row 6, I want row 3 to revert back to white, and then have the entire row 6 turn pale yellow. Please note that I must be able to also edit the contents of any cell in the highlighted row.

Answer:

You can achieve this fairly easily with a combination of handlers for the OnSelectCell and OndrawCell events of the grid:

type
  TGridCracker = class(TStringGrid);
  {required to access protected method InvalidateRow}

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
begin
  with TGridCracker(Sender as TStringGrid) do
  begin
    InvalidateRow(Row);
    InvalidateRow(aRow);
  end;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  grid: TStringGrid;
begin
  if gdFixed in State then
    Exit;
  grid := Sender as TStringGrid;
  if grid.Row = aRow then
  begin
    with Grid.Canvas.Brush do
    begin
      Color := $C0FFFF; {pale yellow}
      Style := bsSolid;
    end;
    grid.Canvas.FillRect(Rect);
    grid.Canvas.Font.Color := clBlack;
    grid.Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, grid.Cells[acol, arow]);
    Grid.Canvas.Brush := grid.Brush;
  end;
end;

Check if the mouse is over a tab of a TTabControl

Problem/Question/Abstract:

I try to determine if the mouse is just over a tab of a TTabControl using GetHitTestInfoAt(). This returns htOnItem if the mouse is over the tab and if it's not. How do I have to approach this issue?

Answer:

Probably, the problem is in the routine which calls GetHitTestInfoAt, since I've tried to check this method and all seemed to work fine. I was calling it in the form's and tabcontrols's OnMouseMove events:

procedure TForm1.TabControl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  XHitTests: THitTests;
begin
  XHitTests := TabControl1.GetHitTestInfoAt(X, Y);
  if htOnItem in XHitTests then
    ShowMessage('OnItem');
end;

Also, you can try to call Win API macro TabCtrl_HitTest directly, in order to determine which tab, if any, is over the cursor. Here's an example:

procedure TForm1.TabControl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  XHitTestInfo: TTCHitTestInfo;
  XIndex: integer;
begin
  XHitTestInfo.pt := POINT(X, Y);
  XIndex := TabCtrl_HitTest(TabControl1.Handle, @XHitTestInfo);
  if XHitTestInfo.flags in [TCHT_ONITEM] then
    ShowMessage('OnItem ' + TabControl1.Tabs[XIndex])
  else if XHitTestInfo.flags in [TCHT_ONITEMICON] then
    ShowMessage('OnIcon ' + TabControl1.Tabs[XIndex])
  else if XHitTestInfo.flags in [TCHT_ONITEMLABEL] then
    ShowMessage('OnLabel ' + TabControl1.Tabs[XIndex]);
end;

Adding an AVI in your EXE File

Problem/Question/Abstract:

Adding an AVI in your EXE File

Answer:

In Notepad type or some other simple text editor type:

MyAvi AVI "some.avi"

or

100 AVI "some.avi"

depending on how you want to reference the identifier.  You will want to know whether it is referenced by a resource name or a resource ID when you write the code to play the AVI.

Save the file with a .RC extension

You will be using the Animate Component to play the file, therefore the same rules apply, like no sound can be with the AVI.

Use Borland's Resource Compiler: BRCC32.EXE to convert the file to a .RES file.  At the dos prompt type the following:

brcc32 myfile.rc

This is some code to play an animation using the Resource Name:

Animate.ResHandle := 0;
Animate.ResName := 'MyAvi';
Animate.Active := True;

To stop an animation, call the Stop method.

Place the following code to add your resource file into your executable.

{$R MYFILE.RES}

A sample file is listed below of how this would work correctly:

unit AviResU;

interface

uses
  Forms, ComCtrls, StdCtrls, Classes, Controls;

type
  TForm1 = class(TForm)
    PlayBtn: TButton;
    Animate: TAnimate;
    StopBtn: TButton;
    procedure PlayBtnClick(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$R AVIRESRC.RES}

procedure TForm1.PlayBtnClick(Sender: TObject);
begin
  Animate.ResHandle := 0;
  Animate.ResName := 'TurboGuy';
  Animate.Active := True;
  PlayBtn.Enabled := False;
  StopBtn.Enabled := True;
end;

procedure TForm1.StopBtnClick(Sender: TObject);
begin
  Animate.Stop;
  PlayBtn.Enabled := True;
  StopBtn.Enabled := False;
end;

end.

How to change the font size when printing a TRichEdit

Problem/Question/Abstract:

I am using a TRichEdit in my application that shows text in a 10 point character size. I would like to print it using a size of 13. How can I change the printing size?

Answer:

If the whole contents of the TRichEdit use the same font size the simplest method would be to simply assign 13 to richedit.font.size, print the bugger and revert the size to 10. One could do this with a hidden TRichEdit control that contains a copy of the text, if the user should not be aware of what is going on.

This method will break as soon as the rich edit control contains formatted text in several font sizes. In this case one can scale the printer canvas by using a custom mapping mode. Unfortunately this means one has to do the printing manually, since the mapping mode can only be set after a BeginDoc and richedit.print will then fail. Here is an example that will print a TRichEdit 1.3 times the original size. It assumes all text will fit onto the first page. If several pages need to be printed the scaling of the printer canvas needs to be redone after each NewPage, since that resets the printer canvas to the default mapping mode!


procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
  richedit_outputarea: TRect;
  printresX, printresY: Integer;
  fmtRange: TFormatRange;
begin
  printer.begindoc;
  try
    r := Rect(1000 div 13, 1000 div 13, Round((Printer.PageWidth - 100) / 1.3),
      Round((Printer.Pageheight - 100) / 1.3));
    SetMapMode(printer.canvas.handle, MM_ANISOTROPIC);
    SetWindowExtEx(printer.canvas.handle, GetDeviceCaps(printer.canvas.handle,
      LOGPIXELSX), GetDeviceCaps(printer.canvas.handle, LOGPIXELSY), nil);
    SetViewportExtEx(printer.canvas.handle, Round(GetDeviceCaps(printer.canvas.handle,
      LOGPIXELSX) * 1.3), Round(GetDeviceCaps(printer.canvas.handle,
      LOGPIXELSY) * 1.3), nil);
    with Printer.Canvas do
    begin
      printresX := Round(GetDeviceCaps(handle, LOGPIXELSX) / 1.3);
      printresY := Round(GetDeviceCaps(handle, LOGPIXELSY) / 1.3);
      {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(r.left * 1440 div printresX, r.top * 1440 div
        printresY, r.right * 1440 div printresX, r.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 * 14400 div 13 div printresX,
        Printer.PageHeight * 14400 div 13 div printresY);
      fmtRange.chrg.cpMin := 0;
      fmtRange.chrg.cpMax := richedit1.GetTextLen - 1;
      {Format the text}
      richedit1.Perform(EM_FORMATRANGE, 1, Longint(@fmtRange));
      {Free cached information}
      richedit1.Perform(EM_FORMATRANGE, 0, 0);
    end;
  finally
    printer.enddoc;
  end;
end;


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 smaller than richedit.gettextLen .

How to detect a mouse click in a polygon region

Problem/Question/Abstract:

I create several regions using CreatePolygonRgn function, passing an array of several points (ex. 4). After that, under some condition, I have to test if the user has clicked inside that region using PtInRegion. Now there are some problems: Sometimes CreatePolygonRgn returns 0 (no region created). Why is that? Under any circumstances I can not get any hits when passing points to PtInRegion.

Answer:

Here is a sample using a dynamic TPoint array:

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
type
  PPointArray = ^TPointArray;
  TPointArray = array[0..MaxInt div SizeOf(TPoint) - 1] of TPoint;
var
  Rgn: HRGN;
  P: PPointArray;
begin
  GetMem(P, SizeOf(TPoint) * 3);
  P[0] := Point(0, 0);
  P[1] := Point(50, 100);
  P[2] := Point(100, 50);
  Rgn := CreatePolygonRgn(P[0], 3, WINDING);
  Canvas.Brush.Color := clRed;
  FillRgn(Canvas.Handle, Rgn, Canvas.Brush.Handle);
  if PtInRegion(Rgn, X, Y) then
    Beep;
  DeleteObject(Rgn);
  FreeMem(P);
end;

More lines in a hint

Problem/Question/Abstract:

More lines in a hint

Answer:

If you want to display more than a one line in the hint of a component, for example of Button1, set it's property ShowHint to true. In the Object Inspector, don't put anything in Button1's hint property. In the FormCreate event handler of the form that contains Button1, add this line:

Button1.Hint := 'First line' + Chr(13) + 'Second line';

How to jump to the contents page of a help file

Problem/Question/Abstract:

How to jump to the contents page of a help file

Answer:

Application.HelpCommand(HELP_CONTENTS, 0);

How to paint a border around text in a TRichEdit

Problem/Question/Abstract:

How to paint a border around text in a TRichEdit

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
begin
  richedit1.perform(EM_GETRECT, 0, lparam(@r));
  Inflaterect(r, -5, -5);
  richedit1.perform(EM_SETRECT, 0, lparam(@r));
end;