Getting System BIOS Date

Here's one, courtesy of one of our readers, Rubem Rocha.

{================================
 The following function will
 retrieve the BIOS date, without 
 built-in assembler or API calls, 
 just Delphi native resources.
 ================================}
function BiosDate: String;
begin
   result := string(pchar(ptr($FFFF5)));
end;

Disabling an Event Handler Once It Has Executed Once

Have you ever wanted to keep an event from firing once it has executed once? Simply set the event handler method to nil in the body of the method. For instance, let's say you want to disable an OnClick for a button once the user has pressed it. Here's the code to do that:

procedure Button1OnClick;
begin
   Button1.OnClick := nil;
end;

Make the Results of a Query Permanent

This tip comes to us by way of one of our readers, Cezar Nechifor. Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can short-circuit this process by making a couple of simple, direct calls to the BDE.

//Make sure you have BDE declared in your uses section
procedure MakePermTable(Qry : TQuery; PermTableName : String);
var
  h  : HDBICur;
  ph : PHDBICur;
begin
  Qry.Prepare;
  Check(dbiQExec(Qry.StmtHandle, ph));
  h := ph^;
  Check(DbiMakePermanent(h, PChar(PermTableName), True));
end;

Create a Right-Aligned Edit Box

HUH?!!! Many of you might think, "Hey! You can't do that unless you use a TMemo. Well, Matt Powell, one of our readers, proved that wrong with such an incredibly simple bit of code that you'll... Forget it, here's component code that I subclassed from TCustomEdit that will give you a right-aligned edit box:

unit AlignedEdit;

interface

uses Messages, Windows, SysUtils, Classes,
     Controls, Forms, Menus, Graphics;

type
  TAlignedEdit = class(TCustomEdit)
  private
    FAlignment : TAlignment;
  protected
    procedure CreateParams(var Params : TCreateParams); override;
  published
    property Alignment : TAlignment read FAlignment
                                    write FAlignment;
  end;

procedure Register;

implementation

{ TAlignedEdit }

procedure TAlignedEdit.CreateParams(var Params: TCreateParams);
const
  Alignments : array[TAlignment] of Integer =
               (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
  inherited CreateParams(Params);
  //Setting this does the alignment
  //Note that the actual alignment will
  //not occur until runtime
  with Params do
    Style := Style AND (NOT 0) OR (ES_MULTILINE)
                   OR (Alignments[FAlignment]);
end;

procedure Register;
begin
  RegisterComponents('BD', [TAlignedEdit]);
end;

end.

It never ceases to amaze me the simple, yet completely elegant solutions that people come up with. Kudos to Matt Powell for passing this along!

Editor Keyboard Shortcut - Column Selection

The Delphi editor is something we all take for granted - I know I do. In past versions of Delphi, the editor lacked features that forced many of us to do as we did with Paradox: Use another editor add-in that provided more editing features. One thing that I use a lot is column selection; that is, instead of selecting an entire block of text in the editor, I only want to select a certain number of columns over several lines. For instance, this is incredibly useful for setting up several arrays with the same element count. There are lots of uses.

Column selection keyboard shorcuts are defined as follows:

There are lots of great editor shortcuts included in the Delphi Editor. For a listing of them, search the Delphi online help for "editor shortcuts." You'll find them as useful as I do!

Preventing a User from Closing a Window Except at Shutdown or Restart

We all know how to prevent a window from closing: Simply write event code for the OnCloseQuery event and set CanClose to False. Once that's done, no matter what a user presses, the window won't close. Here's some code:

procedure TForm1.FormCloseQuery(Sender: TObject; 
                 var CanClose: Boolean);
begin
  CanClose := False;
end;

But what if you wanted to be able to close a window only when you reboot the machine? With the scenario above, that would be impossible. Fortunately though, there is a solution, and it resides in the windows message WM_QUERYENDSESSION.

WM_QUERYENDSESSION is generated by Windows when the OS is resetting: Either at a shutdown or a restart. Using this message, we can set a boolean flag variable and interrogate its value in OnCloseQuery to allow us to close the window and reset the operating system. Look at the unit code below:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCloseQuery(Sender: TObject; 
                      var CanClose: Boolean);
  private
    procedure WMQueryEndSession(var Message : 
                         TWMQueryEndSession); 
    message WM_QUERYENDSESSION;
  public
    WindowsClosing : Boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  WindowsClosing := False;
end;

procedure TForm1.WMQueryEndSession(var Message: 
                 TWMQUERYENDSESSION);
begin
  WindowsClosing := True;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; 
var CanClose: Boolean);
begin
  CanClose := WindowsClosing;
