A Class for Get Tokens, Parse Strings, Count Words, Search Tokens

Problem/Question/Abstract:

A general way for get tokens, parse strings, count words and search for a specific token on a string.

Answer:

There are many functions and ways for get a token on a string. I have written a general class for handle tokens and parse strings.

The class is named as TToken. I want to describe it with some examples.

var
  xTk: TToken;
  i: Integer;
  s: string;
  b: Boolean;
begin
  xTk := TToken.Create;

  {//////////
  the class has some variables:
  TEXT contains the string to handle
  SEPS contains the set of characters that separate tokens
  }

  xTk.Text := 'Here is my example. Contains commas, dots and spaces.';
  xTk.Seps := [' ', ',', '.'];

  {//////////
  with the method COUNT I can count the number of tokens.
  I can use it on two ways, I can call the method and the variable NUMTOKENS save the number of tokens or I can assign the method to a memory variable. Here is the example of the two ways.
  }

  i := xTk.Count;
  ShowMessage(IntToStr(i));
  ShowMessage(IntToStr(xTk.NumTokens));

  {//////////
  When I want to search all tokens on a sequential way Im going to use the methods FIRT and NEXT. Im going to use two Variables: MORETOKENS and LASTTOKEN. MORETOKENS is a boolean variabale that indicates that after I execute the First or Next method I have a token that is saved on the LASTTOKEN variable
  }

  xTk.First;
  while xTk.MoreTokens do
  begin
    ShowMessage(xTk.LastToken);
    xTk.Next;
  end;

  {//////////
  I can assign the Firt and Next method to a memory variable and I can use the variable NOTOKEN that contains the negative value of MORETOKENS
  }

  s := xTk.First;
  while not xTk.NoToken do
  begin
    ShowMessage(s);
    s := xTk.Next;
  end;

  {//////////
  I can search for a specific token with the SEARCH method
  }

  b := xTk.Search('IS');
  if b then
    ShowMessage('Found it')
  else
    ShowMessage('Not found it');

  b := xTk.Search('YOUR');
  if b then
    ShowMessage('Found it')
  else
    ShowMessage('Not found it');

  xTk.Free;

end;

The class is:

unit UToken;

{
Class for handle Tokens
Author: Alejandro Castro
}

interface

uses SysUtils;

type
  TToken = class(Tobject)
  private
    xCharText: string;
    function xGetToken(xText: string): string;
  public
    Seps: set of char; // Separators
    Text: string; // string to handle
    LastToken: string; // token readed with first or next method
    NoToken: Boolean; // flag that indicate that there ARENT more tokens
    MoreTokens: Boolean; // flag that indicate that there ARE more tokens
    NumTokens: Integer; // no of tokens on Text

    constructor Create;
    function Count: Integer; // count the number of tokens
    function First: string; // Find the First Token
    function Next: string; // Find the Next Token
    function Search(TokSearch: string): Boolean; // Search for a specific token

  end;

implementation

constructor TToken.Create;
begin
  Seps := [];
  Text := '';
  xCharText := '';
  NoToken := True;
  MoreTokens := False;
  LastToken := '';
end;

function TToken.Count: Integer;
var
  i, xLen: Integer;
  xFlag: Boolean;
begin
  NumTokens := 0;
  xLen := length(Text);
  i := 1;
  xFlag := False;
  while (i <= xLen) and (xLen <> 0) do
  begin
    if (Text[i] in Seps) then
      xFlag := False
    else
    begin
      if (not xFlag) then
      begin
        xFlag := True;
        inc(NumTokens);
      end;
    end;
    inc(i);
  end;
  Result := NumTokens;
end;

function TToken.Next: string;
begin
  Result := xGetToken(xCharText);
  LastToken := Result;
  if Result = '' then
    NoToken := True
  else
    NoToken := False;
  MoreTokens := not NoToken;
end;

function TToken.First: string;
begin

  Result := xGetToken(Text);
  LastToken := Result;
  if Result = '' then
    NoToken := True
  else
    NoToken := False;
  MoreTokens := not NoToken;

end;

function TToken.xGetToken(xText: string): string;
var
  i, xLen: Integer;
  xFlag, xAgain: Boolean;
begin
  Result := '';
  xLen := length(xText);
  i := 1;
  xFlag := False;
  xAgain := True;
  while (i <= xLen) and (xLen <> 0) and (xAgain) do
  begin
    if (xText[i] in Seps) then
    begin
      xAgain := (xAgain and (not xFlag));
      xFlag := False
    end
    else
    begin
      if (not xFlag) then
      begin
        xFlag := True;
        xAgain := true;
      end;
      Result := Result + xText[i];
    end;
    inc(i);
  end;
  xCharText := copy(xText, i, xLen);
end;

function TToken.Search(TokSearch: string): Boolean;
var
  xAgain: Boolean;
begin
  Result := False;
  xAgain := True;
  First;
  while (not noToken) and (xAgain) do
  begin
    if UpperCase(LastToken) = UpperCase(TokSearch) then
    begin
      Result := true;
      xAgain := False;
    end;
    Next;
  end;
end;
end.


Component Download: http://www.baltsoft.com/files/dkb/attachment/UToken.zip

Get computer name and user

Problem/Question/Abstract:

This article presents a code snipet which shows how to get the current user and the computer name.

Answer:

Obviously this is not a complete program, but you can use the Windows API calls GetUserName and GetComputerName as shown below.

uses
  windows...

var
  u: array[0..127] of Char;
  c: array[0..127] of Char;
  user: string;
  computer: string;
  sz: dword;
  begin
    sz := SizeOf(u);
    GetUserName(u, sz);

    sz := SizeOf(c);
    GetComputerName(c, sz);

    user := u;
    computer := c;
  end;

A VCL Component to print labels

Problem/Question/Abstract:

A simple component to print labels

Answer:

A simple VCL componet to print labels.

A few days ago I wrote an article about a class to print labels (3156)

With the help of Mike Heydon we have rewritten the class to convert it to a component and easier to use.

What do we need to print labels ?

The size (height and width) of every label.
The number of labels per row.
The top and left margin.
The kind of measure: pixels,inches or millimetres.
The font to use.
And of course data to fill the labels.

With the next component we can do it very simply, Im going to use a pseudo-code to explain the use of the component TPrtLabels:

begin
  PrtLabels.Measurements := plmInches; // plmMillimetres or plmPixels
  PrtLabels.Font := FontDialog1.Font; // I get the font from a Font Dialog
  PrtLabels.LabelsPerRow := 4; // 4 Label per row
  PrtLabels.LabelWidth := 3; // only an example
  PrtLabels.LabelHeight := 1.5; // only an example
  PrtLabels.LeftMargin := 0; // only an example
  PrtLabels.TopMargin := 0; // only an example
  PrtLabels.Open; // open the printer
  Table.First // Im going to read a customer table
  while not Table.Eof do
  begin
    PrtLabels.Add(["Name", "Street", "City"]); // I fill the content of every label
    Table.Next;
  end;
  PrtLabels.Close; // close the printer and print any label pending on the buffer
  PrtLabels.Free;
end;

We need only 3 methods: Open, Add and Close.

The properties that we need are:

Measurements(plmInches, plmMillimetres or plmPixels)
LabelsPerRow
LabelWidth
LabelHeight
LeftMargin
TopMargin
Font

The componet:

unit ULabels2;
{
VCL Component to print labels

Authors:
Mike Heydon
Alejandro Castro

Date: 1/Abr/2002
}

interface
uses SysUtils, Windows, Classes, Graphics, Printers;

type
  TPrtLabelMeasures = (plmPixels, plmInches, plmMillimetres);

  TPrtLabels = class(TComponent)
  private
    FFont: TFont;
    FMeasurements: TPrtLabelMeasures;
    FTopMargin,
      FLeftMargin,
      FLabelHeight,
      FLabelWidth: double; // Selected Measure
    FLabelLines,
      FLabelsPerRow: word; // ABS Pixels
    TopMarginPx,
      LeftMarginPx,
      LabelHeightPx,
      LabelWidthPx: integer;
    TabStops: array of word;
    DataArr: array of array of string;
    CurrLab: word;
    procedure SetFont(Value: TFont);
    procedure IniDataArr;
    procedure FlushBuffer;
    procedure SetDataLength(xLabelLines, xLabelsPerRow: Word);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Add(LabLines: array of string);
    procedure Close;
    procedure Open;
  published
    property Font: TFont read FFont write SetFont;
    property Measurements: TPrtLabelMeasures read FMeasurements write FMeasurements;
    property LabelWidth: double read FLabelWidth write FLabelWidth;
    property LabelHeight: double read FLabelHeight write FLabelHeight;
    property TopMargin: double read FTopMargin write FTopMargin;
    property LeftMargin: double read FLeftMargin write FLeftMargin;
    property LabelsPerRow: word read FLabelsPerRow write FLabelsPerRow;
    //    property LabelLines : word read FLabelLines write FLabelLines;
  end;

