## 2010. június 30., szerda

### 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)

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;

## 2010. június 29., kedd

### 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.

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.

## 2010. június 28., hétfő

### 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?

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!

## 2010. június 27., vasárnap

### 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?

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

## 2010. június 26., szombat

### 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?

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.

## 2010. június 25., péntek

### 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.

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:

interface

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

type
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

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;

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
IconID := IconIDs[MsgType];
if IconID <> nil then
begin
with Image1 do
begin
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;
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;

begin
ModalResult := 1;
end;

begin
ModalResult := 2;
end;

begin
ModalResult := 3;
end;

begin
ModalResult := 4;
end;

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;

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
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;

## 2010. június 24., csütörtök

### 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.

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
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
hitem := Node.ItemId;
if value then
State := TVIS_BOLD;
TreeView_SetItem(Node.Handle, TVItem);
end;
end;

## 2010. június 23., szerda

### 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.

It does not work well but you can try this:

unit Unit1;

interface

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

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

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
wnd: HWND;
tries: Integer;
begin
tries := 0;
repeat
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);
MoveWindow(wnd, 0, 0, clientwidth, clientheight, false);
ShowWindow(wnd, SW_SHOW);
SetForegroundWindow(wnd);
end
else
showmessage('Failed');
end;

procedure TForm1.ApplicationEvents1Activate(Sender: TObject);
begin
else
Close;
end;

end.

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

## 2010. június 22., kedd

### 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.

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;

## 2010. június 21., hétfő

### Sort a TStringGrid using the Bubblesort algorithm

Problem/Question/Abstract:

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

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;

## 2010. június 20., vasárnap

### Delphi .NET: Get computer IP address

Problem/Question/Abstract:

How to get the list of the computer IP addresses

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;
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

for count := 0 to length(ipAddr) - 1 do

end.

## 2010. június 19., szombat

### 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.

{ ... }
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;

## 2010. június 18., péntek

### 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.

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;

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

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;
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 := Value;
if Assigned(FDatabase) then
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 := Value;
if Assigned(FSession) then
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 := Value;
if Assigned(Reference) then
end;

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.

## 2010. június 17., csütörtök

### 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?

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:

type
var
phe: PHostEnt;
Buffer: array[0..63] of Char;
i: Integer;
IP: string;
begin
{\$IFDEF OFFLINETEST}
Result := True;
{\$ELSE}
WSAStartup(\$101, GInitData);
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(Buffer);
if phe = nil then
Exit;
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
else
{\$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
if (winetdllHandle <> 0) then
begin
'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;
exit;
Vlib := GetModuleHandle(PChar(VLibraryname));
if Vlib <> 0 then
begin
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;

## 2010. június 16., szerda

### 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)?

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).

## 2010. június 14., hétfő

### ...delete a file permanently?

Problem/Question/Abstract:

delete a file permanently?

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;

## 2010. június 13., vasárnap

### Split and freeze rows and columns in Excel

Problem/Question/Abstract:

How to split and freeze rows and columns in Excel

{ ... }
ExcelApplication1.Connect;
ExcelApplication1.ActiveWindow.SplitColumn := 5;
ExcelApplication1.ActiveWindow.SplitRow := 10;
ExcelApplication1.ActiveWindow.FreezePanes := True;
{ ...}

## 2010. június 12., szombat

### 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?

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;

## 2010. június 11., péntek

### 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.

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;

## 2010. június 10., csütörtök

### 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?

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.

## 2010. június 9., szerda

### 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.

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
begin
WebBrowser1.Navigate('res://' + Application.ExeName + '/MY_HTMLFILE', Flags,
end;

## 2010. június 8., kedd

### 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.

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;

## 2010. június 7., hétfő

### 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?

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;

## 2010. június 6., vasárnap

Problem/Question/Abstract:

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.

{\$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.

## 2010. június 5., szombat

### 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?

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 .

## 2010. június 4., péntek

### 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.

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;

## 2010. június 3., csütörtök

### More lines in a hint

Problem/Question/Abstract:

More lines in a hint

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';

## 2010. június 2., szerda

### How to jump to the contents page of a help file

Problem/Question/Abstract:

Application.HelpCommand(HELP_CONTENTS, 0);

## 2010. június 1., kedd

### How to paint a border around text in a TRichEdit

Problem/Question/Abstract:

How to paint a border around text in a TRichEdit