end;

end.

As you can see, I've created a public variable called WindowsClosing. When WM_QUERYENDSESSION fires, it sets the variable to True. Then in OnCloseQuery, CanClose is set to the value of WindowsClosing. Notice that I set WindowsClosing to False in OnCreate. This is purely for initialization purposes to make sure that previous attempts to close the window are foiled.

Some Useful Date Calculation Routines

Ever notice how some date routines are missing from SysUtils? Well as they say, necessity is the mother of invention, I've come up with some date calculation routines that you can include in your own programs that require some date calculations. If you've got any more than this, please feel free to share them!

type TDatePart = (dpYear, dpMonth, dpDay);

{Purpose  : Return a date part.}
function GetDatePart(Date : TDateTime; DatePart : TDatePart) : Word;
var
  D, M, Y : Word;
begin
  //Initialize Result - avoids compiler warning
  Result := 0;
  DecodeDate(Date, Y, M, D);
  case DatePart of
    dpYear  : Result := Y;
    dpMonth : Result := M;
    dpDay   : Result := D;
  end;
end;

{Purpose  : Extracts the date portion of a date time. Useful for
            seeing if two date time values fall on the same day}
function ExtractDatePart(Date : TDateTime) : TDate;
begin
  Result := Int(Date);
end;

{Purpose  : Gets the time portion of a date time. Like ExtractDatePart
            this is useful for comparing times.}
function ExtractTimePart(Date : TDateTime) : TTime;
begin
  Result := Frac(Date);
end;

{Purpose  : Used for determining whether or not a DateTime is
            a weekday.}
function IsWeekday(Day : TDateTime) : Boolean;
begin
  Result := (DayOfWeek(Day) >= 2) AND (DayOfWeek(Day) <= 6);
end;

{Purpose  :  Function returns the date of the relative day of a 
             month/year combo such as the date of the "Third 
             Monday of January." The formal parameters depart a bit 
             from the MS SQL Server Schedule agent constants in that
             the RelativeFactor parameter (Freq_Relative_Interval in 
             MS-SQL), takes integer values from 1 to 5 as opposed to 
             integer values from 2 to the 0th to 2 to the 4th power.

Formal Parameters
=======================================================================================
Year            : Year in question
Month           : Month in question
RelativeFactor  : 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last
Day             : 1 - 7, day starting on Sunday; 8 = Day; 
                  9 = Weekday; 10 = Weekend Day
}
function GetRelativeDate(Year, Month, 
                         RelativeFactor, Day : Integer) : TDateTime;
var
  TempDate : TDateTime;
  DayIndex : Integer;