procedure Register;

implementation

const
  MMCONV = 25.4;

procedure Register;
begin
  RegisterComponents('Mah2001', [TPrtLabels]);
end;

constructor TPrtLabels.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FMeasurements := plmInches;
  FLabelHeight := 0.0;
  FLabelWidth := 0.0;
  FTopMargin := 0.0;
  FLeftMargin := 0.0;
  FLabelsPerRow := 1;
  FLabelLines := 1;
  FFont := TFont.Create;
  TabStops := nil;
  DataArr := nil;
end;

destructor TPrtLabels.Destroy;
begin
  FFont.Free;
  TabStops := nil;
  DataArr := nil;

  inherited Destroy;
end;

procedure TPrtLabels.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TPrtLabels.SetDataLength(xLabelLines, xLabelsPerRow: Word);
begin
  if (xLabelLines + xLabelsPerRow) > 1 then
    SetLength(DataArr, xLabelLines, xLabelsPerRow);
end;

procedure TPrtLabels.Open;
var
  PixPerInX, PixPerInY, i: integer;
begin
  if (FLabelsPerRow + FLabelLines) > 1 then
  begin
    SetLength(TabStops, FLabelsPerRow);
    SetDataLength(FLabelLines, FLabelsPerRow);
    //    SetLength(DataArr,FLabelLines,FLabelsPerRow);
    Printer.Canvas.Font.Assign(FFont);
    Printer.BeginDoc;
    PixPerInX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
    PixPerInY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

    case FMeasurements of
      plmInches:
        begin
          LabelWidthPx := trunc(LabelWidth * PixPerInX);
          LabelHeightPx := trunc(LabelHeight * PixPerInY);
          TopMarginPx := trunc(TopMargin * PixPerInX);
          LeftMarginPx := trunc(LeftMargin * PixPerInY);
        end;

      plmMillimetres:
        begin
          LabelWidthPx := trunc(LabelWidth * PixPerInX * MMCONV);
          LabelHeightPx := trunc(LabelHeight * PixPerInY * MMCONV);
          TopMarginPx := trunc(TopMargin * PixPerInX * MMCONV);
          LeftMarginPx := trunc(LeftMargin * PixPerInY * MMCONV);
        end;

      plmPixels:
        begin
          LabelWidthPx := trunc(LabelWidth);
          LabelHeightPx := trunc(LabelHeight);
          TopMarginPx := trunc(TopMargin);
          LeftMarginPx := trunc(LeftMargin);
        end;
    end;

    for i := 0 to FLabelsPerRow - 1 do
      TabStops[i] := LeftMarginPx + (LabelWidthPx * i);
    IniDataArr;
  end;
end;

procedure TPrtLabels.Close;
begin
  if (FLabelsPerRow + FLabelLines) > 1 then
  begin
    FlushBuffer;
    Printer.EndDoc;
    TabStops := nil;
    DataArr := nil;
  end;
end;

procedure TPrtLabels.IniDataArr;
var
  i, ii: integer;
begin
  CurrLab := 0;
  for i := 0 to High(DataArr) do // FLabelLines - 1 do
    for ii := 0 to High(DataArr[i]) do //FLabelsPerRow do
      DataArr[i, ii] := '';
end;

procedure TPrtLabels.FlushBuffer;
var
  i, ii, y, SaveY: integer;
begin
  if CurrLab > 0 then
  begin
    if Printer.Canvas.PenPos.Y = 0 then
      Printer.Canvas.MoveTo(0, TopMarginPx);
    y := Printer.Canvas.PenPos.Y;
    SaveY := y;

    for i := 0 to fLabelLines - 1 do
    begin
      for ii := 0 to fLabelsPerRow - 1 do
      begin
        Printer.Canvas.TextOut(TabStops[ii], y, DataArr[i, ii]);
      end;

      inc(y, Printer.Canvas.Textheight('X'));
    end;

    if (LabelHeightPx + SaveY) + LabelHeightPx > Printer.PageHeight then
      Printer.NewPage
    else
      Printer.Canvas.MoveTo(0, LabelHeightPx + SaveY);

    IniDataArr;
  end;
end;

procedure TPrtLabels.Add(LabLines: array of string);
var
  i: integer;
begin

  if Length(LabLines) > FLabelLines then
  begin
    FLabelLines := Length(LabLines);
    SetDataLength(fLabelLines, fLabelsPerRow);
  end;

  inc(CurrLab);

  for i := 0 to high(LabLines) do
    if i <= FLabelLines - 1 then
      DataArr[i, CurrLab - 1] := LabLines[i];

  if CurrLab = FLabelsPerRow then
    FlushBuffer;
end;

end.


Component Download: http://www.baltsoft.com/files/dkb/attachment/ULabels2.zip

Example of a Windows Service, with a thread

Problem/Question/Abstract:

Delphi 5&6 has a template project for services, but it is incomplete. This example builds on that template and completes the service. It also shows how to start a thread that beeps every 2 seconds. You can use this as a base when developing servers as services.

Answer:

This example shows how to use the service template in delphi, taking it a step further and making a complete example. The source for this is included in the ntservice.zip file.

Coded under D6, but works for D5 if you copy the source parts after creating a template service.

Below are all the source files listed one by one.

To test the source, create a Service with Delphi, and pase these sources on top of the automatically generated source.

program NTService;

uses
  SvcMgr,
  NTServiceMain in 'Units\NTServiceMain.pas' {ExampleService: TService},
  NTServiceThread in 'Units\NTServiceThread.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TExampleService, ExampleService);
  Application.Run;
end.

{*
  Windows Service Template
  ========================

  Author          Kim Sandell
                  emali: kim.sandell@nsftele.com

  Disclaimer      Freeware. Use and abuse at your own risk.

  Description     A Windows NT Service skeleton with a thread.
                  Works in WinNT 4.0, Win 2K, and Win XP Pro

                  The NTServiceThread.pas contains the actual
                  thread that is started under the service.
                  When you want to code a service, put the code in
                  its Execute() method.

  Example         To test the service, install it into the SCM with
                  the InstallService.bat file. The go to the Service
                  Control Manager and start the service.

                  The Interval can be set to execute the Example Beeping
                  every x seconds. It depends on the application if it
                  needs a inerval or not.

  Notes           This example has the service startup options set to
                  MANUAL. If you want to make a service that starts
                  automatically with windows then you need to change this.
                  BE CAREFULT ! If your application hangs when running as a
                  service THERE IS NO WAY to terminate the application.

  History     Description
  ==========  ============================================================
  24.09.2002  Initial version

*}
unit NTServiceMain;

interface

uses
  Windows, Messages, SysUtils, Classes, SvcMgr,
  NTServiceThread;

type
  TExampleService = class(TService)
    procedure ServiceExecute(Sender: TService);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServicePause(Sender: TService; var Paused: Boolean);
    procedure ServiceContinue(Sender: TService; var Continued: Boolean);
    procedure ServiceShutdown(Sender: TService);
  private
    { Private declarations }
    fServicePri: Integer;
    fThreadPri: Integer;

    { Internal Start & Stop methods }
    function _StartThread(ThreadPri: Integer): Boolean;
    function _StopThread: Boolean;
  public
    { Public declarations }
    NTServiceThread: TNTServiceThread;

    function GetServiceController: TServiceController; override;
  end;

var
  ExampleService: TExampleService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  ExampleService.Controller(CtrlCode);
end;

function TExampleService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TExampleService.ServiceExecute(Sender: TService);
begin
  { Loop while service is active in SCM }
  while not Terminated do
  begin
    { Process Service Requests }
    ServiceThread.ProcessRequests(False);
    { Allow system some time }
    Sleep(1);
  end;
end;

procedure TExampleService.ServiceStart(Sender: TService; var Started: Boolean);
begin
  { Default Values }
  Started := False;
  fServicePri := NORMAL_PRIORITY_CLASS;
  fThreadPri := Integer(tpLower);

  { Set the Service Priority }
  case fServicePri of
    0: SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
    1: SetPriorityClass(GetCurrentProcess, NORMAL_PRIORITY_CLASS);
    2: SetPriorityClass(GetCurrentProcess, HIGH_PRIORITY_CLASS);
    3: SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  end;

  { Attempt to start the thread, if it fails free it }
  if _StartThread(fThreadPri) then
  begin
    { Signal success back }
    Started := True;
  end
  else
  begin
    { Signal Error back }
    Started := False;
    { Stop all activity }
    _StopThread;
  end;
