Working with KeyBoard Binding

Problem/Question/Abstract:

How to set your own shortcut keys while working with delphi editor? If you want your own piece of shortcut key to perform a certain action for you then this code will help

Answer:

Include this unit in a delphi package, and install the package. Now, if you press ctrl + d you will get the 'This was written by Subha Narayanan' in your editor window.
The actual process is very simple. We use the interface TNotifier Object and IOTAkeyboardbinding to create our own interface.
Our main key to perform this action is the procedure 'Dupline'

unit DupLineBinding;

interface

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

type
  TDupLineBinding = class(TNotifierObject, IOTAKeyboardBinding)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    procedure DupLine(const Context: IOTAKeyContext; KeyCode: TShortCut;
      var BindingResult: TKeyBindingResult);
    {IOTAKeyBoardBinding}
    function GetBindingType: TBindingType;
    function GetDisplayName: string;
    function GetName: string;
    procedure BindKeyboard(const BindingServices: IOTAKeyBindingServices);

  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  (BorlandIDEServices as
    IOTAKeyBoardServices).AddKeyBoardBinding(TDupLineBinding.Create);
end;

function TDupLineBinding.GetBindingType: TBindingType;
begin
  Result := btPartial;
end;

function TDupLineBinding.GetDisplayName;
begin
  Result := 'Subha Line Binding';
    {The way it shoudl appear in the delphi ide editor window}
end;

function TDupLineBinding.GetName;
begin
  Result := 'sn.dupline'; {Should be unique}
end;

procedure TDupLineBinding.DupLine(const Context: IOTAKeyContext; KeyCode: TShortCut;
  var BindingResult: TKeyBindingResult);
var
  ep: IOTAEditPosition;
  eb: IOTAEditBlock;
  r, c: Integer;
begin
  {Actual place where the writting into editor takes place}
  try
    ep := Context.EditBuffer.EditPosition;
    ep.Save;
    r := ep.Row;
    c := ep.Column;
    eb := Context.EditBuffer.EditBlock;
    ep.MoveBOL;
    eb.Reset;
    eb.BeginBlock;
    eb.Extend(Ep.Row + 1, 1);
    eb.EndBlock;
    eb.Copy(False);
    ep.MoveBOL;
    ep.Paste;
    ep.Move(r, c);
  finally
    ep.Restore;
  end;
  BindingResult := krHandled;
end;

procedure TDupLineBinding.BindKeyboard(const BindingServices: IOTAKeyBindingServices);
{Here we specify the shortcut key which should do the action}
begin
  BindingServices.AddKeyBinding([Shortcut(Ord('D'), [ssCtrl])], DupLine, nil);
end;

end.

Create a multiple line heading in a TStringGrid

Problem/Question/Abstract:

How to create a multiple line heading in a TStringGrid

Answer:

Here is an example for a TStringGrid that has a multiple line heading with centered and bold text:

procedure TForm1.grid1DrawCell(Sender: TObject; Col, Row: Longint;
  Rect: TRect; State: TGridDrawState);
var
  l_oldalign: word;
  l_YPos, l_XPos, i: integer;
  s, s1: string;
  l_col, l_row: longint;