begin
  TempDate := EncodeDate(Year, Month, 1);
  DayIndex := 0;
  //Now, if you're looking for the last day, just go to the last
  //day of the month, and count backwards until you hit the day
  //you're interested in.
  if (RelativeFactor = 5) then
    begin
      TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]);
      case Day of
        1..7 :
          if (DayOfWeek(TempDate) = Day) then
            Result := TempDate
          else
            begin
              while (DayOfWeek(TempDate) <> Day) do
                TempDate := TempDate - 1;
              Result := TempDate;
            end;
        9  :
          begin
            if IsWeekday(TempDate) then
              Result := TempDate
            else
              begin
                while NOT IsWeekday(TempDate) do
                  TempDate := TempDate - 1;
                Result := TempDate;
              end;
          end;
        10 :
          begin
            if NOT IsWeekday(TempDate) then
              Result := TempDate
            else
              begin
                while IsWeekday(TempDate) do
                  TempDate := TempDate - 1;
                Result := TempDate;
              end;
          end;
      else
        //This only happens if you're going after the very last day of the month
        Result := TempDate;
      end;
    end
  else
    //Otherwise, you have to go through the month day by day until you get
    //to the day you want. Since the relative week is a power of 2, just
    //see if the day exponent is a
    case Day of
      1..7 :
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if (DayOfWeek(TempDate) = Day) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      9 :
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      10 :
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if NOT IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      else
        Result := TempDate + RelativeFactor;
    end;
end;

type
  TDecimalTimeType = (dtSecond, dtMinute, dtHour);

{Purpose  : Returns hours, minutes, or seconds in decimal format for use
            in date time calculations}
function GetDecimalTime(Count : Integer; 
                        DecimalTimeType : TDecimalTimeType) : Double;
const
  Second = 1/86400;
  Minute = 1/1440;
  Hour   = 1/24;
begin
  //Initialize result
  Result := 0;
  case DecimalTimeType of
    dtSecond  : Result := Count * Second;
    dtMinute  : Result := Count * Minute;
    dtHour    : Result := Count * Hour;
  end;
end;

{Purpose  : Converts a MS-style integer time to a TTime}
function IntTimeToTime(Time : Integer) : TTime;
var
  S : String;
begin
  S := IntToStr(Time);
  //String must be 5 or 6 character long
  if (Length(S) < 5) OR (Length(S) > 6) then
    Result := 0
  else
    begin
      if (Length(S) = 5) then //A morning time
        S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2)
      else //Afternoon, evening time
        S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2);
      Result := StrToTime(S);
    end;
end;

Finding a Substring in a TStrings

The IndexOf function in TStrings is great because it lets you quickly get the index of Item that holds the string in question. Unfortunately, it doesn't work for sub-strings. In that case, I've put together a neat little function called IndexOfSubString where you pass in the TStrings descendant you want to search on and a search value, and it'll return the index. Check it out:

{Purpose  : Binary search algorithm for a 
            TStrings object. Finds the first
            occurence of any substring within 
            a TStrings object or descendant}
function IndexOfSubString(List : TStrings; 
                   SubString : String) : Integer;
var
  I,
  LowIdx,
  HighIdx : Integer;
  Found : boolean;
begin
  Found := false;
  Result := -1;
  {This type of search uses the first half 
   of the TStrings list, so initialize the 
   LowIdx and HighIdx to the first and approximate
   half of the list, respectively.}
  LowIdx := 0;
  HighIdx := List.Count div 2;

  {Note that Found and the LowIdx are used 
   as conditionals. It's obvious why Found 
   is used, but less apparent why LowIdx is 
   used instead of HighIdx. The reason for 
   this is that the way I've set it up here, 
   HighIdx will never exceed (List.Count - 2), 
   whereas LowIdx can equal (List.Count - 1) 
   by nature of the assignment
   if Found remains false after the for loop.}
  while not Found and (LowIdx < (List.Count - 1)) do
  begin
    for I := LowIdx to HighIdx do
      if (Pos(SubString, List[I]) > 0) and 
         not Found then
      begin
        Found := true;
        Result := I;
      end;

    if not Found then
    begin
      LowIdx := HighIdx + 1;
      HighIdx := HighIdx + 
                ((List.Count - HighIdx) div 2);
    end;
  end;
end;

function TForm1.IndexOfSubStr(List: TStrings; SubString: string): Integer; 
var 
  Index: integer; 
begin 
  Result := -1;
  if List.Count = 0 then
    exit; 
  SubString := UpperCase(SubString); 
  for Index := 0 to List.Count - 1 do 
    if Pos(SubString, UpperCase(List[Index])) > 0 then 
      begin 
        Result := Index; 
        break; 
      end; 