end;

procedure TExampleService.ServiceStop(Sender: TService;
  var Stopped: Boolean);
begin
  { Try to stop the thread - signal results back }
  Stopped := _StopThread;
end;

procedure TExampleService.ServicePause(Sender: TService; var Paused: Boolean);
begin
  { Attempt to PAUSE the thread }
  if Assigned(NTServiceThread) and (not NTServiceThread.Suspended) then
  begin
    { Suspend the thread }
    NTServiceThread.Suspend;
    { Return results }
    Paused := (NTServiceThread.Suspended = True);
  end
  else
    Paused := False;
end;

procedure TExampleService.ServiceContinue(Sender: TService;
  var Continued: Boolean);
begin
  { Attempt to RESUME the thread }
  if Assigned(NTServiceThread) and (NTServiceThread.Suspended) then
  begin
    { Suspend the thread }
    if NTServiceThread.Suspended then
      NTServiceThread.Resume;
    { Return results }
    Continued := (NTServiceThread.Suspended = False);
  end
  else
    Continued := False;
end;

procedure TExampleService.ServiceShutdown(Sender: TService);
begin
  { Attempt to STOP (Terminate) the thread }
  _StopThread;
end;

function TExampleService._StartThread(ThreadPri: Integer): Boolean;
begin
  { Default result }
  Result := False;
  { Create Thread and Set Default Values }
  if not Assigned(NTServiceThread) then
  try
    { Create the Thread object }
    NTServiceThread := TNTServiceThread.Create(True);
    { Set the Thread Priority }
    case ThreadPri of
      0: NTServiceThread.Priority := tpIdle;
      1: NTServiceThread.Priority := tpLowest;
      2: NTServiceThread.Priority := tpLower;
      3: NTServiceThread.Priority := tpNormal;
      4: NTServiceThread.Priority := tpHigher;
      5: NTServiceThread.Priority := tpHighest;
    end;
    { Set the Execution Interval of the Thread }
    NTServiceThread.Interval := 2;

    { Start the Thread }
    NTServiceThread.Resume;
    { Return success }
    if not NTServiceThread.Suspended then
      Result := True;
  except
    on E: Exception do
      ; // TODO: Exception Logging
  end;
end;

function TExampleService._StopThread: Boolean;
begin
  { Default result }
  Result := False;
  { Stop and Free Thread }
  if Assigned(NTServiceThread) then
  try
    { Terminate thread }
    NTServiceThread.Terminate;
    { If it is suspended - Restart it }
    if NTServiceThread.Suspended then
      NTServiceThread.Resume;
    { Wait for it to finish }
    NTServiceThread.WaitFor;
    { Free & NIL it }
    NTServiceThread.Free;
    NTServiceThread := nil;
    { Return results }
    Result := True;
  except
    on E: Exception do
      ; // TODO: Exception Logging
  end
  else
  begin
    { Return success - Nothing was ever started ! }
    Result := True;
  end;
end;

end.

{*
  A Windows NT Service Thread
  ===========================

  Author          Kim Sandell
                  Email: kim.sandell@nsftele.com
*}
unit NTServiceThread;

interface

uses
  Windows, Messages, SysUtils, Classes;

type
  TNTServiceThread = class(TThread)
  private
    { Private declarations }
  public
    { Public declarations }
    Interval: Integer;

    procedure Execute; override;
  published
    { Published declarations }
  end;

implementation

{ TNTServiceThread }

procedure TNTServiceThread.Execute;
var
  TimeOut: Integer;
begin
  { Do NOT free on termination - The Serivce frees the Thread }
  FreeOnTerminate := False;

  { Set Interval }
  TimeOut := Interval * 4;

  { Main Loop }
  try
    while not Terminated do
    begin
      { Decrement timeout }
      Dec(TimeOut);

      if (TimeOut = 0) then
      begin
        { Reset timer }
        TimeOut := Interval * 4;

        { Beep once per x seconds }
        Beep;
      end;
      { Wait 1/4th of a second }
      Sleep(250);
    end;
  except
    on E: Exception do
      ; // TODO: Exception logging...
  end;
  { Terminate the Thread - This signals Terminated=True }
  Terminate;
end;

end.

A component to prevent your form to be placed out of visible area

Problem/Question/Abstract:

Just put this component on your form and set as active and your form will not be moved out of screen visible area.

Answer:

unit ScreenSnap;

interface

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

type
  TNoOutScreen =
    class(TComponent)
  private
    OldWndProc: Pointer;
    NewWndProc: Pointer;
    FDistance: Integer;
    procedure NewWndMethod(var Msg: TMessage);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Distance: Integer read FDistance write FDistance default 30;
  end;

procedure Register;

implementation

constructor TNoOutScreen.Create(AOwner: TComponent);
begin
  inherited;
  if (not (csDesigning in ComponentState)) then
  begin
    NewWndProc := MakeObjectInstance(NewWndMethod);
    OldWndProc := Pointer(SetWindowLong(TForm(Owner).Handle, gwl_WndProc,
      LongInt(NewWndProc)));
  end
  else
  begin
    NewWndProc := nil;
    OldWndProc := nil;
  end;
  FDistance := 30;
end;

destructor TNoOutScreen.Destroy;
begin
  if (Assigned(NewWndProc)) then
    FreeObjectInstance(NewWndProc);
  inherited;
end;

procedure TNoOutScreen.NewWndMethod(var Msg: TMessage);
var
  Pabd: APPBARDATA;
  ScreenWidth: Integer;
  ScreenHeight: Integer;
  ScreenRect: TRect;
  TaskBarRect: TRect;
begin
  if (Msg.Msg = WM_EXITSIZEMOVE) then
  begin
    Pabd.cbSize := SizeOf(APPBARDATA);
    SHAppBarMessage(ABM_GETTASKBARPOS, Pabd);
    ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
    ScreenHeight := GetSystemMetrics(SM_CYSCREEN);
    ScreenRect := Rect(0, 0, ScreenWidth, ScreenHeight);
    TaskBarRect := Pabd.rc;
    if ((TaskBarRect.Left = -2) and (TaskBarRect.Bottom = (ScreenHeight + 2)) and
      (TaskBarRect.Right = (ScreenWidth + 2))) then
      ScreenRect.Bottom := TaskBarRect.Top
    else if ((TaskBarRect.Top = -2) and (TaskBarRect.Left = -2) and (TaskBarRect.Right
      = (ScreenWidth + 2))) then
      ScreenRect.Top := TaskBarRect.Bottom
    else if ((TaskBarRect.Left = -2) and (TaskBarRect.Top = -2) and
                 (TaskBarRect.Bottom = (ScreenHeight + 2))) then
      ScreenRect.Left := TaskBarRect.Right
    else if ((TaskBarRect.Right = (ScreenWidth + 2)) and (TaskBarRect.Top = -2) and
      (TaskBarRect.Bottom = (ScreenHeight + 2))) then
      ScreenRect.Right := TaskBarRect.Left;
    if (TForm(Owner).Left < (ScreenRect.Left + FDistance)) then
      TForm(Owner).Left := ScreenRect.Left;
    if (TForm(Owner).Top < (ScreenRect.Top + FDistance)) then
      TForm(Owner).Top := ScreenRect.Top;
    if ((TForm(Owner).Left + TForm(Owner).Width) > (ScreenRect.Right - FDistance))
      then
      TForm(Owner).Left := ScreenRect.Right - TForm(Owner).Width;
    if ((TForm(Owner).Top + TForm(Owner).Height) > (ScreenRect.Bottom - FDistance))
      then
      TForm(Owner).Top := ScreenRect.Bottom - TForm(Owner).Height;
  end;
  Msg.Result := CallWindowProc(OldWndProc, TForm(Owner).Handle, Msg.Msg, Msg.WParam,
    Msg.LParam);
end;

procedure Register;
begin
  RegisterComponents('Christian', [TNoOutScreen]);
end;

end.

Formating integers

Problem/Question/Abstract:

How do I format a integer into a nice format. Eg. 1,200,000

Answer:

Lots of people don't realise this, but FormatFloat can be used to format integers as well:

i := 1200000;
s := FormatFloat('#,0', i);
Memo1.lines.add(s);

This will display a formated version of 1200000. If you live in the USA you will get "1,200,000". Depending on the local settings of your Windows environment you might get "1.200.000" (eg you live in The Netherlands).  You can also make different formats for negative numbers. Just checkout the Help on FormatFloat.

An easy pulsing effect

Problem/Question/Abstract:

How can I create a pulsing effect on a color in my program easily?

Answer:

It is easy because you only have to set a TDateTime variable at the beginning of your program, and then you are able to use pulsing colors like in QBASIC the color codes after 16. But it's finer.
So I show a program code. On Form1 there is a Timer1. Its interval is 50. Then the code should look like:

unit uPulse;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
{the .interval should be about 50, if it's high,
the framerate will be low}
private
{ Private declarations }
public
{ Public declarations }
end;

TFadingMode = (fmFlash, fmPulse); {Two types of the effect.}

var
Form1: TForm1;
Starting_Time: TDateTime;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
Starting_Time := Now;
end;

function TimeElapsed(Since: TDateTime): integer;
var
h, m, s, ms: Word;
begin
DecodeTime(Now - Since, h, m, s, ms);
Result := m * 60000 + s * 1000 + ms;
{
It may be: Result:=h*3600000+m*60000+s*1000+ms;
But not necessary.
}
end;

procedure TForm1.Timer1Timer(Sender: TObject);
const
PulsingRate = 500;
FadingMode = fmPulse;
{Modify these to get different results}
var
f: Byte; {the formula}
begin
case FadingMode of
{fades from color1 to color2 then turns back to color1}
fmFlash: f := 255 * (TimeElapsed(Starting_Time) mod PulsingRate) div PulsingRate;
{fades from color1 to color2 then fades back to color1}
fmPulse: f := 255 * Abs(TimeElapsed(Starting_Time) mod PulsingRate * 2 -
PulsingRate) div PulsingRate;
end;
{Then set the color with the RGB function}
Canvas.Brush.Color := RGB(f, 0, 0);
{
currently modifying RED, but you can get other colors like:
RGB(f,0,0) -     black->red
RGB(255-f,0,0) - red->black
RGB(0,f,0) -     black->green
RGB(50,150,f) -  green->blue
RGB(f,f,0) -     yellow->black
RGB(f,f,f) -     white->black
}
{then do the job... paint something etc.}
Canvas.Ellipse(50, 50, 150, 150);
end;

end.

It's good because you can refresh the screen anytimes, the result depends only on the time elapsed. You don't have to declare a lot of variables.
And you can use the formula everywhere where is a color used. Just refresh it often!

MySQl experiences

Problem/Question/Abstract:

Some tips on using MySQl with delphi

Answer:

I&#8217;ve used Delphi (versions 4 & 5) with MySql versions 3.23 and higher for a few years and did one project which involved a data import utility reading data into the database and then displaying graphs on website using ISAPI dlls written in Delphi.

First tip- get yourself a good front end; my-manager from ems-tech.com or sqlyog are both excellent and simplify development enormously. Both cost but will repay the effort in next to no time.

Next download the zeos libraries from http://www.zeoslib.net/http://www.zeoslib.net/ - these are superb- though take a little getting used to. Installing is a bit of a pig-with 6 different folders needed that have to be added to the environment library path. The zeos libraries aren&#8217;t just for mysql BTW, other databases are supported as well.

Next, I&#8217;ve found it simplest to keep the appropriate libmysql.dll in the same folder as the Delphi application. At one point during my import utility development, things started going very strange &#8211; every time I tried to connect to a database, I got really odd access violations. A quick search determined I had 4 different libmysqls on the pc and my app was picking up the wrong one. It doesn&#8217;t help that utilities like sqlyog or my-manager install their own versions &#8211; this makes it easy to get confused. I ended up removing all but the newest libmysql dll and then having to reinstall sqlyog etc but that fixed it, - the website, code and sqlyog etc all worked fine- so if you get funny a/vs check your lib dlls.

I&#8217;ve always tended to develop using classes and that&#8217;s true with zeos- less hassle than wotrking with components on forms or data modules. The code accompanying this shows how to create a class- I call it TgvDB. This handles all the initialisation of properties etc and lets you create a TGVdb instance dynamically. This creates a Connection and query and simplifies returning data or running queries &#8211; if your variable is db1 then

NumRecords := db1.Select('select * from table'); // Return all records
Db1.exec('Update table2 set column1 = 0 ');

In all rows, sets column 1 = 0.

for returned data, use the queryrec property to get at the values.

while not db.queryrec.eof do
begin
value := db.queryrec.fields('column1').asstring;
db.queryrec.next;
end;

Code:

unit mysql;

interface

uses
ZConnection, Db, ZAbstractRODataset, ZAbstractDataset, ZDataset, zdbcIntfs, classes;

type
TGvDb = class
private
FDataBase: TZConnection;
FDB: TZQuery;
FLastError: string;

public
constructor Create; overload;
destructor Destroy; override;
function Select(SQL: string): integer;
function Exec(sql: string): boolean;
function LockTables(tablename: string): boolean;
procedure UnLockTables;
property QueryRec: TzQuery read FDB;
property LastError: string read FLastError write FLastError;
end;

function NewQuery: Tgvdb;

implementation

uses Sysutils;

function NewQuery: Tgvdb;
begin
Result := Tgvdb.Create;
end;

{ TGvDb }

function TGvDb.LockTables(tablename: string): boolean;
begin
fdb.Sql.Text := 'LOCK TABLES ' + Tablename;
try
fdb.ExecSql;
Result := True;
except
Result := False;
end;
end;

procedure TGvDb.UnlockTables;
begin
fdb.Sql.Text := 'UNLOCK TABLES';
fdb.ExecSql;
end;

constructor TGvDb.Create; // Used to create new cities
begin
FDatabase := TZConnection.Create(nil);
FDatabase.HostName := 'localhost';
FDatabase.User := '';
FDatabase.Password := '';
Fdatabase.Protocol := 'mysql';
FDatabase.Database := 'mysql';
FDatabase.Catalog := 'mysql';
FDatabase.Port := 3306;
Fdb := TZQuery.Create(nil);
Fdb.Connection := FDatabase;
end;

destructor TGvDb.Destroy;
begin
FDb.Free;
FDatabase.Free;
end;

function TGvDb.Exec(sql: string): boolean;
begin
Fdb.Active := false;
Fdb.Sql.Text := SQL;
try
Fdb.ExecSql;
FLastError := '';
result := true;
except
on E: Exception do
begin
Result := False;
FLastError := E.Message;
end;
end;
end;

function TGvDb.Select(SQL: string): integer;
begin
Fdb.Active := false;
Fdb.Sql.Text := SQL;
try
Fdb.Open;
FLastError := '';
result := Fdb.RecordCount;
except
on E: Exception do
begin
Result := 0;
FLastError := E.Message;
end;
end;
end;

end.

Get all table names in a database

Problem/Question/Abstract:

at some point along the way, you will need to get all the table names from some database, you look at the help... not much help... you have to use an Alias and you don't want one... pretty simple anyway...

Answer:

the example you find at the Delphi 5 help:

MyStringList := TStringList.Create;
try
Session.GetTableNames('DBDEMOS', '*.db', False, False, MyStringList);
{ Add the table names to a list box }
ListBox1.Items = MyStringList;
finally
MyStringList.Free;
end;

which would've been easier to write just:

Session.GetTableNames('DBDEMOS', '*.db', False, False, ListBox1.Items);

here they use the Session component and an Alias 'DBDEMOS', but you don't have an Alias and you don't want to bother in creating one for the installation program, you wanna use just the typical database component...
then all  you have to do is this:
drop your database component in the form, fill all the needed properties:
databasename, Drivername, etc and make this call:

database1.Session.GetTableNames(database1.DatabaseName, '', False, False,
ListBox1.Items)

here we use the embeded 'session' component and your own database name

both solutions give you the list of all the tables in ListBox1.Items, only in the second case you don't have an alias and you can directly specify the location of the database you need
important:

set the third parameter to 'false' if you're not using Paradox or dBASE databases, and
set the fourth parameter to 'false' if you want only the table names

...finally an example of this... I had a situation where I had this database with a variable number of tables on it... and I had to open all of them, I had a maximum of 5 tables, so I created an array of TTables (yes, an array)
Const MAX_TABLES=4

{.. }
database1: TDatabase;
Private
TableCount: Integer;
AllMyTables: array[0..MAX_TABLES] of TTable;

//then I created the tables at runtime

for X := 0 to MAX_TABLES do
begin
AllMyTables[X] := TTable.Create(Form1);
AllMyTables[X].database := database1
end

//then called the function to retrieve all the table names without using an
//Alias:

database1.Session.GetTableNames(database1.DatabaseName, '', False, False,
ListBox1.Items)