begin
  l_col := col;
  l_row := row;
  with sender as TStringGrid do
  begin
    if (l_row = 0) then
      canvas.font.style := canvas.font.style + [fsbold];
    if l_row = 0 then
    begin
      l_oldalign := settextalign(canvas.handle, ta_center);
      l_XPos := rect.left + (rect.right - rect.left) div 2;
      s := cells[l_col, l_row];
      while s <> '' do
      begin
        if pos(#13, s) <> 0 then
        begin
          if pos(#13, s) = 1 then
            s1 := ''
          else
          begin
            s1 := trim(copy(s, 1, pred(pos(#13, s))));
            delete(s, 1, pred(pos(#13, s)));
          end;
          delete(s, 1, 2);
        end
        else
        begin
          s1 := trim(s);
          s := '';
        end;
        l_YPos := rect.top + 2;
        canvas.textrect(rect, l_Xpos, l_YPos, s1);
        inc(rect.top, rowheights[l_row] div 3);
      end;
      settextalign(canvas.handle, l_oldalign);
    end
    else
    begin
      canvas.textrect(rect, rect.left + 2, rect.top + 2, cells[l_col, l_row]);
    end;
    canvas.font.style := canvas.font.style - [fsbold];
  end;
end;

How to check when a screen saver has been invoked

Problem/Question/Abstract:

I want my application to go into 'sleep mode' when the screen saver has been started.

Answer:

unit U1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure AppMessage(var AMessage: TMsg; var Handled: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{Get screen saver messages}

procedure TForm1.AppMessage(var AMessage: TMsg; var Handled: Boolean);
begin
  if ((WM_SYSCOMMAND = AMessage.Message) and (SC_SCREENSAVE = AMessage.wParam)) then
  begin
    Handled := True;
    Label1.Caption := 'Warning! Screen saver detected. Top clearance required.';
    Handled := False;
  end;
end;

{On form create}

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

end.

How to store the content of the clipboard in a file

Problem/Question/Abstract:

How to store the content of the clipboard in a file

Answer:

{ ... }
if Clipboard.HasFormat(CF_BITMAP) then
begin
  bmp := TBitmap.Create;
  try
    Clipboard.AssignTo(bmp);
    bmp.SaveToFile(filename);
  finally
    bmp.free
  end;
end;
{ ... }

How to rotate a TBitmap smoothly

Problem/Question/Abstract:

I would like to rotate a TBitmap using a smooth algorithm but without clipping the corner of the bitmap. The size of the rotated bitmap change according to the angle.

Answer:

cx, cy represent the center of rotation.

function IntToByte(i: integer): byte;
begin
  if (i > 255) then
    Result := 255
  else if (i < 0) then
    Result := 0
  else
    Result := i;
end;

function TrimInt(i, Min, Max: integer): integer;
begin
  if (i > Max) then
    Result := Max
  else if (i < Min) then
    Result := Min
  else
    Result := i;
end;

procedure SmoothRotate(Src, Dst: TBitmap; cx, cy: integer; Angle: Extended);

type
  TFColor = record
    b, g, r: Byte
  end;

var
  Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
  cAngle, sAngle: Double;
  xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
  nw, ne, sw, se: TFColor;
  P1, P2, P3: PByteArray;
begin
  Src.PixelFormat := pf24Bit;
  Dst.PixelFormat := pf24Bit;
  Angle := -Angle * Pi / 180;
  sAngle := Sin(Angle);
  cAngle := Cos(Angle);
  xDiff := (Dst.Width - Src.Width) div 2;
  yDiff := (Dst.Height - Src.Height) div 2;
  for y := 0 to Dst.Height - 1 do
  begin
    P3 := Dst.scanline[y];
    py := 2 * (y - cy) + 1;
    for x := 0 to Dst.Width - 1 do
    begin
      px := 2 * (x - cx) + 1;
      fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
      fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
      ifx := Round(fx);
      ify := Round(fy);
      if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then
      begin
        eww := fx - ifx;
        nsw := fy - ify;
        iy := TrimInt(ify + 1, 0, Src.Height - 1);
        ix := TrimInt(ifx + 1, 0, Src.Width - 1);
        P1 := Src.scanline[ify];
        P2 := Src.scanline[iy];
        nw.r := P1[ifx * 3];
        nw.g := P1[ifx * 3 + 1];
        nw.b := P1[ifx * 3 + 2];
        ne.r := P1[ix * 3];
        ne.g := P1[ix * 3 + 1];
        ne.b := P1[ix * 3 + 2];
        sw.r := P2[ifx * 3];
        sw.g := P2[ifx * 3 + 1];
        sw.b := P2[ifx * 3 + 2];
        se.r := P2[ix * 3];
        se.g := P2[ix * 3 + 1];
        se.b := P2[ix * 3 + 2];
        Top := nw.b + eww * (ne.b - nw.b);
        Bottom := sw.b + eww * (se.b - sw.b);
        P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
        Top := nw.g + eww * (ne.g - nw.g);
        Bottom := sw.g + eww * (se.g - sw.g);
        P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
        Top := nw.r + eww * (ne.r - nw.r);
        Bottom := sw.r + eww * (se.r - sw.r);
        P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
      end;
    end;
  end;
end;

How to remove white-spaces from a TMemo

Problem/Question/Abstract:

How to remove white-spaces from a TMemo

Answer:

This would trim a TMemo (multi-line string), discarding any white-space from end-of-lines and from end-of-text. The end result is exactly similar to the original, without the useless extras, usually left-overs from bad typing habits.

function MemoTrimTrail(const aMemo: string): string;
var
  iRead, iWrite, vLastNonWhite, vLastNonSpace: Integer;
  vChr: Char;
  vIsSpace, vIsReturn: Boolean;
begin
  if aMemo = '' then
  begin {empty string}
    Result := ''; {nothing to do}
    exit;
  end;
  SetLength(Result, Length(aMemo)); {initially, empty string of same length}
  UniqueString(Result); {make sure we have a separate copy}
  iWrite := 0; {where characters will be written out}
  vLastNonWhite := 0; {last non-space, non-return}
  vLastNonSpace := 0; {last non-space, but could be return}
  for iRead := 1 to Length(aMemo) do
  begin
    vChr := aMemo[iRead]; {pick next char in source}
    vIsReturn := vChr in [#13, #10]; {CR or LF}
    vIsSpace := vChr in [#32, #09]; {space or tab}
    if vIsReturn then
      iWrite := vLastNonSpace + 1 {skip empty end-of-lines}
    else
      Inc(iWrite);
    Result[iWrite] := vChr; {write char in result-string}
    if not vIsSpace then
    begin
      vLastNonSpace := iWrite; {last non-space, returns are Ok}
      if not vIsReturn then
      begin
        vLastNonWhite := iWrite; {last black-ink character}
      end;
    end;
  end;
  SetLength(Result, vLastNonWhite); {truncate at last black-ink character}
end;

Detecting database changes

Problem/Question/Abstract:

Detecting database changes

Answer:

Do you need to determine if a user has changed any of the fields of a displayed record, but hasn't yet posted the record? If so, you can check the current state of the database via the datasource associated with it. To do so, simply write the following code:

if (Datasource1.State in dsEditModes) then
  {...code you want to execute...}

If the datasource's State property is dsEdit, dsInsert or dsSetKey, this statement will evaluate as true.

ADO data state

Problem/Question/Abstract:

ADO data state

Answer:

This little code snip is how to get the database's state as it changes.

procedure TForm1.DataSource1StateChange(Sender: TObject);
var
  ds: string;
begin
  case ADOTable1.State of
    dsInactive: ds := 'Closed';
    dsBrowse: ds := 'Browsing';
    dsEdit: ds := 'Editing';
    dsInsert: ds := 'New record inserting';
  else
    ds := 'Other states'
  end;
  Caption := 'ADOTable1 state: ' + ds;
end;

How to enable/disable individual buttons on a TDBNavigator

Problem/Question/Abstract:

How to enable/disable individual buttons on a TDBNavigator

Answer:

{Append allowed/ not allowed}
DBNavigator1.Controls[4].Enabled := not DBNavigator1.Controls[4].Enabled

Abstraction of Runtime Queries from Code

Problem/Question/Abstract:

Programming methodology books such as 'The Pragmatic Programmer' by Andrew Hunt and David Thomas teach the principles of decoupling, abstraction and non-repetition. This article shows how to achieve some of these goals when codeing queries whose SQL statements are set at runtime.

Answer:

In article "Auxiliary TQuery used with queries built at run time", Fernando Martins suggested a way to avoid code replication when using TQuery objects with SQL statements set at runtime. Here I show how to take this a step further and remove the SQL from your code so that the queries can be changed without recompiling your program.

My queries are stored within an inifile in the program's directory. This provides us with a simple file format which is easy to use both in and out of Delphi. My inifile has the following syntax:

[QUERIES]
1=SELECT CAPITAL FROM COUNTRY WHERE NAME = 'Argentina'
2=SELECT NAME FROM COUNTRY WHERE CONTINENT = 'South America'

To perform the query call the ExecuteQuery procedure which in turn will call the GetQuery function. ExecuteQuery must be passed the following paramaters:

myQuery : TQuery  - TQuery component used to perform query
queryID : integer - ID number in inifile for the SQL satement
myDB : string     - optional Database Name

ExecuteQuery(qryRuntime, 1, );
ExecuteQuery(qryRuntime, 2, 'DBDEMOS');

Now for the code:

uses IniFiles;

const
  queryFileName = 'queries.ini';

procedure ExecuteQuery(myQuery: TQuery; const queryID: integer; const myDB: string =
  '');
{performs query getting SQL statement at runtime from inifile}
begin
  if not (myDB = '') then
    myQuery.DatabaseName := myDB;
  try
    myQuery.Close;
    myQuery.SQL.Clear;
    myQuery.SQL.Add(GetQuery(queryID));
    myQuery.Open;
  except
    on E: Exception do
      MessageDlg(E.message, mtError, [mbYes], 0);
  end; {try..except}
end; {procedure ExecuteQuery}

function GetQuery(const qID: integer): string;
{reads SQL statement from inifile}
var
  DirPath: string;
  queryIni: TIniFile;
begin
  DirPath := ExtractFilePath(ParamStr(0));
  queryIni := TIniFile.Create(DirPath + queryFileName);
  try
    if not (queryIni.ValueExists('QUERIES', IntToStr(qID))) then
      raise Exception.Create('ERROR: Query ID not found in file!')
    else
      result := queryIni.ReadString('QUERIES', IntToStr(qID), '');
  finally
    queryIni.Free;
  end; {try..finally}
end; {function GetQuery}

Finally, to avoid having to look up long lists of query IDs when programming, incorporate them into a unit of constant values so that you can use code like the following:

ExecuteQuery(qryRuntime, GET_CAPITAL, );
ExecuteQuery(qryRuntime, GET_COUNTRIES, 'DBDEMOS');

How to open and read the first frame in an AVI file

Problem/Question/Abstract:

How to open and read the first frame in an AVI file

Answer:

{File: AVIObjects.pas
Author: Liran Shahar
Purpose: AVI file objects routines to open,read and retrive poster frames (first frame in AVI file)
Copyright(C) 2001, Com-N-Sense Ltd, all rights reserved

Note: this unit is released as freeware. In other words, you are free  to use this unit in your own applications, however I retain all copyright to the code. LS}

unit AVIObjects;

interface

uses
  Windows, Graphics, Sysutils, Classes, VFW, Ole2;

type
  TAviFileStream = class(TPersistent)
  private
    aviFile: IAviFile;
    aviStream: IAviStream;
    aviFrame: IGetFrame;
    aviInfo: TAviStreamInfo;
  protected
    function GetFrameCount: cardinal; virtual;
    function GetDuration: double; virtual;
    function GetWidth: integer; virtual;
    function GetHeight: integer; virtual;
    function GetWantedBitmapFormat: PBitmapInfoHeader; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function Active: boolean; virtual;
    procedure Open(const Filename: AnsiString); virtual;
    procedure Close; virtual;
    procedure GetFrame(FrameNumber: cardinal; var DIB: PBitmapInfoHeader); virtual;
    property FrameCount: cardinal read GetFrameCount;
    property Duration: double read GetDuration;
    property ImageWidth: integer read GetWidth;
    property ImageHeight: integer read GetHeight;
  end;

implementation

constructor TAviFileStream.Create;
begin
  inherited Create;
  aviFile := nil;
  aviStream := nil;
  aviFrame := nil;
end;

destructor TAviFileStream.Destroy;
begin
  Close;
  inherited Destroy;
end;

function TAviFileStream.Active: boolean;
begin
  Result := (aviStream <> nil) and (aviFrame <> nil);
end;

function TAviFileStream.GetFrameCount: cardinal;
begin
  Result := aviInfo.dwLength;
end;

function TAviFileStream.GetDuration: double;
begin
  if (aviInfo.dwRate <> 0) and (aviInfo.dwScale <> 0) then
    Result := aviInfo.dwLength / (aviInfo.dwRate / aviInfo.dwScale)
  else
    Result := 0.0;
end;

function TAviFileStream.GetWidth: integer;
begin
  Result := aviInfo.rcFrame.Right - aviInfo.rcFrame.Left;
end;

function TAviFileStream.GetHeight: integer;
begin
  Result := aviInfo.rcFrame.Bottom - aviInfo.rcFrame.Top;
end;

function TAviFileStream.GetWantedBitmapFormat: PBitmapInfoHeader;
begin
  Result := nil;
end;

procedure TAviFileStream.Open(const Filename: AnsiString);
var
  iResult: integer;
  BmpInfoHeader: PBitmapInfoHeader;
begin
  Close;
  fillchar(aviInfo, sizeof(aviInfo), 0);
  iResult := AviFileOpen(aviFile, pchar(FileName), OF_READ + OF_SHARE_DENY_WRITE, nil);
  if iResult <> AVIERR_OK then
    raise Exception.Create('Cannot open AVI file ' + Filename);
  iResult := AVIFileGetStream(aviFile, aviStream, streamTypeVideo, 0);
  if iResult <> AVIERR_OK then
    raise Exception.Create('Cannot open stream for that file');
  iResult := AVIStreamInfo(aviStream, aviInfo, sizeof(aviInfo));
  if iResult <> AVIERR_OK then
    raise Exception.Create('Cannot read stream info');
  BmpInfoHeader := GetWantedBitmapFormat;
  aviFrame := AVIStreamGetFrameOpen(aviStream, BmpInfoHeader);
  if not assigned(aviFrame) then
    raise Exception.Create('Cannot find suitable decompressor');
  if assigned(BmpInfoHeader) then
    dispose(BmpInfoHeader);
end;

procedure TAviFileStream.Close;
var
  iResult: integer;
begin
  aviFrame := nil;
  aviStream := nil;
  aviFile := nil;
end;

procedure TAviFileStream.GetFrame(FrameNumber: cardinal; var DIB: PBitmapInfoHeader);
begin
  DIB := aviStreamGetFrame(aviFrame, FrameNumber)
end;

initialization
  CoInitialize(nil);
  AVIFileInit;

finalization
  AVIFileExit;
  CoUninitialize;

end.

How to run an application in a TOLEContainer without using the Insert Object dialog

Problem/Question/Abstract:

I want to run MS Word by using TOleContainer but I don't want to use the Insert Object dialog. How can I do that?

Answer:

{Creating a new Word document in an Olecontainer}
OleContainer1.CreateObject('Word.Document', False);
OleContainer1.DoVerb(ovShow);

{Loading an existing document in an Olecontainer}
OleContainer1.CreateObjectFromFile('C:\Docs\Doc1.doc', False);
OleContainer1.DoVerb(ovShow);

Convert Listbox.TabWidth to screen pixels

Problem/Question/Abstract:

How to convert Listbox.TabWidth to screen pixels

Answer:

PixelsX := TabWidth * LoWord(GetDialogBaseUnits) div 4 * Canvas.TextWidth(' ') div 4

How to save and restore font properties in the registry

Problem/Question/Abstract:

I tried to save user selected font settings in the registry. Therefore I declared a variable Wfont: TFont; and created it with Wfont := TFont.create; . All works fine, like setting a panel's font and so on, but when I try to write it to the registry using reg.writebinarydata('Font',wfont,sizeof(Tfont)), only 4 Bytes are stored. Ergo the font could not be loaded.

Answer:

Saving and restoring font properties in the registry:

uses
  typInfo, Registry;

function GetFontProp(anObj: TObject): TFont;
var
  PInfo: PPropInfo;
begin
  {try to get a pointer to the property information for a property with the name 'Font'. TObject.ClassInfo returns a pointer to the RTTI table, which we need to pass to GetPropInfo}
  PInfo := GetPropInfo(anObj.ClassInfo, 'font');
  Result := nil;
  if PInfo <> nil then
    {found a property with this name, check if it has the correct type}
    if (PInfo^.Proptype^.Kind = tkClass) and
      GetTypeData(PInfo^.Proptype^)^.ClassType.InheritsFrom(TFont) then
      Result := TFont(GetOrdProp(anObj, PInfo));
end;

function StyleToString(styles: TFontStyles): string;
var
  style: TFontStyle;
begin
  Result := '[';
  for style := Low(style) to High(style) do
  begin
    if style in styles then
    begin
      if Length(result) > 1 then
        result := result + ',';
      result := result + GetEnumname(typeInfo(TFontStyle), Ord(style));
    end;
  end;
  Result := Result + ']';
end;

function StringToStyle(S: string): TFontStyles;
var
  sl: TStringlist;
  style: TFontStyle;
  i: Integer;
begin
  Result := [];
  if Length(S) < 2 then
    Exit;
  if S[1] = '[' then
    Delete(S, 1, 1);
  if S[Length(S)] = ']' then
    Delete(S, Length(S), 1);
  if Length(S) = 0 then
    Exit;
  sl := TStringlist.Create;
  try
    sl.commatext := S;
    for i := 0 to sl.Count - 1 do
    begin
      try
        style := TFontStyle(GetEnumValue(Typeinfo(TFontStyle), sl[i]));
        Include(Result, style);
      except
      end;
    end;
  finally
    sl.free
  end;
end;

procedure SaveFontProperties(forControl: TControl; toIni: TRegInifile; const section:
  string);
var
  font: TFont;
  basename: string;
begin
  Assert(Assigned(toIni));
  font := GetFontProp(forControl);
  if not Assigned(font) then
    Exit;
  basename := forControl.Name + '.Font.';
  toIni.WriteInteger(Section, basename + 'Charset', font.charset);
  toIni.WriteString(Section, basename + 'Name', font.Name);
  toIni.WriteInteger(Section, basename + 'Size', font.size);
  toIni.WriteString(Section, basename + 'Color', '$' + IntToHex(font.color, 8));
  toIni.WriteString(Section, basename + 'Style', StyleToString(font.Style));
end;

procedure RestoreFontProperties(forControl: TControl; toIni: TRegInifile; const
  section: string);
var
  font: TFont;
  basename: string;
begin
  Assert(Assigned(toIni));
  font := GetFontProp(forControl);
  if not Assigned(font) then
    Exit;
  basename := forControl.Name + '.Font.';
  font.Charset := toIni.ReadInteger(Section, basename + 'Charset', font.charset);
  font.Name := toIni.ReadString(Section, basename + 'Name', font.Name);
  font.Size := toIni.ReadInteger(Section, basename + 'Size', font.size);
  font.Color := TColor(StrToInt(toIni.ReadString(Section, basename + 'Color', '$' +
    IntToHex(font.color, 8))));
  font.Style := StringToStyle(toIni.ReadString(Section, basename + 'Style',
    StyleToString(font.Style)));
end;

How to create a TScrollBox without scrollbars

Problem/Question/Abstract:

How to create a TScrollBox without scrollbars

Answer:

Below is a TScrollbox descendent with properties to hide either scrollbar. It can also do a tiled bitmap background. The latter hasn't been made foolproof yet.

THideScrollbarScrollbox = class(TScrollbox)
private
  fHideVertScrollbar, fHideHorzScrollbar: Boolean;
  fVertPosition, fVertRange: Integer;
  fHorzPosition, fHorzRange: Integer;
  OldVisible, OldHorzVisible: Boolean;
  fBackBmp: TBitmap;
  function GetVertPosition: Integer;
  procedure SetVertPosition(const Value: Integer);
  function GetVertRange: Integer;
  procedure SetVertRange(const Value: Integer);
  procedure SetHideVertScrollbar(const Value: Boolean);
  procedure WMPaint(var msg: TWMPaint); message WM_PAINT;
  procedure SetHideHorzScrollbar(const Value: Boolean);
  function GetHorzPosition: Integer;
  function GetHorzRange: Integer;
  procedure SetHorzPosition(const Value: Integer);
  procedure SetHorzRange(const Value: Integer);
protected
  procedure PaintWindow(DC: HDC); override;
public
  constructor Create(AOwner: TComponent); override;
  procedure scrollinview(AControl: TControl);
  property BackBmp: TBitmap read fBackBmp write fBackBmp;
published
  property HideVertScrollbar: Boolean read fHideVertScrollbar write SetHideVertScrollbar;
  property HideHorzScrollbar: Boolean read fHideHorzScrollbar write SetHideHorzScrollbar;
  {use these to set positions and range:}
  property VertPosition: Integer read GetVertPosition write SetVertPosition;
  property VertRange: Integer read GetVertRange write SetVertRange;
  property HorzPosition: Integer read GetHorzPosition write SetHorzPosition;
  property HorzRange: Integer read GetHorzRange write SetHorzRange;
end;

implementation

{ THideScrollbarScrollbox }

constructor THideScrollbarScrollbox.Create(AOwner: TComponent);
begin
  inherited;
  OldVisible := VertScrollbar.Visible;
  fVertPosition := 0;
  fBackBmp := nil;
end;

function THideScrollbarScrollbox.GetHorzPosition: Integer;
begin
  if HorzScrollbar.Visible or not fHideHorzScrollbar then
  begin
    Result := HorzScrollbar.position;
    fHorzPosition := Result;
  end
  else
    Result := fHorzPosition;
end;

function THideScrollbarScrollbox.GetHorzRange: Integer;
begin
  if HorzScrollbar.Visible or not fHideHorzScrollbar then
  begin
    Result := HorzScrollbar.Range;
    fHorzRange := Result;
  end
  else
    Result := fHorzRange;
end;

function THideScrollbarScrollbox.GetVertPosition: Integer;
begin
  if VertScrollbar.Visible or not fHideVertScrollbar then
  begin
    Result := VertScrollbar.position;
    fVertPosition := Result;
  end
  else
    Result := fVertPosition;
end;

function THideScrollbarScrollbox.GetVertRange: Integer;
begin
  if VertScrollbar.Visible or not fHideVertScrollbar then
  begin
    Result := VertScrollbar.Range;
    fVertRange := Result;
  end
  else
    Result := fVertRange;
end;

procedure TileBitmap(ABm: TBitmap; aDC: HDC; bmw, bmh, cw, ch, cx, cy: Integer);
var
  x, y: Integer;
  BMDC: HDC;
begin
  y := cy;
  if bmw > 0 then
    if bmh > 0 then
    begin
      BMDC := ABm.Canvas.Handle;
      while y < ch do
      begin
        x := cx;
        if y + bmh > 0 then
          while x < cw do
          begin
            if x + bmw > 0 then
              BitBlt(aDC, x, y, bmw, bmh, BMDC, 0, 0, SRCCopy);
            x := x + bmw;
          end;
        y := y + bmh;
      end;
    end;
end;

procedure THideScrollbarScrollbox.PaintWindow(DC: HDC);
begin
  if fBackBmp <> nil then
  begin
    TileBitmap(fBackBmp, DC, fBackBmp.Width, fBackBmp.Height,
      clientwidth, clientheight, 0, -VertPosition);
  end
  else
    inherited;
end;

procedure THideScrollbarScrollbox.scrollinview(AControl: TControl);
var
  Rect: TRect;
begin
  if VertScrollbar.Visible or not fHideVertScrollbar then
    inherited scrollinview(AControl)
  else
  begin
    if AControl = nil then
      exit;
    Rect := AControl.ClientRect;
    dec(Rect.Left, HorzScrollbar.margin);
    inc(Rect.Right, HorzScrollbar.margin);
    dec(Rect.Top, VertScrollbar.margin);
    inc(Rect.Bottom, VertScrollbar.margin);
    Rect.TopLeft := screentoclient(AControl.ClienttoScreen(Rect.TopLeft));
    Rect.BottomRight := screentoclient(AControl.ClienttoScreen(Rect.BottomRight));
    if Rect.Top < 0 then
      VertPosition := VertPosition + Rect.Top
    else if Rect.Bottom > clientheight then
    begin
      if Rect.Bottom - Rect.Top > clientheight then
        Rect.Bottom := Rect.Top + clientheight;
      VertPosition := VertPosition + Rect.Bottom - clientheight;
    end;
  end;
end;

procedure THideScrollbarScrollbox.SetHideHorzScrollbar(const Value: Boolean);
begin
  if Value <> fHideHorzScrollbar then
  begin
    fHideHorzScrollbar := Value;
    if Value then
    begin
      OldHorzVisible := HorzScrollbar.Visible;
      HorzScrollbar.Visible := False;
    end
    else
      HorzScrollbar.Visible := OldHorzVisible;
    HorzRange := HorzRange;
    HorzPosition := HorzPosition;
  end;
end;

procedure THideScrollbarScrollbox.SetHideVertScrollbar(const Value: Boolean);
begin
  if Value <> fHideVertScrollbar then
  begin
    fHideVertScrollbar := Value;
    if Value then
    begin
      OldVisible := VertScrollbar.Visible;
      VertScrollbar.Visible := False;
    end
    else
      VertScrollbar.Visible := OldVisible;
    VertRange := VertRange;
    VertPosition := VertPosition;
  end;
end;

procedure THideScrollbarScrollbox.SetHorzPosition(const Value: Integer);
var
  Oldposition: Integer;
begin
  Oldposition := HorzPosition;
  fHorzPosition := Value;
  if fHorzPosition > HorzRange - clientwidth then
    fHorzPosition := HorzRange - clientwidth;
  if fHorzPosition < 0 then
    fHorzPosition := 0;
  if fHorzPosition = Oldposition then
    exit;
  if HorzScrollbar.Visible or not fHideHorzScrollbar then
    HorzScrollbar.position := Value
  else
    Scrollby(Oldposition - fHorzPosition, 0);
end;

procedure THideScrollbarScrollbox.SetHorzRange(const Value: Integer);
begin
  fHorzRange := Value;
  if HorzScrollbar.Visible or not fHideHorzScrollbar then
    HorzScrollbar.Range := Value;
end;

procedure THideScrollbarScrollbox.SetVertPosition(const Value: Integer);
var
  Oldposition: Integer;
begin
  Oldposition := VertPosition;
  fVertPosition := Value;
  if fVertPosition > VertRange - clientheight then
    fVertPosition := VertRange - clientheight;
  if fVertPosition < 0 then
    fVertPosition := 0;
  if fVertPosition = Oldposition then
    exit;
  if VertScrollbar.Visible or not fHideVertScrollbar then
    VertScrollbar.position := Value
  else
    Scrollby(0, Oldposition - fVertPosition);
end;

procedure THideScrollbarScrollbox.SetVertRange(const Value: Integer);
begin
  fVertRange := Value;
  if VertScrollbar.Visible or not fHideVertScrollbar then
    VertScrollbar.Range := Value;
end;

procedure THideScrollbarScrollbox.WMPaint(var msg: TWMPaint);
begin
  ControlState := ControlState + [csCustomPaint];
  inherited;
  ControlState := ControlState - [csCustomPaint];
end;

Good Thursday and Easter Date function

Problem/Question/Abstract:

Here is another function that calculates the Good Thursday and any other related date for eny year. The algorithm provided here is straightforward in the sense that it calculates the Good Thursday (which is the jewish passover) as the thursday ocurring in the same week as the first spring full moon. Obviously the function can be easily adapted to calculate any full moon down to the second.

Answer:

function good_thursday(year: integer): tdatetime;
const
  full_moon: tdatetime = 34804.33889; {15/4/95 8:08}
  sunday: tdatetime = 1;
  sinodic_month: tdatetime = 29.53058912;

var
  equinoccio: tdatetime;
  lunar_months: double;
  full_moon, weeks: double;

begin
  if year < 100 then
    if year year := year + 2000
  else
    year := year + 1900;
  equinoccio := encodedate(year, 3, 21);
  lunar_months := 10000 - Int(10000 - (equinoccio - full_moon) / sinodic_month);
  full_moon := full_moon + sinodic_month * lunar_months;
  weeks := 10000 - Int(10000 - (full_moon - sunday) / 7);
  good_thursday := sunday + 7 * weeks - 3;
end;

Revert to Win 3.1 form resizing behaviour

Problem/Question/Abstract:

Has anyone found a way to prevent the Paint method from firing when you're in the middle of resizing a form? In other words, is there some way to ghost the change until the user actually releases the mouse button, instead of redrawing the form constantly during the resize?

Answer:

You can revert to the way a window was resized in Win 3.1 - with a sizing frame and a redraw only when the user let go of the mouse.

In your forms declaration you place this:

private
        {Private declarations}
        FDragFullWindowState: LongBool;
        procedure WMEnterSizeMove(var msg: TMessage); message WM_ENTERSIZEMOVE;
        procedure WMExitSizeMove(var msg: TMessage); message WM_EXITSIZEMOVE;

The implementation is like this:

procedure TProdBuilderMainForm.WMEnterSizeMove(var msg: TMessage);
begin
  SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FDragFullWindowState, 0);
  if FDragFullWindowState then
    SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Ord(False), nil, 0);
end;

procedure TProdBuilderMainForm.WMExitSizeMove(var msg: TMessage);
begin
  if FDragFullWindowState then
    SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Ord(True), nil, 0);
end;

Modify the idapi.cfg settings through code (2)

Problem/Question/Abstract:

How can my program access the idapi.cfg file and probably change its INIT (Local Share etc.) section?

Answer:

For 32bit only. You can of course use the registry to determine the default CFG File instead of passing it as a parameter here:

procedure ModifyCFG(const ACFGFile, AValue, AEntry, ACFGPath: string; SaveAsWin31:
  bool);
var
  hCfg: hDBICfg;
  pRecBuf, pTmpRec: pByte;
  pFields: pFLDDesc;
  Count: word;
  i: integer;
  Save: boolean;
  Reg: TRegistry;
const
  RegSaveWIN31: array[bool] of string = ('WIN32', 'WIN31');
begin
  hCfg := nil;
  pFields := nil;
  pRecBuf := nil;
  Save := False;
  Check(DbiOpenConfigFile(PChar(ACFGFile), False, hCfg));
  try
    Check(DbiCfgPosition(hCfg, PChar(ACfgPath))); {neccessary...?}
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, nil, nil));
    pRecBuf := AllocMem(succ(Count) * 128); {128 additional safety...}
    pFields := AllocMem(Count * sizeof(FLDDesc));
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    for i := 1 to Count do
    begin
      if StrPas(pFields^.szName) = AEntry then
      begin
        pTmpRec := pRecBuf;
        Inc(pTmpRec, 128 * (i - 1));
        StrPCopy(PChar(pTmpRec), AValue);
      end;
      inc(pFields);
    end;
    dec(pFields, Count);
    Check(DbiCfgModifyRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    Save := True;
  finally
    if hCfg <> nil then
      Check(DbiCloseConfigFile(hCfg, Save, True, SaveAsWin31));
    if pRecBuf <> nil then
      FreeMem(pRecBuf, succ(Count) * 128);
    if pFields <> nil then
      FreeMem(pFields, Count * sizeof(FLDDesc));
  end;
  {update registry SAVECONFIG value}
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if not Reg.OpenKey('SOFTWARE\Borland\Database Engine', False) then
      ShowMessage('Configuration Path not found')
    else
    begin
      Reg.LazyWrite := False;
      Reg.WriteString('SAVECONFIG', RegSaveWIN31[SaveAsWin31]);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  {DbiExit/Init to re-read cfg... make absolutely sure there are no active
        DB components when doing this (it's is best done by a loader app)}
  Session.Close;
  Session.Open;
end;

ACFGPath would be '\SYSTEM\INIT\', AEntry would be 'LOCAL SHARE' und AValue would be 'TRUE' or 'FALSE'.

Accept dropped files from the explorer

Problem/Question/Abstract:

This way you can drag and drop files to a specific control in a Delphi form

Answer:

Just create a project and add a ListBox component to Form1.

1. First, a procedure to handle the message but without handling it.

interface

procedure WMDROPFILES(var Msg: TMessage);

implementation

procedure TForm1.WMDROPFILES(var Msg: TMessage);
var
  pcFileName: PChar;
  i, iSize, iFileCount: integer;
begin
  pcFileName := ''; // to avoid compiler warning message
  iFileCount := DragQueryFile(Msg.WParam, $FFFFFFFF, pcFileName, 255);
  for i := 0 to iFileCount - 1 do
  begin
    iSize := DragQueryFile(Msg.wParam, 0, nil, 0) + 1;
    pcFileName := StrAlloc(iSize);
    DragQueryFile(Msg.WParam, i, pcFileName, iSize);
    if FileExists(pcFileName) then
      AddFile(pcFileName); // method to add each file
    StrDispose(pcFileName);
  end;
  DragFinish(Msg.WParam);
end;

2. Second, a WindowProc method to replace ListBox1 WindowProc default method and a variable to store ListBox1 WindowProc default method.

interface

procedure LBWindowProc(var Message: TMessage);

implementation

var
  OldLBWindowProc: TWndMethod;

procedure TForm1.LBWindowProc(var Message: TMessage);
begin
  if Message.Msg = WM_DROPFILES then
    WMDROPFILES(Message); // handle WM_DROPFILES message
  OldLBWindowProc(Message);
    // call default ListBox1 WindowProc method to handle all other messages
end;

3. In Form1 OnCreate event, initialize all.

procedure TForm1.FormCreate(Sender: TObject);
begin
  OldLBWindowProc := ListBox1.WindowProc; // store defualt WindowProc
  ListBox1.WindowProc := LBWindowProc; // replace default WindowProc
  DragAcceptFiles(ListBox1.Handle, True); // now ListBox1 accept dropped files
end;

4. In Form1 OnDestroy event, uninitialize all. Not necesary but a good practice.

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ListBox1.WindowProc := OldLBWindowProc;
  DragAcceptFiles(ListBox1.Handle, False);
end;

5. To complete source code, the AddFile method.

interface

procedure AddFile(sFileName: string);

implementation

procedure TForm1.AddFile(sFileName: string);
begin
  ListBox1.Items.Add(sFilename);
end;

6. Do not forget to add ShellAPI unit to the uses clause.


Component Download: DroppedFiles.zip

How to get the Word version on a client PC

Problem/Question/Abstract:

Using D6 I need to extract the Word version on the client computer. The options are Word97, Word2000 and WordXP.

Answer:

function GetCurrentWordMajorVersion: Integer;
var
  vRegistry: TRegistry;
  vVersionStr: string;
  vVersion: string;
begin
  Result := -1;
  vRegistry := TRegistry.Create(KEY_READ);
  try
    vRegistry.RootKey := HKEY_CLASSES_ROOT;
    if vRegistry.OpenKeyReadOnly('Word.Application\CurVer') then
    begin
      {Get the default value: 'Word.Application.10'}
      vVersionStr := vRegistry.ReadString('');
      {Extract the major version from the string}
      vVersion := System.Copy(vVersionStr, Succ(LastDelimiter('.', vVersionStr)),
        MAXINT);
      {8=Word97, 9=Word2000, 10=Word2002, etc.}
      Result := StrToIntDef(vVersion, -1);
    end;
  finally
    vRegistry.Free;
  end;
end;

Binary search on an alphasorted TListView

Problem/Question/Abstract:

How to do a binary search on an alphasorted TListView

Answer:

If you want to use a fast searching algorithm (binary search for example) the listview has to be sorted on the column you do the duplicate check on. If it is not sorted you have to use the listviews FindCaption or FindData method, which does a linear search. To sort a listview use its AlphaSort or CustomSort methods.

A binary search on a alphasorted listview for a caption would be something like this (untested!):

{
Function ListviewBinarySearch

Parameters:

listview:
listview to search, assumed to be sorted, must be <> nil.

Item:
item caption to search for, cannot be empty

index:
returns the index of the found item, or the index where the item should be inserted if it is not already in the list. Returns True if there is an item with the passed caption in the list, false otherwise.

Description:
Uses a binary search and assumes that the listview is sorted ascending on the caption of the listitems. The search is case-sensitive, like the default alpha-sort routine used by the TListview class.

Note:
We use the lstrcmp function for string comparison since it is the function used by the default alpha sort routine. If the listview is sorted by another means (e.g. OnCompare event) this needs to be changed, the comparison method used must always be the same one used to sort the listview, or the search will not work!

Error Conditions: none
Created: 31.10.99 by P. Below
}

function ListviewBinarySearch(listview: TListview; const Item: string; var index:
  Integer): Boolean;
var
  first, last, pivot, res: Integer;
begin
  Assert(Assigned(listview));
  Assert(Length(item) > 0);
  Result := false;
  index := 0;
  if listview.items.count = 0 then
    Exit;
  first := 0;
  last := listview.items.count - 1;
  repeat
    pivot := (first + last) div 2;
    res := lstrcmp(PChar(item), Pchar(listview.items[pivot].caption));
    if res = 0 then
    begin
      { Found the item, return its index and exit. }
      index := pivot;
      result := true;
      Break;
    end
    else if res > 0 then
    begin
      { Item is larger than item at pivot }
      first := pivot + 1;
    end
    else
    begin
      { Item is smaller than item at pivot }
      last := pivot - 1;
    end;
  until
    last < first;
  index := first;
end;

Access TSpeedButtons in a TGroupBox

Problem/Question/Abstract:

I need to put a lot of TSpeedButtons into a GroupBox (for example 20). For each button I set a GroupIndex. Is it possible to control what button was pressed without writing a SpeedButtonClick procedure for each button?

Answer:

The OnClick method passes the Sender in as a TObject. You can hook all the buttons up to the same OnClick methods and check to see which button was clicked something like this:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if Sender is TSpeedButton then
    with Sender as TSpeedButton do
    begin
      case GroupIndex of
        1: ;
        2: ;
        3: ;
      end;
    end;
end;

This is assuming the GroupIndex of each button is unique.

Get the name of a keyboard key

Problem/Question/Abstract:

Does anyone know how to get the name of a key from the keyboard? I want a method that sends the ASCII code and returns the correct name in string format.

Answer:

Start with calling VkKeyScan, then proceed to GetKeynameText, via MapVirtualKey.

function GetKeyname(ch: Char): string;
var
  scan: Word;
  virtual_keycode: Byte;
  keyname: array[0..128] of Char;
  lparam: Integer;
begin
  scan := VkKeyScan(ch);
  Result := '';
  if scan <> $FFFF then
  begin
    if (Scan and $100) <> 0 then
      Result := Result + '[Shift]';
    if (Scan and $200) <> 0 then
      Result := Result + '[Ctrl]';
    if (Scan and $400) <> 0 then
      Result := Result + '[Alt]';
    virtual_keycode := Lobyte(scan);
    lparam := MapVirtualKey(virtual_keycode, 0) shl 16;
    if lparam <> 0 then
      if GetKeyNametext(lparam, keyname, sizeof(keyname)) > 0 then
        Result := Result + '[' + keyname + ']';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  memo1.text := GetKeyname(alignededit1.text[1]);
end;

How to close another application

Problem/Question/Abstract:

How to close another application

Answer:

library KillGUI;

uses
  Windows, Messages;

function PostQM(nCode: Integer; wParam: WParam; lparam: LParam): Lparam; stdcall;
begin
  PostQuitMessage(1);
  Result := 0;
end;

function ExitRP(nCode: Integer; wParam: WParam; lparam: LParam): Lparam; stdcall;
begin
  ExitProcess(1);
  Result := 0;
end;

procedure PostQuit(AHandle: THandle; Level: DWord); stdcall;
var
  tid: DWord;
  pid: DWord;
  hProcess: THandle;
begin
  tid := GetWindowThreadProcessId(AHandle, @pid);
  case Level of
    0:
      PostMessage(AHandle, WM_CLOSE, 0, 0);
    1:
      SetWindowsHookEx(WH_GETMESSAGE, PostQM, Hinstance, tid);
    2:
      SetWindowsHookEx(WH_GETMESSAGE, ExitRP, Hinstance, tid);
    3:
      begin
        hProcess := OpenProcess(PROCESS_TERMINATE, False, pid);
        TerminateProcess(hProcess, 1);
      end;
  end;
  PostThreadMessage(tid, 0, 0, 0);
end;

exports
  PostQuit name 'PostQuit';

begin
end.

Exception handling in threads

Problem/Question/Abstract:

Exception handling in threads

Answer:

One of my applications that ran fine on my system, particularly when run in the Delphi IDE, started to stop executing after displaying 'Application error has occurred'.
What was the reason?

I had moved I/O-depending parts of that application into separate threads in order to increase performance and improve responsiveness of the application to user input. It was a typical scenario, ideal for multi-threading.

It turned out that those threads threw an unexpected exception. I did have a global exception handler as a method of my main form/ property of TApplication, but that did not catch the exceptions raised by threads other than the main thread.

Therefore it is mandatory to do at least some basic exception handling on your threads. The simplest solution is to put a try-except-end block in the Execute method and silently eat all exceptions.

If you want to display the exception remember that the VCL itself is not thread-safe. You can make it threadsafe for the execution time of a method by calling this method with the Synchronize() function. The downside is that you cannot pass arguments to a synchronized function. You have to pass arguments via member variables of your thread class.


// This is the cheapest way to handle exceptions
// in threads. if you want to display the exception
// then you need to do this with a separate method,
// which has to be called synchronized..

procedure TSortThread.Execute;
begin
  try
    // do the sorting
  except
    // silently eat all exceptions
  end;
end;

COM Activation

Problem/Question/Abstract:

Did you ever wonder how COM obejcts are created? Did you know you are not the one that creates them? Read more about COM activation right here

Answer:

Introduction

COM has always been presented as something complex to digest and tedious to administer. Nothing can be further from the truth. What you need is, as with everything else, to understand a few principles. After that everything will start to make sense and you will be able to find your way in the land of COM. You may ask why COM and SOAP? Well, the answer is simple: because we can.

Windows comes equipped with an incredible set of tools and services that make distributed development a breeze. This is especially true if you are a Delphi developer because the way it wraps COM is so elegant that there's virtually no difference in writing a regular Delphi class and a COM object. Obviously the devil is in the details and that is what scares most of the people.

In this article I will explain a basic principle: what happens when you try to instantiate a COM object first. Then I will explain why this mechanism (pattern) is so useful. If you get lost check the "To recap" section below. It might help.

Registration and class factories

After you build a COM object like I explained in my Introduction to COM article you need to register it in order to make it available for your client applications. There are different ways to register a COM object:

You can use RegSvr32.exe which is under Windows\System32

You can install your COM object in a COM+ application (which was called Microsoft Transaction Server (MTS) Package under NT4)

You can click on the button Register in the Delphi type library editor from the IDE

Option 2 is the best way for a variety of reasons I will explain later. But why do you need to register a COM object? Why cannot you just use it?

Well, in order to use an object you need to create it. That is the problem. You are not the one that creates the COM object. Windows does it for you and it does that using a class factory that you provide with your COM object.

Take a look at the DSOAPNTier sample application and open the unit uOrderManager_Impl.pas. Go to the end to the initialization section. This is what you will find:

initialization
  TAutoObjectFactory.Create(ComServer, TOrderManager, Class_OrderManager,
    ciMultiInstance, tmApartment);
end.

This code runs as soon as the COM DLL is loaded and creates a class factory. Windows uses it to create the COM object.

Structure of a COM DLL

Class factory... Ok, the initialization section creates it. Windows then uses it... But wait a moment. Who gives Windows the reference to the class factory? Looking at the code, it only looks like a class that is created and potentially never destroyed. Is that a memory leak?

Obviously not. The answer is in the project file (.dpr). If you open it this is what you will see:

library DSOAPNTierLib;

uses
  ComServ, [..];
exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin
end.

Those 4 exported functions are the key to our class factory problem. In order for a regular DLL to be a COM DLL, it has to export those functions. If you open the unit ComServ.pas you will be able to see their formal declaration and the implementation that Delphi automatically provides for you.

Those functions are declared as:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
function DllCanUnloadNow: HResult; stdcall;
function DllRegisterServer: HResult; stdcall;
function DllUnregisterServer: HResult; stdcall;

I hope everything begins to make sense.

DllGetClassObject: it is the function that Windows calls to get the pointer to the class factory object (the one that gets automatically created in the initialization section). The first parameter indicate whose object's class factory it wants returned by using the class factory GUID. The second is a parameter that indicates what interface Windows wants to use to communicate with the class factory. This is almost always IID_IClassFactory or IID_IClassFactory2 which are system interfaces. The third is the pointer to the returned class factory.

After Windows calls this function it will have a pointer to the class factory. That object implements IClassFactory

IClassFactory = interface(IUnknown)
  ['{00000001-0000-0000-C000-000000000046}']
  function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult;
    stdcall;
  function LockServer(fLock: BOOL): HResult; stdcall;
end;

There we go! Trought the method CreateInstance finally, after all this work, Windows is able to create the object!

DllCanUnloadNow: is called by Windows to indicate whether the server can be unloaded from memory because it is no longer in use.

DllRegisterServer, DLLUnregisterServer: they register and unregister the DLL by storing a bunch of informations in the Windows registry as we will see soon.

Registry

Ok, now we know how to get a pointer to the object that creates the object. We know how to tell it to create the object (IClassFactory) but there's another thing that is not clear. Who told Windows to load that DLL instead of another one? The answer is the registry.

When you call RegSrv32.exe (see above, how to register a COM DLL) you specify a file name (the DLLs). Regsrv32 first checks that those 4 functions exist in the DLL. If it is so then calls either DllRegisterServer or DllUnRegisterServer (depending on what you told it to do). That is all RegSvr32.exe does. It really doesn't care of what those functions do until they return 0.

When you create a COM DLL using Delphi, the VCL provides a default implementation for those 4 functions. Those simply store the GUIDs of the class factory, the GUIDs of the COM objects and associate the DLL name to them. This is really all that happens.

Take a look at the following screenshot:



Well, there's another small detail. The ProgID. That is just another redirection. A ProgID is the friendly name (a string) for your COM object such as MyLibrary.MyBusinessObject

You can create a COM object by using it's a GUID or a ProgID. When you use the ProgID, Windows will see to which GUID it is associated and the use that to retrieve all the rest of the information (DLL name). There's another section in the registry that starting from the ProgID will let you find the node I've just shown.

To recap

I hope that I succeeded in making it clear. There are many other details that should be mentioned, but this is meant to be an introduction, not a book on the subject. Here's again what happens in a step by step mode:

Your client application wants to create a COM object so does something like MyObject := CoMyObject.Create

The CoMyObject class (CoClass) tells Windows to return it a pointer to the class factory for the object

Windows scans into the registry and finds the name of the right DLL/EXE

Windows loads it and calls DllGetClassObject

The class factory returned by that call is finally used to create the object

Why is this so useful?

Well, for a variety of reasons.

By not being the one that directly creates the object, COM allows you to cross the boundaries of your local PC. A COM object doesn't necessarily live on the same pc of your client application but could be hosted by a remote server. This is what DCOM (Distributed COM) allows: remote creation and method invokation.

The other useful thing that comes out from this is COM+/MTS and object pooling/just in time activation

COM+ and just in time activation

When you use COM+ or MTS to register your COM object (which means, you create a COM+ application and you drop your DLL in it), you get some benefits in terms of scalability and performance that aren't available with regular in-process creation.

Take a look at the following screen-shot:



I created the "DSOAP Samples" COM+ application and I installed the Login and OrderManager objects into it.

So, what do I need to do in my client to create them now? Nothing. You would create them exactly the way you did before. Same code, no need to recompile or change anything. A few things will change anyways: scalability, creation time and execution speed (depending on what you do) will improve significantly.

The reasons for this lie in the just in time activation on one side, database connection pooling on the other. Actually let's also also add object pooling.

Just in time activation is that process trough which an object is put "asleep" until it is actually used. You create your object and let's say you keep it active without calling any method for 2 minutes. Wouldn't it be nice if something would just free it and call it only after 2 minutes? Well, this is what COM+ does for you transparently. This improves scalability of the server a lot. Instead of keeping memory utilized for nothing, COM+ is able to free the objects and whenever you will call them again it will recreate them for you and restore their state. All that is automatic.

The OrderManager class uses ADO inside to query the database. Before plugging the object in COM+, if we would have created, used and destroyed the object a hundred times, it would have taken let's say 100 seconds. This is because each time it would have had to reconnect to the database. By plugging OrdersManager in COM+ we now benefit from ADO connection pooling. COM+ will keep a list of active connections to the database for you and whenever a call is made, unless necessary, it will resuse one of the existing ones.

Finally (as you can see from the "Pooled" column on the right), COM+ objects can be pooled. There are a few things you need to do to make this happen but I just wanted to give you the idea that that is possible as well. The client wouldn't know the difference.

Conclusion

This is by no means an article that explains everything. There's far more that should be said but I think that I provided you with enough understanding on the subject to start digging into the subject by yourself.

Happy coding!

Sort TListView columns by date or time

Problem/Question/Abstract:

Is there any way to sort columns in a TListView by date or time when a user clicks on the header of the column?

Answer:

Solve 1:

LV1 is a TListView with vsReport.

function CustomDateSortProc(Item1, Item2: TListItem; ParamSort: integer): integer;
  stdcall;
begin
  result := 0;
  if StrToDateTime(item1.SubItems[0]) > StrToDateTime(item2.SubItems[0]) then
    Result := 1
  else if StrToDateTime(item1.SubItems[0]) < StrToDateTime(item2.SubItems[0]) then
    Result := -1;
end;

function CustomNameSortProc(Item1, Item2: TListItem; ParamSort: integer): integer;
  stdcall;
begin
  Result := CompareText(Item1.Caption, Item2.Caption);
end;

procedure TForm1.GetFilesClick(Sender: TObject);
var
  sr: TSearchRec;
  Item: TListItem;
begin
  if FindFirst('e:\*.*', faAnyFile, sr) = 0 then
    repeat
      if (sr.Attr and faDirectory) <> sr.Attr then
      begin
        item := LV1.items.add;
        item.Caption := sr.name;
        Item.SubItems.Add(DateTimeToStr(filedatetodatetime(sr.time)));
      end;
    until
      FindNext(sr) <> 0;
  FindClose(sr);
end;

procedure TForm1.LV1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  if column = LV1.columns[0] then
    LV1.CustomSort(@CustomNameSortProc, 0)
  else
    LV1.CustomSort(@CustomDateSortProc, 0)
end;


Solve 2:

Open a new Delphi application project. Drop a listview (ListView1) onto the default form. Paste in the attached code. Hook up the FormCreate and ListView1ColumnClick event handlers.

The custom sort procedure (and the callback) save the day. There are some limits and drawbacks to this approach though. Since the listview is inherently unaware of data types, you have to bolt that onto the outside. This extra thrashing can represent a performance hit if you're doing something funky in the callback. This example uses up the TListView.Tag, TListColumn.Tag and TListItem.Data properties. This might clash with a scheme in place, or may sicken you because of its bold-faced greed. This system only allows for single-column sorts. This can easily be extended, though, by a reinterpretation of TListView.Tag into sort column_s_. No graphics in the column headers.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListView1: TListView;
    procedure FormCreate(Sender: TObject);
    procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function UnformatText(const Text: string; const VarType: Integer): Variant;
begin
  {This is an ambitious function, in simple form. The standard text to type
        variable conversion is fairly weak, so this function is a good place to
        canonize that thinking.}
  if Length(Text) = 0 then
    Result := Null
  else
  begin
    case VarType of
      varBoolean:
        if CompareText(Text, 'True') = 0 then
          Result := True
        else if CompareText(Text, 'False') = 0 then
          Result := False
        else if CompareText(Text, 'Yes') = 0 then
          Result := True
        else if CompareText(Text, 'No') = 0 then
          Result := False
        else
        begin
          Result := Null;
        end;
    else
      {use the default handler}
      Result := VarAsType(Text, VarType);
    end;
  end;
end;

function LVItemValue(const Item: TListItem; const Col, VarType: Integer): Variant;
begin
  {get the indicated "cell's" text, return an empty string if either index is out of range}
  if Item = nil then
    Result := Null
  else if Col < 0 then
    Result := Null
  else if Col > Item.SubItems.Count then
    Result := Null
  else if Col = 0 then
    Result := UnformatText(Item.Caption, VarType)
  else
  begin
    Result := UnformatText(Item.SubItems[Col - 1], VarType);
  end;
end;

function LVSort(lParam1, lParam2: Integer; lParamSort: Integer): Integer; stdcall;
const
  NULL_COMPARE = -1; {-1 floats nulls to top, +1, to bottom}
var
  oLV: TListView;
  iSortCol: Integer;
  bSortAsc: Boolean;
  iSortVarType: Integer;
  vData1: Variant;
  vData2: Variant;
begin
  try
    {resolve the reference to the listview being sorted}
    oLV := TListView(lParamSort);
    {is "no sort" being requested?}
    if oLV.Tag = 0 then
    begin
      {not a very economic use of the data property...}
      Result := Integer(TListItem(lParam1).Data) - Integer(TListItem(lParam2).Data);
      exit;
    end;
    iSortCol := Abs(oLV.Tag) - 1;
    bSortAsc := oLV.Tag >= 0;
    {determine the data type}
    if iSortCol < 0 then
      iSortVarType := varString
    else if iSortCol >= oLV.Columns.Count then
      iSortVarType := varString
    else
    begin
      iSortVarType := oLV.Columns[iSortCol].Tag;
    end;
    {get the data of interest}
    vData1 := LVItemValue(TListItem(lParam1), iSortCol, iSortVarType);
    vData2 := LVItemValue(TListItem(lParam2), iSortCol, iSortVarType);
    {do some "null" handling that supercedes typed comparisons}
    if VarIsNull(vData1) and VarIsNull(vData2) then
      Result := 0 {they're both null}
    else if VarIsNull(vData1) then
      Result := NULL_COMPARE
    else if VarIsNull(vData2) then
      Result := -NULL_COMPARE
    else if vData1 > vData2 then
      Result := 1
    else if vData1 < vData2 then
      Result := -1
    else
    begin
      Result := 0;
    end;
    if not bSortAsc then
      Result := -Result;
  except
    Result := 0;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);

  function RandomNull(const Text: string): string;
  begin
    if Random(8) < 1 then
      Result := ''
    else
    begin
      Result := Text;
    end;
  end;

var
  oCol: TListColumn;
  oItem: TListItem;
  iItem: Integer;
begin
  Randomize;
  {set listview properties}
  with ListView1 do
  begin
    Items.Clear;
    Columns.Clear;
    Align := alClient;
    ReadOnly := True;
    SortType := stNone;
    Tag := 0;
    ViewStyle := vsReport;
  end;
  {default columns of different types}
  oCol := ListView1.Columns.Add;
  oCol.Caption := 'varDate';
  oCol.Tag := varDate;
  oCol.Width := 100;
  oCol := ListView1.Columns.Add;
  oCol.Caption := 'varBoolean';
  oCol.Tag := varBoolean;
  oCol.Width := 100;
  oCol := ListView1.Columns.Add;
  oCol.Caption := 'varInteger';
  oCol.Tag := varInteger;
  oCol.Width := 100;
  oCol := ListView1.Columns.Add;
  oCol.Caption := 'varCurrency';
  oCol.Tag := varCurrency;
  oCol.Width := 100;
  oCol := ListView1.Columns.Add;
  oCol.Caption := 'varString';
  oCol.Tag := varString;
  oCol.Width := 100;
  {add items to the listview}
  for iItem := 0 to 100 + Random(100) do
  begin
    {data property stores "original index" info}
    oItem := ListView1.Items.Add;
    oItem.Data := Pointer(iItem); {using this more like a Tag property}
    {plug in some fake data}
    oItem.Caption := RandomNull(FormatDateTime('dd-mmm-yyyy', Now() - Random(1000)));
    if Random(2) < 1 then
      oItem.SubItems.Add(RandomNull('Yes'))
    else
    begin
      oItem.SubItems.Add(RandomNull('No'));
    end;
    oItem.SubItems.Add(RandomNull(FloatToStr(0.01 * Random(100000))));
    oItem.SubItems.Add(RandomNull(IntToStr(Random(10000))));
    oItem.SubItems.Add(RandomNull(Char(65 + Random(26)) + Char(65 + Random(26)) +
      Char(65 + Random(26)) + Char(65 + Random(26)) + Char(65 + Random(26))));
  end;
end;

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  {sort the sort column and order into the listview's tag}
  if ListView1.Tag = Column.Index + 1 then
    ListView1.Tag := -ListView1.Tag {desc sort}
  else if ListView1.Tag = -(Column.Index + 1) then
    ListView1.Tag := 0 {no sort}
  else
  begin
    ListView1.Tag := Column.Index + 1; {asc sort}
  end;
  {pass the listview such that it will be sent to the sort procedure}
  ListView1.CustomSort(LVSort, Integer(ListView1));
end;

end.

How does the API call to make a dialup network connection look like?

Problem/Question/Abstract:

How does the API call to make a dialup network connection look like?

Answer:

The following code creates an internet connection through dialup networking:

uses
  WinInet;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, Application.Handle) then
    MessageDlg('No internet connection', mtError, [mbOk], 0);
end;

How to determine the size of the Windows taskbar

Problem/Question/Abstract:

How to determine the size of the Windows taskbar

Answer:

Solve 1:

You need to get the Rect in the rc member of the APPBARData structure and subtract the top from the bottom.

procedure TForm1.Button1Click(Sender: TObject);
var
  appbardata: TAppBarData;
  Rect: TRect;
  taskBarHeight: Integer;
begin
  AppBarData.cbSize := 0;
  AppBarData.hWnd := 0;
  AppBarData.rc.Left := 0;
  AppBarData.rc.Top := 0;
  AppBarData.rc.Bottom := 0;
  AppBarData.rc.Right := 0;
  SHAppBarMessage(ABM_GETTASKBARPOS, appbardata);
  Rect := appbardata.rc;
  taskBarHeight := Rect.Bottom - Rect.Top;
  ShowMessage(IntToStr(taskBarHeight));
end;


Solve 2:

function GetTaskBarSize: TRect;
var
  wnd: HWND;
begin
  wnd := FindWindow('Shell_TrayWnd', nil);
  if wnd > 0 then
    GetWindowRect(wnd, Result)
  else
    Result := Rect(0, 0, 0, 0);
end;


Solve 3:

This is one way to get the height of the taskbar:

function GetTaskBarRect: TRect;
var
  TBData: TAppBarData;
begin
  TBData.cbSize := sizeof(TAppBarData);
  SHAppBarMessage(ABM_GETTASKBARPOS, TBData);
  Result := TBData.rc;
end;

How to automatically delete records in a database after 30 days

Problem/Question/Abstract:

Can anyone suggest an elegant way of automatically deleting database records if they are more than say 30 days old?

Answer:

Use a TQuery. Replace Table1.Tablename with your Tablename and replace FieldDate with the Date Field.

var
  MyDate: TDateTime;
begin
  MyDate := Date - 30;
  Query1.Active := False;
  Query1.SQL.Clear;
  Query1.SQL.Add('DELETE FROM "' + Table1.TableName + '"');
  Query1.SQL.Add('WHERE (FieldDate = "' + FormatDateTime('mm/dd/yyyy', MyDate) + '")');
  Query1.Active := True;
end;

How to mirror text horizontally or vertically on a TPaintBox

Problem/Question/Abstract:

How to mirror text horizontally or vertically on a TPaintBox

Answer:

This is actually not quite straightforward. The best way to do that is to first paint the text onto an off-screen bitmap and then paint that bitmap on screen using some weird coordinate manipulations. Drop a TPaintbox on the screen and connect a method to its OnPaint handler. Change the handler to the code below to see how this works:

procedure TForm1.PaintBox1Paint(Sender: TObject);
const
  test = 'Hello world';
var
  bmp: TBitmap;
  cv: TCanvas;
  ext: TSize;
  r: TRect;
begin
  cv := (Sender as TPaintbox).canvas;
  ext := cv.TextExtent(test);
  bmp := TBitmap.Create;
  try
    bmp.Width := ext.cx;
    bmp.Height := ext.cy;
    bmp.Canvas.Brush := cv.Brush;
    bmp.Canvas.Font := cv.Font;
    bmp.Canvas.FillRect(bmp.canvas.cliprect);
    bmp.Canvas.TextOut(0, 0, test);
    {draw text in normal orientation}
    cv.Draw(0, 0, bmp);
    r := Rect(ext.cx, 0, 0, ext.cy);
    OffsetRect(r, 0, ext.cy);
    {draw text horizontally mirrored}
    cv.CopyRect(r, bmp.canvas, bmp.canvas.ClipRect);
    r := Rect(0, ext.cy, ext.cx, 0);
    OffsetRect(r, 0, 2 * ext.cy);
    {draw text vertically mirrored}
    cv.CopyRect(r, bmp.canvas, bmp.canvas.ClipRect);
  finally
    bmp.Free
  end;
end;

The key here is to set up the target rectangle for CopyRect with left and right or top and bottom switched. Be warned, there is a slight potential that this code will cause acute indigestion for some video drivers!