end; 

Accessing OnUpClick and OnDownClick of TSpinEdit

This one comes from our Forum SysOp, Chris Bray!

I have just answered a question for another Forum which I had to research quite carefully, and as it relates to compound components (wrapper components if you prefer) I thought the answer might be relevant to the Tips section.

The questioner wanted to access the OnUpClick and OnDownClick events of the SpinButton which is part of the SpinEdit component from the samples page of the pallette.

My answer was as follows:

You have two choices:  either create your own component surfacing the OnUpClick or
OnDownClick properties, or call the OnUpClick property of the updown button on the
SpinEdit.
Assuming you will not want to create your own component, sample code to access the
button from a form follows:

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, 
  Controls, Forms, Dialogs, StdCtrls, Spin;

type
  TForm1 = class(TForm)
    SpinEdit1: TSpinEdit;

    procedure FormCreate(Sender: TObject);
  public
    procedure OnButtonUpClick(Sender: TObject);
end;

var
  Form1: TForm1;

implementation

  {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  SpinEdit1.Button.OnUpClick := OnButtonUpClick;
end;

procedure TForm1.OnButtonUpClick(Sender: TObject);
begin
  MessageDlg('Up Button was clicked.', mtInformation,
    [mbOk], 0);
end;

end.

To expand the example, simply add additional procedures for the DownClick and any other
properties you wish to surface at runtime.  Note that the source code for the spin
edit is provided in the Pro and Client Server versions of Delphi, and should be located in
the Source folder in a file called Spin.pas.

A Note from Brendan: You might be wondering about what Chris did here and why does it work? Put simply, all events are method pointers, or more fundamentally, procedural types. A procedural type is Delphi type that is defined as a function or procedure that can be assigned to variables or passed to other procedures or functions as arguments. For example, the following is an example of procedural type:

type
  TExtendedFunction = function(A, B : Extended) : Extended;

With that in mind, we can define a variable to be of type TExtendedFunction, then assign a function to it to "assign" it a value:

function MyExtendedFunction(A, B : Extended) : Extended;

var
  F : TExtendedFunction;

begin
  F := MyExtendedFunction;

...

//Now "use" F
  F(23.100, 4.00234);
  

Method pointers, like events, differ from procedural pointers only with respect to how they're declared. If TExtendedFunction were a method pointer, the declaration would be followed by of object to indicate that the function belongs to an instance of an object. 

Okay, now what does that have to do with the current discussion? Actually, everything. Since events are essentially variables, we have the freedom in Delphi to re-assign their "values" to something else. What Chris did above was to simply re-assign the OnUpClick of the TSpinEdit to his own "variable definition." In Windows parlance, this is called subclassing. Pretty slick, and it's a good demonstration of the power and flexibility of Delphi.

Be forewarned though, that you shouldn't do this unless you absolutely have to. Most events are surfaced in the Object Inspector at design time (they're published properties), and you can define most of your events there. It's only when events aren't surfaced, or you want to affect different behavior at runtime does this methodology become valid. So use with care!

Re-sizing a JPEG file

JPEG files can be handled easily in Delphi by adding the JPEG unit to the uses clause and then using its methods to manipulate a JPEG image.  However a TJPEGImage does not have a Canvas, so you cannot draw on it, and it does not provide any access to the internal bitmap it uses so you cannot manipulate that.  So how can you change the size of a JPEG graphic?  The following simple code provides the answer by creating a new JPEG file exactly half the size of the original:

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses JPEG;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  Jpeg1, Jpeg2: TJPEGImage;
  TempBitmap: TBitmap;
  CanvasRect: TRect;