//Now I can open all the tables =o)
TableCount := ListBox1.Items.Count;
//note we save the 'TableCount' so later we
//can use it to iterate through the tables in the array
for X := 0 to TableCount do
begin
AllMyTables[X].TableName := ListBox1.Items[X];
AllMyTables[X].Active := True
end;

//of course, at the end don't forget to free the tables, since we created them
//dinamically
for X := 0 to MAX_TABLES do
begin
AllMyTables[X].Active := False;
AllMyTables[X].Free
end

of course I missed some optimizations or stuff, but I just wanted to give you the idea and an example so... I hope it is useful.

Convert long IP addresses to short ones and vice versa

Problem/Question/Abstract:

How to convert long IP addresses to short ones and vice versa

Answer:

IP converting (long/ short). Example: 34753784563 instead of 193.234.22.12, used by different applications like IRC (DCC algorithm):

Convert long IP addresses to short ones:

function shortIP(const s: string): string;
var
Ip: int64;
a, b, c, d: Byte;
begin
IP := StrToInt64(s);
a := (IP and $FF000000) shr 24;
b := (IP and $00FF0000) shr 16;
c := (IP and $0000FF00) shr 8;
d := (IP and $000000FF);
Result := Format('%d.%d.%d.%d', [a, b, c, d]);
end;

Convert short IP addresses to long ones:

function LongIP(IP: string): string;
var
IPaddr: array[1..4] of Word;
Temp: string;
Res: DWord;
I: Integer;
begin
Temp := IP + '.';
for I := 1 to 4 do
begin
try
IPaddr[i] := StrToInt(copy(Temp, 1, pos('.', Temp) - 1));
Delete(temp, 1, pos('.', Temp));
if (IPaddr[i] > 255) then
raise Exception.Create('');
except
{Check the IP}
result := 'Invalid IP address.';
Exit;
end;
end;
Res := (ipaddr[1] shl 24) + ipaddr[1] + (ipaddr[2] shl 16) + ipaddr[2] +
(ipaddr[3] shl 8) + ipaddr[3] + (ipaddr[4]);
Result := Format('%u', [res]);
end;

Updates with Oracle

Problem/Question/Abstract:

How can I commit the Updates with Oracle 8.0.6 and Delphi 5.0 ? I don't want to use a DBNavigator, but buttons.

Answer:

I would add a new TQuery component to your Databasa module. Call it CommitQuery. Edit the SQL property of CommitQuery by writing 'commit'; in the editor. And change the database alias so that the query will be posted in the right database. Create the ButtonOnClick procedure and add the line CommitQuery.Execute;

Or you can do something like this

Database1.startTransaction;
try
  Somequery.edit;
  // Do someting wityh the query.
  Somequery.post;
  Database1.Commmit;
except
  Database1.Rollback
end;

Center a Form efficiently

Problem/Question/Abstract:

Center a Form efficiently

Answer:

To center a form after having changed its dimensions at run-time,
the poScreenCenter won't do it - it only works when the form is shown.

The following code shows 2 solutions how to handle this "problem":


// this works, but the form will be redrawn two times
// (one redraw for each assignment)
Form1.Left := (Screen.Width div 2) - (Form.Width div 2);
Form1.Top := (Screen.Height div 2) - (Form.Height div 2);

// this is better.. the form is redrawn only once
Form1.SetBounds((Screen.Width - AForm.Width) div 2,
  (Screen.Height - AForm.Height) div 2,
  ATop, Form1.Width, Form1.Height);

How to drag and drop text from a TRichEdit to other components

Problem/Question/Abstract:

I would like to select text in a TRichEdit control, then drag and drop the text on another (non TRichEdit) component (ie. TEdit or TMemo). Simulating this behavior would be fine. The drag- related events are not firing when I drag text, so I assume the drag and drop behavior is embedded in the Windows control. But I don't see any drag-related messages in the Windows SDK online help.

Answer:

I've got a unit "uGenDragDrop", that implements IDropTarget (amongst others), and allows you to easily add OLE Drag and Drop support to any Delphi component (i.e. allow you to drag and drop not only within a Delphi application, but also in and out of Delphi applications).

Here is a snippet of code that implements OLE drop support for a TMemo on a form.

uses
  uGenDragDrop;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DTMemo := TDropTarget.Create(Memo1);
  DTMemo.AddFormat(CF_TEXT, [asComplete], [meGlobMemory]);
end;

procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := TRUE;
end;

procedure TForm1.Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  Memo1.Lines.Add((Source as TStorageMedium).GetText);
end;

Check the BDE version in your application

Problem/Question/Abstract:

Check the BDE version in your application

Answer:

Sometimes you may want to have your application check that the proper BDE version is installed.
Use the following code:

program BDEVersion;

uses
  Forms,
  DB,
  BDE,
  Dialogs,
  SysUtils;

{$R *.RES}

var
  ThisVersion: SYSVersion;
begin
  DbiGetSysVersion(ThisVersion);
  ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
end.

An almost complete include file to detect different versions of Borland compilers

Problem/Question/Abstract:

An almost complete include file to detect different versions of Borland compilers

Answer:

File: Compilers.inc

Include file to determine which compiler is currently being used to build the project/ component. This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). The following symbols are defined:

// COMPILER_1    : Kylix/Delphi/BCB 1.x is the compiler.
// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler.
// COMPILER_2    : Kylix/Delphi 2.x or BCB 1.x is the compiler.
// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler.
// COMPILER_3    : Kylix/Delphi/BCB 3.x is the compiler.
// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler.
// COMPILER_4    : Kylix/Delphi/BCB 4.x is the compiler.
// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler.
// COMPILER_5    : Kylix/Delphi/BCB 5.x is the compiler.
// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler.
// COMPILER_6    : Kylix/Delphi/BCB 6.x is the compiler.
// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler.
// COMPILER_7    : Kylix/Delphi/BCB 7.x is the compiler.
// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler.
//
// Only defined if Windows is the target:
// CPPB        : Any version of BCB is being used.
// CPPB_1      : BCB v1.x is being used.
// CPPB_3      : BCB v3.x is being used.
// CPPB_3_UP   : BCB v3.x or higher is being used.
// CPPB_4      : BCB v4.x is being used.
// CPPB_4_UP   : BCB v4.x or higher is being used.
// CPPB_5      : BCB v5.x is being used.
// CPPB_5_UP   : BCB v5.x or higher is being used.
//
// Only defined if Windows is the target:
// DELPHI      : Any version of Delphi is being used.
// DELPHI_1    : Delphi v1.x is being used.
// DELPHI_2    : Delphi v2.x is being used.
// DELPHI_2_UP : Delphi v2.x or higher is being used.
// DELPHI_3    : Delphi v3.x is being used.
// DELPHI_3_UP : Delphi v3.x or higher is being used.
// DELPHI_4    : Delphi v4.x is being used.
// DELPHI_4_UP : Delphi v4.x or higher is being used.
// DELPHI_5    : Delphi v5.x is being used.
// DELPHI_5_UP : Delphi v5.x or higher is being used.
// DELPHI_6    : Delphi v6.x is being used.
// DELPHI_6_UP : Delphi v6.x or higher is being used.
// DELPHI_7    : Delphi v7.x is being used.
// DELPHI_7_UP : Delphi v7.x or higher is being used.
//
// Only defined if Linux is the target:
// KYLIX       : Any version of Kylix is being used.
// KYLIX_1     : Kylix 1.x is being used.
// KYLIX_1_UP  : Kylix 1.x or higher is being used.

{$IFDEF Win32}
{$IFDEF VER150}
{$DEFINE COMPILER_7}
{$DEFINE DELPHI}
{$DEFINE DELPHI_7}
{$ENDIF}

{$IFDEF VER140}
{$DEFINE COMPILER_6}
{$DEFINE DELPHI}
{$DEFINE DELPHI_6}
{$ENDIF}

{$IFDEF VER130}
{$DEFINE COMPILER_5}
{$IFDEF BCB}
{$DEFINE CPPB}
{$DEFINE CPPB_5}
{$ELSE}
{$DEFINE DELPHI}
{$DEFINE DELPHI_5}
{$ENDIF}
{$ENDIF}

{$IFDEF VER125}
{$DEFINE COMPILER_4}
{$DEFINE CPPB}
{$DEFINE CPPB_4}
{$ENDIF}

{$IFDEF VER120}
{$DEFINE COMPILER_4}
{$DEFINE DELPHI}
{$DEFINE DELPHI_4}
{$ENDIF}

{$IFDEF VER110}
{$DEFINE COMPILER_3}
{$DEFINE CPPB}
{$DEFINE CPPB_3}
{$ENDIF}