begin
  if OpenPictureDialog1.Execute then
    begin
      // Create a Bitmap and two JPEG's
      TempBitmap := TBitmap.Create;
      Jpeg1 := TJPEGImage.Create;
      Jpeg2 := TJPEGImage.Create;
      try
        // Load the picture to shrink into the first Jpeg
        Jpeg1.LoadFromFile(OpenPictureDialog1.FileName);

        // Set the bitmap width to the new size
        TempBitmap.Width := JPeg1.Width div 2;
        TempBitmap.Height := JPeg1.Height div 2;

        // Create a TRect with the canvas co-ordinates
        CanvasRect := Rect(0, 0, TempBitmap.Width, TempBitmap.Height);

        // Draw the JPEG on the Canvas
        MyBitMap.Canvas.StretchDraw(CanvasRect, JPeg1);

        // Assign the bitmap to the second Jpeg
        Jpeg2.Assign(TempBitmap);

        // Save the second Jpeg in a renamed file
        Jpeg2.SaveToFile(ExtractFilePath(OpenPictureDialog1.FileName)+
          'Small '+ExtractFileName(OpenPictureDialog1.FileName));
      finally
        // Tidy up the stuff you created before leaving
        TempBitmap.Free;
        Jpeg1.Free;
        Jpeg2.Free;
      end;
    end;
end;

end.

Although we do not have access to the inner bitmap of the JPEG object,  we can use standard TGraphic methods with it.    Basically all we are doing is drawing the image at the new size and then assigning the resulting bitmap to a new JPEG object. 

If you want to make the new file a different size simply change the size of the intermediate TBitmap.  However, bear in mind that you should always use the same percentage of both height and width of the original in order to maintain the aspect ratio.

Chris Bray.

How do I get the size of a Text File in Delphi?

The FileSize function in Delphi does not work on Text files, and requires the file to be open when the Function is run on binary files. It is actually quite easy to get the size of any file using the FindFirst function, since the SearchRec object contains a wealth of information about the file found. Sample code follows:

{This example requires a form containing a Button, a Label, and an OpenDialog. Clicking the Button and selecting a file will fill the label caption with the File size in MB to two decimal places. For more places or a different format, change the FloatToStrF parameters.}

procedure TForm1.Button1Click(Sender: TObject);
var
  SearchRec: TSearchRec;
begin
  if OpenDialog1.Execute then
    if FindFirst(OpenDialog1.FileName, faAnyFile, SearchRec) = 0 then
      Label1.Caption := FloatToStrF(SearchRec.Size/1048576, ffFixed, 7, 2)+' MB';
  FindClose(SearchRec);
end;

Chris Bray

How do I Delete a File to the Recycle Bin?

This tip was contributed by Dave Johnson who, after searching the net for a delete function finally found one he had written himself some time previously!  A nice little routine, and extremely useful, so thanks to Dave for this one...

function myDeleteFile(Filename : string; ToRecycle : Boolean) : Boolean;
var
  tempFileOp : TSHFileOpStruct;