{$IFDEF VER100}
{$DEFINE COMPILER_3}
{$DEFINE DELPHI}
{$DEFINE DELPHI_3}
{$ENDIF}

{$IFDEF VER93}
{$DEFINE COMPILER_2} // C_UP_UPB v1 compiler is really v2
{$DEFINE CPPB}
{$DEFINE CPPB_1}
{$ENDIF}

{$IFDEF VER90}
{$DEFINE COMPILER_2}
{$DEFINE DELPHI}
{$DEFINE DELPHI_2}
{$ENDIF}

{$IFDEF VER80}
{$DEFINE COMPILER_1}
{$DEFINE DELPHI}
{$DEFINE DELPHI_1}
{$ENDIF}

{$IFDEF COMPILER_1}
{$DEFINE COMPILER_1_UP}
{$ENDIF}

{$IFDEF COMPILER_2}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$ENDIF}

{$IFDEF COMPILER_3}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$DEFINE COMPILER_3_UP}
{$ENDIF}

{$IFDEF COMPILER_4}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$DEFINE COMPILER_3_UP}
{$DEFINE COMPILER_4_UP}
{$ENDIF}

{$IFDEF COMPILER_5}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$DEFINE COMPILER_3_UP}
{$DEFINE COMPILER_4_UP}
{$DEFINE COMPILER_5_UP}
{$ENDIF}

{$IFDEF COMPILER_6}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$DEFINE COMPILER_3_UP}
{$DEFINE COMPILER_4_UP}
{$DEFINE COMPILER_5_UP}
{$DEFINE COMPILER_6_UP}
{$ENDIF}

{$IFDEF COMPILER_7}
{$DEFINE COMPILER_1_UP}
{$DEFINE COMPILER_2_UP}
{$DEFINE COMPILER_3_UP}
{$DEFINE COMPILER_4_UP}
{$DEFINE COMPILER_5_UP}
{$DEFINE COMPILER_6_UP}
{$DEFINE COMPILER_7_UP}
{$ENDIF}

{$IFDEF DELPHI_2}
{$DEFINE DELPHI_2_UP}
{$ENDIF}

{$IFDEF DELPHI_3}
{$DEFINE DELPHI_2_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}

{$IFDEF DELPHI_4}
{$DEFINE DELPHI_2_UP}
{$DEFINE DELPHI_3_UP}
{$DEFINE DELPHI_4_UP}
{$ENDIF}

{$IFDEF DELPHI_5}
{$DEFINE DELPHI_2_UP}
{$DEFINE DELPHI_3_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_5_UP}
{$ENDIF}

{$IFDEF DELPHI_6}
{$DEFINE DELPHI_2_UP}
{$DEFINE DELPHI_3_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_6_UP}
{$ENDIF}

{$IFDEF DELPHI_7}
{$DEFINE DELPHI_2_UP}
{$DEFINE DELPHI_3_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_7_UP}
{$ENDIF}

{$IFDEF CPPB_3}
{$DEFINE CPPB_3_UP}
{$ENDIF}

{$IFDEF CPPB_4}
{$DEFINE CPPB_3_UP}
{$DEFINE CPPB_4_UP}
{$ENDIF}

{$IFDEF CPPB_5}
{$DEFINE CPPB_3_UP}
{$DEFINE CPPB_4_UP}
{$DEFINE CPPB_5_UP}
{$ENDIF}

{$IFDEF CPPB_3_UP}
// C++ Builder requires this if you use Delphi components in run-time packages.
{$OBJEXPORTALL On}
{$ENDIF}

{$ELSE (not Windows)}
// Linux is the target
{$DEFINE KYLIX}
{$DEFINE KYLIX_1}
{$DEFINE KYLIX_1_UP}
{$ENDIF}

How to send mail in HTML format from a Delphi application

Problem/Question/Abstract:

I would like to create a program which is able to send mail in HTML format. I tested some code but got a 'Connection Failed' message when I attempted to send the mail.

Answer:

You may have to logon to the smtp server via Pop3 first:

var
  oLogon: TNMPop3;
  oMail: TNMSmtp;
begin
  oLogon := TNMPop3.Create(self);
  try
    with oLogon do
    begin
      Host := 'pop.mail.yahoo.com';
      UserID := 'user';
      Password := 'password';
    end;
    oLogon.Connect;
    oLogon.Disconnect;
  finally
    oLogon.Free;
  end;
  oMail := TNMSmtp.Create(self);
  with oMail do
  begin
    try
      Host := 'smtp.mail.yahoo.com';
      Port := 25;
      UserID := 'YourID';
      Connect;
      SubType := mtHTML;
      { set all other properties, e. g. FromName, FromAddress, ReplyTo, Subject, etc }
      PostMessage.FromAddress := 'yourname@yahoo.com';
      PostMessage.FromName := 'YourName';
      PostMessage.Subject := 'My First HTML mail';
      PostMessage.ToAddress.Add('yourname@yahoo.com');
      {Replace [ ] brackets in the following three lines with < > ones}
      PostMessage.Body.Add('[html] [head] [/head]');
      PostMessage.Body.Add('[body] [h1]My 1st html msg[/h1] [/body]');
      PostMessage.Body.Add('[/html]');
      Connect;
      SendMail;
      Disconnect;
    finally
      Free;
    end;
  end;
end;

Create a TPaintBox that can be scrolled by mouse wheel

Problem/Question/Abstract:

I have a TPaintBox that shows part of my bitmap and I would like to be able to scroll by using the mouse wheel, both up and down and all 4 directions. I assume this needs some message handlers, but have no idea of which ones.

Answer:

The WM_MOUSEWHEEL message is sent to the focus window when the mouse wheel is rotated. As far as I know, it's impossible to do this with a TPaintBox as it's a TGraphicControl descendant and can't receive this message. The solution could be to place it in a scrollbox. Then define OnMouseWheelDown and OnMouseWheelUp event handlers to the scroll box and insert a ScrollBy(..) method call. Also, you'll need your scrollbox to receive the focus. And the last thing is to write a CM_HITTEST message handler for the paint box. In the message result return the HTNOWHERE constant. This will force the parent scrollbox to handle mouse messages on its own. Here's an example:

{ ... }
TMyPaintBox = class(TPaintBox)
protected
  procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
end;

{ ... }

procedure TMyPaintBox.CMHitTest(var Message: TCMHitTest);
begin
  Message.Result := Windows.HTNOWHERE;
end;

Here's how scrollbox events handlers can look like

{scrolls content to the right direction}

procedure TForm1.MyScrollBox1MouseWheelDown(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  MyScrollBox1.ScrollBy(5, 0);
end;

{scrolls content to the left}

procedure TForm1.MyScrollBox1MouseWheelUp(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  MyScrollBox1.ScrollBy(-5, 0);
end;

{sets focus to the scrollbox}

procedure TForm1.MyScrollBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  MyScrollBox1.SetFocus;
end;

How to display different icons depending on the screen resolution

Problem/Question/Abstract:

How to display different icons depending on the screen resolution

Answer:

Just check for the current resolution and change the icon handle of the application. Of course, you have to create new icons in your resource. Put this in the project (.DPR) file of your application source:

Application.Initialize;
Application.CreateForm(TForm1, Form1);
case GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of
  640: Application.Icon.Handle := LoadIcon(hInstance, 'ICON640');
  800: Application.Icon.Handle := LoadIcon(hInstance, 'ICON800');
  1024: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1024');
  1280: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1280');
end;
Application.Run;

How to get the font settings as defined in the Windows display properties

Problem/Question/Abstract:

I'm using a TMenuBar control and I would like my menus to be the same size as defined in the Windows display properties. The same goes for the rest of my application. How can I find out what the windows settings for fonts and sizes for menus are?

Answer:

function GetCaptionFont: TFont;
var
  ncMetrics: TNonClientMetrics;
begin
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(TNonClientMetrics), @ncMetrics,
    0);
  Result := TFont.Create;
  Result.Handle := CreateFontIndirect(ncMetrics.lfCaptionFont);
end;

In Windows XP, applications seem to have a concept of a system font. That is, labels and captions seem to appear in another font other than MS Sans Serif. I was wondering if it is possible to detect this font and use it in Delphi applications. Currently, everything seems hard-coded to MS Sans Serif.

procedure GetCaptionFont(afont: TFont);
var
  ncMetrics: TNonClientMetrics;
begin
  assert(assigned(afont));
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS,
    sizeof(TNonClientMetrics), @ncMetrics, 0);
  afont.Handle := CreateFontIndirect(ncMetrics.lfCaptionFont);
end;

The TNonClientMetrics structure also contains information on other fonts used in the non-client area:

lfCaptionFont: Font used in regular captions
lfSmCaptionFont: Font used in small captions
lfMenuFont: Font used in menus
lfStatusFont: Font used in status bars
lfMessageFont: Font used in message boxes

The problem with changing the forms font (and with it all controls that have Parentfont = true) is that it will likely change the size of some controls that autosize depending on fonts, and that can screw up your layout.

How to compare two pf24bit images

Problem/Question/Abstract:

How to compare two pf24bit images

Answer:

The code below compares two pf24bit images and tells you if they are alike or not. It also gives you the lines and pixels that are different:

function Tbilde_form.CompareBitmaps(B1, B2: TBitmap): boolean;
var
  ps1, pr1, ps, pr: PRGBTriple;
  I, J, Bps: Integer;
  tid: TDateTime;

  function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  begin
    Dec(Alignment);
    Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
    Result := Result div 8;
  end;

begin
  tid := now;
  Result := True;
  ps1 := b1.ScanLine[0];
  pr1 := b2.ScanLine[0];
  Bps := BytesPerScanLine(b1.Width, 24, 32);
  for I := 0 to b1.Height - 1 do
  begin
    ps := PRGBTriple(PChar(ps1) - Bps * I);
    pr := PRGBTriple(PChar(pr1) - Bps * I);
    for J := 0 to b1.Width - 1 do
    begin
      if not CompareMem(Pr, Ps, SizeOf(TRGBTriple)) then
      begin
        memo1.lines.Add('Line:' + inttostr(I) + ' point: ' + inttostr(j));
        Result := False;
        {Break}
      end;
      Inc(pr);
      Inc(ps)
    end;
    {if not Result then Break}
  end;
  tid_label.caption := timetostr(now - tid);
end;

Check whether a user has a shortcut installed

Problem/Question/Abstract:

Check whether a user has a shortcut installed

Answer:

The following routine checks whether a shortcut or a file with a given name is either on the desktop, in the start menu or in its programs submenu. It will both check in the user's private desktop/ start menu.. as in the all-users settings.

The return value shows where the first installation was found, it may be used as in .FormCreate() at the bottom of the example.

Because shortcuts are just files, it is not case-sensitive.
LinkExists ('SourceCoder') = LinkExists ('sourcecoder')

uses
  Registry;

type
  TInstallationPlace = (le_None, le_CommonDesktop, le_CommonProgs, le_CommonStart,
    le_UserDesktop, le_UserProgs, le_UserStart);

  // check whether a shortcut or a file with name s is either on
  // the desktop, in the start menu or in its programs submenu.

function LinkExists(const s: string): TInstallationPlace;
var
  cDesktop,
    cProgs,
    cStart,
    uDesktop,
    uProgs,
    uStart: string;

  function myExists(const s: string): boolean;
  begin
    // s can be directory or a file, so FileExists() won't do it..
    myExists := FileGetAttr(s) >= 0;
  end;

begin
  // check whether we have the link in All_User's Desktop!
  cDesktop := '';
  cProgs := '';
  cStart := '';
  uDesktop := '';
  uProgs := '';
  uStart := '';
  with TRegistry.Create do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
      false) then
    begin
      cDesktop := ReadString('Common Desktop');
      cProgs := ReadString('Common Programs');
      cStart := ReadString('Common Start Menu');
    end;
    CloseKey;
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
      false) then
    begin
      uDesktop := ReadString('Desktop');
      uProgs := ReadString('Programs');
      uStart := ReadString('Start Menu');
    end;
    CloseKey;
    Free;
  end;
  // check in all 3 places for our link
  Result := le_None;
  s := '\' + s;
  if myExists(cDesktop + s) then
    Result := le_CommonDesktop
  else if myExists(cProgs + s) then
    Result := le_CommonProgs
  else if myExists(cStart + s) then
    Result := le_CommonStart
  else if myExists(cDesktop + ChangeFileExt(s, '.lnk')) then
    Result := le_CommonDesktop
  else if myExists(cProgs + ChangeFileExt(s, '.lnk')) then
    Result := le_CommonProgs
  else if myExists(cStart + ChangeFileExt(s, '.lnk')) then
    Result := le_CommonStart
  else if myExists(uDesktop + s) then
    Result := le_UserDesktop
  else if myExists(uProgs + s) then
    Result := le_UserProgs
  else if myExists(uStart + s) then
    Result := le_UserStart
  else if myExists(uDesktop + ChangeFileExt(s, '.lnk')) then
    Result := le_UserDesktop
  else if myExists(uProgs + ChangeFileExt(s, '.lnk')) then
    Result := le_UserProgs
  else if myExists(uStart + ChangeFileExt(s, '.lnk')) then
    Result := le_UserStart
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if LinkExists('SourceCoder') <> le_None then
    ShowMessage('yes')
  else
    ShowMessage('no');
end;

How to save a TCollectionItem from a component to a stream

Problem/Question/Abstract:

I have written a component which uses TCollections as properties. Now I need a way to save the TCollectionItems to a file. How can I do that?

Answer:

You may try these routines. I have tested them with TStatusBar.Panels collection and they worked for me:

procedure LoadCollectionFromStream(Stream: TStream; Collection: TCollection);
begin
  with TReader.Create(Stream, 4096) do
  try
    CheckValue(vaCollection);
    ReadCollection(Collection);
  finally
    Free;
  end;
end;

procedure LoadCollectionFromFile(const FileName: string; Collection: TCollection);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadCollectionFromStream(FS, Collection);
  finally
    FS.Free;
  end;
end;

procedure SaveCollectionToStream(Collection: TCollection; Stream: TStream);
begin
  with TWriter.Create(Stream, 4096) do
  try
    WriteCollection(Collection);
  finally
    Free;
  end;
end;

procedure SaveCollectionToFile(Collection: TCollection; const FileName: string);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);
  try
    SaveCollectionToStream(Collection, FS);
  finally
    FS.Free;
  end;
end;

Note: It's obvious, the Collection variable must point to the initialized instance of a TCollection
descendant.

Change the position of a list item in a TListView (2)

Problem/Question/Abstract:

How can I swap two items (and their subitems) in a TListview? Is there a command ?

Answer:

Exchange two items in a TListView:

procedure TForm1.Button2Click(Sender: TObject);
var
  temp: TListItem;
  i1, i2: Integer;
begin
  i1 := 0;
  i2 := 0;
  { pick two items to exchange at random }
  while i1 = i2 do
  begin
    i1 := Random(listview1.items.count);
    i2 := Random(listview1.items.count);
  end;
  { exchange them, need to create a temp item for this }
  temp := TListitem.create(listview1.items);
  try
    temp.Assign(listview1.items[i1]);
    listview1.items[i1].Assign(listview1.items[i2]);
    listview1.items[i2].Assign(temp);
  finally
    temp.free
  end;
end;

RTTI - determining property information

Problem/Question/Abstract:

A RTTI question - it is possible to determine if a certain property is Read-Only, Write-Only or stored?

Answer:

The following code checks whether a property can be written to, read or whether it is stored.


function IsWriteProp(Info: PPropInfo): Boolean;
begin
  Result := Assigned(Info) and (Info^.SetProc <> nil)
end;

function IsReadProp: Boolean;
begin
  Result := Assigned(Info) and (Info^.GetProc <> nil)
end;

function IsStoredProp: Boolean;
begin
  Result := Assigned(Info) and TYPINFO.IsStoredProp(FObj, Info)
end;

Debugging IIS5 the easy way

Problem/Question/Abstract:

IIS debugging is kind of painful... until you understand what is going on behind the scenes!

Answer:

Introduction

If you developed ISAPI dlls and tried to debug them under IIS5 you probabily went trough one of the most painful exercises on the Windows platform. "What doesn't kill you makes you stronger" they say, but there is a limit in my opinion. Well, tonight after having unsuccesfully tried all the "how-to"s on the web, I dediced to see what is going on and why it is (apparently) that difficult.

It turned out that it's very simple and what happens behind the scenes in nothing but regular COM stuff. The key steps are just 3. It's as easy as that! No registry changes or anything else.

Setting up the debugging environment

In this example I will assume your ISAPI dll runs in a virtual directory called "DebuggingIIS".

Open the Internet Services Manager utility located under Control Panel\Administrative Tools.

Find your virtual directory and after right-clicking on it and selecting "Properties" change it's Application protection to "High" as in the following screenshot.



What happened after you did it is IIS created a special COM+ application which will be responsible for loading your ISAPI dlls and everything that as to do with your virtual directory.

If you open up the Component Services up will see this:



Now, right click on the COM+ Application, select "Properties"  and follow me through 2 additional steps before we are ready to start debugging directly from Delphi.

The first page that will appear is the following:



You will need the Application ID in Delphi so copy it by right clicking on it.

Now move to the page Identity and switch the default setting to "Interactive User" as for the following screenshot:



Belive it or not, we are done with IIS and COM+

Now you can go in your Delphi ISAPI project and after clicking on Run\Parameters enter the following parameters:



The value after ProcessID is the Application ID we copied in the Application Services snap in.

Happy debugging!

How to display bitmaps in a TDBGrid

Problem/Question/Abstract:

How can I add a bitmap to an individual cell in a TDBGrid and save the grid as a bitmap afterwards?

Answer:

Solve 1:

To display a bitmap in a cell, set DefaultDrawing to False and create a DrawDataCell handler similar to the following:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState)
var
  Graf: TBitmap;
begin
  if Field is TBlobField then
  begin
    Graf := TBitmap.Create;
    Graf.Assign(Field);
    DBGrid1.Canvas.StretchDraw(Rect, Graf);
    Graf.Free;
  end
  else
  begin
    DBGrid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 1, Field.DisplayText);
  end;
end;


Solve 2:

To display the bitmap:

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  MyRect: TRect;
  MyImageIndex: Integer;
begin
  DBGrid1.Canvas.FillRect(Rect);
  MyImageIndex := Column.Index mod 2;
  ImageList1.Draw(DBGrid1.Canvas, Rect.Left + 2, Rect.Top + (Rect.Bottom - Rect.Top -
    ImageList1.Height) div 2, MyImageIndex, Column.Grid.Enabled);
  MyRect := Rect;
  MyRect.Left := MyRect.Left + ImageList1.Width + 4;
  DBGrid1.DefaultDrawColumnCell(MyRect, DataCol, Column, State);
end;

To save the grid:

procedure TForm1.Button1Click(Sender: TObject);
var
  MyBitmap: TBitmap;
begin
  MyBitmap := TBitmap.Create;
  try
    MyBitmap.Width := DBGrid1.ClientWidth;
    MyBitmap.Height := DBGrid1.ClientHeight;
    MyBitmap.Canvas.Brush := DBGrid1.Brush;
    MyBitmap.Canvas.FillRect(DBGrid1.ClientRect);
    MyBitmap.Canvas.Lock;
    try
      DBGrid1.PaintTo(MyBitmap.Canvas.Handle, 0, 0);
      Clipboard.Assign(MyBitmap);
    finally
      MyBitmap.Canvas.Unlock;
    end;
  finally
    MyBitmap.Free;
  end;
end;

How to get the position of the Windows Taskbar

Problem/Question/Abstract:

I want to get some desktop settings in variables, like background color etc. But I don't want to use the registry, does anybody know a different way? I also want to know the height of the taskbar, and the position of the taskbar (top of the screen, bottom, left or right).

Answer:

For the following example put a RadioGroup on your form and give it 5 items:

implementation

type
  TTaskBarPosition = (tpHide, tpBottom, tpLeft, tpRight, tpTop);

function FindTaskBarPos(aWorkArea: TRect): TTaskBarPosition;
begin
  if aWorkArea.Left <> 0 then
  begin
    Result := tpLeft;
    Exit;
  end;
  if aWorkArea.Top <> 0 then
  begin
    Result := tpTop;
    Exit;
  end;
  if aWorkArea.Right <> Screen.Width then
  begin
    Result := tpRight;
    Exit;
  end;
  if aWorkArea.Bottom <> Screen.Height then
  begin
    Result := tpBottom;
    Exit;
  end;
  Result := tpHide;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  WorkArea: TRect;
begin
  Color := clBackground;
  SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
  RadioGroup1.ItemIndex := Ord(FindTaskBarPos(WorkArea));
end;

end.

Create a semicolon delimited list of paths

Problem/Question/Abstract:

I'm looking for a component that will build a semicolon delimited list of paths, like the one Delphi presents you to build the include path, etc.

Answer:

No need for a component, just use straight Object Pascal. Example:

procedure TForm1.Button1Click(Sender: TObject);
var
  sList: TStringList;
  i, iRes: integer;
  sTmp: string;
begin
  sTmp := '$(DELPHI)\Lib;$(DELPHI)\Bin;$(DELPHI)\Imports;$(DELPHI)\Projects\Bpl';
  sList := TStringList.Create;
  try
    iRes := Pos(';', sTmp);
    while iRes > 0 do
    begin
      sList.Add(Copy(sTmp, 1, iRes - 1));
      Delete(sTmp, 1, iRes);
      iRes := Pos(';', sTmp);
    end;
    if sTmp <> EmptyStr then
      sList.Add(sTmp);
    showmessage(sList.Text);
    sTmp := '';
    for i := 0 to sList.Count - 1 do
      if i < sList.Count - 1 then
        sTmp := sTmp + sList[i] + ';'
      else
        sTmp := sTmp + sList[i];
    showmessage(sTmp);
  finally
    FreeAndNil(sList);
  end;
end;

Call CopyFileEx and let the callback update a progress bar

Problem/Question/Abstract:

Does anyone have an example of using CopyFileEx with a CopyProgressRoutine? I have created a function that takes the same parameters as the CopyProgressRoutine, but when I pass it using @ or Addr() I get a Variable Required error message.

Answer:

Let's assume you call CopyFileEx and want the callback to update a progress bar. The callback cannot be an objects method but you can use the lpData parameter of CopyFileEx to pass any kind of data to the callback, e.g. a form reference. So, if you want to serve a progress form in the callback that would look like this (untested !):

type
  TProgressForm = class(TForm)
    AbortButton: TButton;
    ProgressBar: TProgressBar;
    procedure AbortButtonClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FCancel: BOOL;
  end;
  {form has fsStayOnTop formstyle!}

implementation

{$R *.DFM}

procedure TProgressForm.AbortButtonClick(Sender: TObject);
begin
  FCancel := True;
end;

{Note: could use int64 instead of COMP, but that would make this D4 specific}

function CopyCallback(TotalFileSize, TotalBytesTransferred, StreamSize,
  StreamBytesTransferred: COMP; dwStreamNumber, dwCallbackReason: DWORD;
  hSourceFile, hDestinationFile: THandle; progressform: TProgressForm): DWORD; stdcall;
var
  newpos: Integer;
begin
  Result := PROCESS_CONTINUE;
  if dwCallbackReason = CALLBACK_CHUNK_FINISHED then
  begin
    newpos := Round(TotalBytesTransferred / TotalFileSize * 100);
    with progressform.Progressbar do
      if newpos <> Position then
        Position := newpos;
    Application.ProcessMessages;
  end;
end;

function DoFilecopy(const source, target: string): Boolean;
var
  progressform: TProgressForm;
begin
  progressform := TProgressform.Create;
  try
    progressform.Show;
    Application.ProcessMessages;
    Result := CopyFileEx(PChar(source), PChar(target), @CopyCallback,
                 Pointer(progressform), @progressform.FCancel, 0);
  finally
    progressform.Hide;
    progressform.free;
  end;
end;

Get the TObject from an IInterface

Problem/Question/Abstract:

I'm trying to find a way to get the TObject reference from an IInterface object. I know that if the interface loses the reference the object will destroy but I've got a special need. The environment is based on interfaces but there is one component that can't use interfaces. So to work around it I assign the interface to a local variable, convert the interface to an object, call the component and when all is done get rid of the interface variable. Is this the right approach or can anything go wrong?

Answer:

function GetImplementingObject(const I: IInterface): TObject;
const
  AddByte = $04244483; {opcode for ADD DWORD PTR [ESP+4], Shortint}
  AddLong = $04244481; {opcode for ADD DWORD PTR [ESP+4], Longint}
type
  PAdjustSelfThunk = ^TAdjustSelfThunk;
  TAdjustSelfThunk = packed record
    case AddInstruction: longint of
      AddByte: (AdjustmentByte: shortint);
      AddLong: (AdjustmentLong: longint);
  end;
  PInterfaceMT = ^TInterfaceMT;
  TInterfaceMT = packed record
    QueryInterfaceThunk: PAdjustSelfThunk;
  end;
  TInterfaceRef = ^PInterfaceMT;
var
  QueryInterfaceThunk: PAdjustSelfThunk;
begin
  Result := Pointer(I);
  if Assigned(Result) then
  try
    QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk;
    case QueryInterfaceThunk.AddInstruction of
      AddByte: Inc(PChar(Result), QueryInterfaceThunk.AdjustmentByte);
      AddLong: Inc(PChar(Result), QueryInterfaceThunk.AdjustmentLong);
    else
      Result := nil;
    end;
  except
    Result := nil;
  end;
end;