begin
  if FileExists(Filename) then
  begin
    with tempFileOp do
    begin
      Wnd:=0;
      wFunc:=FO_DELETE;
      pFrom:=pchar(Filename+#0+#0); // Must be double #0 to terminate the string.
                                   // WARNING: Documented, but UNTESTED by me.
                                   // You can use a single #0 to seperate multiple
                                    // files in a single call.
      pTo:=#0+#0; // Prevents Crash in D5 and maybe beyond
      if ToRecycle then
        fFlags:=FOF_FILESONLY or FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT
      else
        fFlags:=FOF_FILESONLY or FOF_NOCONFIRMATION or FOF_SILENT;
      SHFileOperation(tempFileOp);
    end;
  end;
  Result:=not(FileExists(Filename));
end;

How do I make my program open a file specified as a command line parameter?

To do this you need to use two functions - ParamCount and ParamStr.  ParamCount returns the number of command line parameters specified when the program was run.   ParamStr returns the parameter string of a specified parameter.

Basically all you need to do is check to see whether any parameters have been passed, and if so evaluate them.  The format of the parameter(s)  is entirely up to you, and you can produce code to deal with anything from a single parameter to a whole range.

This simple example only allows for a single parameter - a file name - and if a file name is passed the program loads that file when the form is shown.  It requires a single form with a Memo dropped onto it.  Simply put the following code into the form's OnShow event:

procedure TForm1.FormShow(Sender: TObject);
begin
  Memo1.Clear;
  if ParamCount > 0 then
    begin
      case ParamCount of
        1: Memo1.Lines.LoadFromFile(Paramstr(1));
        // allow for other possible parameter counts here
      else
         begin
           ShowMessage('Invalid Parameters');
           Application.Terminate;
         end;
    end;
end;

To prove this code, after compiling the program of course, select Start | Run and enter the following. Make sure that you replace the path of the exe file with the correct path for your machine:

"F:\Borland\Delphi 3\Project1.exe" "c:\windows\win.ini"

This will open the Win.ini file in the memo in the application you created.   Obviously this example could be extended considerably (there is no check to make sure that the file exists, for example) and the parameters could be parsed to determine what should be done with the information.  It does not have to be a file opening command, it could just as easily be configuration information or indeed anything else that you may wish to specify when the program is run.

Chris Bray.

How do I get the text from a Rich Text File (.rtf) without the formatting information?

Usefully, the Lines property of a TRichEdit returns the text alone, without the formatting information.  All that is needed, therefore, is to load the RTF into a RichEdit and then access the Lines to obtain each individual line of information:

procedure TForm1.Button1Click(Sender: TObject);
var
   PlainStrings: TStringList;
begin
  RichEdit1.LoadFromFile('C:\My Documents\Test.rtf');
  PlainStrings := TStringList.Create;
  try
    for i := 0 to RichEdit1.Lines.Count do
      PlainStrings.Add(RichEdit1.Lines[i]);
    PlainStrings.SaveToFile('C:\My Documents\Test.txt');
  finally
    PlainStrings.Free
  end;
end;

Naturally you will need to replace the file names for the LoadFromFile and SaveToFile calls with your own file names, but otherwise - that's all there is to it!

Chris Bray

How do I get the current Windows User and Computer name?

Another useful tip from Simon Clayton, who says:

program Project1;
uses
  Forms,
  Windows, // needed for dWord
  Dialogs, // needed for ShowMessage
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
  buffer : array[0..255] of char;
  size : dword;
begin
  size := 256;
  GetUserName(buffer, size);
  ShowMessage(buffer);
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Simon Clayton

It would be easy to extend Simon's example to add the Computer Name to this check as well, should it be needed.  Rather than emulate Simon's startup check, I have created another version of his code to operate when a button is clicked, to give another view of how it could be used:

procedure TForm1.Button1Click(Sender: TObject);
var
  buffer : array[0..255] of char;
  size : dword;
  UserName: String;
  ComputerName: String;
begin
  size := 256;
  GetUserName(buffer, size);
  UserName := buffer;
  size := MAX_COMPUTERNAME_LENGTH + 1;
  GetComputerName(buffer, size);
  ComputerName := buffer;
  ShowMessage('User Name: '+UserName+' Computer Name: '+ComputerName);
end;

Chris Bray

How do I change the color of the tabs on a PageControl?

This tip from Todd Flickinger...

The example below uses the OnDrawTab event to change the colour of the active Tab and of the Font used:

procedure TForm1.TabControl1DrawTab(Control: TCustomTabControl;
   TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  s:string;
   r:TRect;
begin
  s :=form1.TabControl1.Tabs.Strings[tabindex];
  r := Rect;
  with Control.Canvas do
    begin
      if Active then 
        begin
          Brush.Color := clinfoBK;
          Font.Color := clBlue;
        end;
     Windows.FillRect(Handle,r,Brush.Handle);
     OffsetRect(r, 0, 1);
     DrawText(Handle, PChar(s), Length(s), r, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
  end;
end;

Great stuff, Todd!