How to play sound from a resource file

Problem/Question/Abstract:

I am attempting to have a wave file played when a button is clicked. Rather than install the wave file and use the PlaySound() API call, I'd like to put it into a resource file so that it plays with only the EXE present.

Answer:

{ ... }
var
  FindHandle, ResHandle: THandle;
  ResPtr: Pointer;
begin
  FindHandle := FindResource(HInstance, 'Name of your resource', 'WAVE');
  if FindHandle <> 0 then
  begin
    ResHandle := LoadResource(HInstance, FindHandle);
    if ResHandle <> 0 then
    begin
      ResPtr := LockResource(ResHandle);
      if ResPtr <> nil then
        SndPlaySound(PChar(ResPtr), snd_ASync or snd_Memory);
      UnlockResource(ResHandle);
    end;
    FreeResource(FindHandle);
  end;
end;

How to paint on a TControlCanvas in a TMemo

Problem/Question/Abstract:

How to paint on a TControlCanvas in a TMemo

Answer:

Solve 1:

Create a new component derived from TMemo and override its drawing. Something like this:


type
  TMyMemo = class(TMemo)
  protected
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  end;

procedure TMyMemo.WMPaint(var Message: TWMPaint);
var
  MCanvas: TControlCanvas;
  DrawBounds: TRect;
begin
  inherited;
  MCanvas := TControlCanvas.Create;
  DrawBounds := ClientRect;
  try
    MCanvas.Control := Self;
    with MCanvas do
    begin
      Brush.Color := clBtnFace;
      FrameRect(DrawBounds);
      InflateRect(DrawBounds, -1, -1);
      FrameRect(DrawBounds);
      FillRect(DrawBounds);
      MoveTo(33, 0);
      Brush.Color := clWhite;
      LineTo(33, ClientHeight);
      PaintImages;
    end;
  finally
    MCanvas.Free;
  end;
end;


The PaintImages procedure draws images on the TMemo's canvas.


procedure TMyMemo.PaintImages;
var
  MCanvas: TControlCanvas;
  DrawBounds: TRect;
  i, j: Integer;
  OriginalRegion: HRGN;
  ControlDC: HDC;
begin
  MCanvas := TControlCanvas.Create;
  DrawBounds := ClientRect;
  try
    MCanvas.Control := Self;
    ControlDC := GetDC(Handle);
    MCanvas.Draw(0, 1, Application.Icon);
  finally
    MCanvas.Free;
  end;
end;


Solve 2:

Basically you will need to intercept WM_ERASEBKGND and WM_PAINT messages. Let's say you have a TImage control the same size as your TMemo holding a bitmap that you want to use as your background. Let's assume you have this hooked in a TImage field called FImage available in your memo component code. The following should give you a good start:

In your class definition for TMyMemo:


procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    {...}

procedure TMyMemo.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
  {assuming we get a good DC in Message - you should check this of course}
  BitBlt(Message.dc, 0, 0, Width, Height, FImage.Canvas.Handle, 0, 0, SRCCOPY);
  Message.Result := -1;
end;

procedure TMyMemo.WMPaint(var Message: TWMPaint);
var
  bm: TBitmap;
  dc: HDC;
  hDummy: HWND;
  i: integer;
  tm: TEXTMETRIC;
  Y: integer;
begin
  bm := TBitmap.Create;
  try
    bm.Width := Width;
    bm.Height := Height;
    Perform(WM_ERASEBKGND, bm.Canvas.Handle, 0); {always in this simple example}
    bm.Canvas.Font.Assign(Font);
    GetTextMetrics(bm.Canvas.Handle, tm);
    SetBkMode(bm.Canvas.Handle, TRANSPARENT);
    Y := 0;
    for i := 0 to Lines.Count - 1 do
    begin
      bm.Canvas.TextOut(0, Y, Lines[i]);
      Inc(Y, tm.tmHeight);
    end;
    dc := GetDeviceContext(hDummy);
    BitBlt(dc, 0, 0, Width, Height, bm.Canvas.Handle, 0, 0, SRCCOPY);
    ReleaseDC(hDummy, dc);
  finally
    bm.Free;
  end;
  Message.Result := 0;
end;


Note that this is only good for displaying transparently. Editing is another story. What I do is call the inherited behavior when I'm editing (so no transparency while typing). Obviously this example has no error checking. Also, the Message parameter for WM_PAINT may contain a device context to use in lieu of GetDeviceContext. The text always draws at X = 0 so it ignores the border style & width. Finally, you should check for clipping to improve performance (I did this last).

Incremental search in a DBGrid

Problem/Question/Abstract:

When you fill a DBGrid with Data from a Query you can search for each column of the Grid, with a TEdit.

Answer:

Here is a sample project:

// Makes incremental search in a DBGrid with a TEdit

unit U_Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, StdCtrls, Grids, DBGrids, ExtCtrls, DBCtrls;

type
  TFm_Main = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    qry_Data: TQuery;
    Ds_Data: TDataSource;
    dbg_Data: TDBGrid;
    Label1: TLabel;
    Ed_Search: TEdit;
    Database1: TDatabase;
    qry_DataNUM_FACTURA: TStringField;
    qry_DataF_FACTURA: TDateTimeField;
    qry_DataM_DEVENGADO: TFloatField;
    DBNavigator1: TDBNavigator;
    procedure dbg_DataTitleClick(Column: TColumn);
    procedure FormCreate(Sender: TObject);
    procedure Ed_SearchChange(Sender: TObject);

  private
    FQueryStatement: string;

    //Since for Alphanumeric Field you don�t need to validate nothing
    //just keep a method pointer to the default Event Handler
    FALphaNumericKeyPress: TKeyPressEvent;
  public
    property QueryStatement: string read FQueryStatement;

    //Since we are going to search in various Fields wich DataType
    //can be of diferent types, we must validate the user input on
    //the OnkeyPress of the TEdit, but instead of building a super
    //generic routine, lets make things simple. Build a separate
    //method for each DataType you are interested in validate.

    //I will only validate for Fields of type ftFloat, but you easily
    //customize the code for your own needs..

    //Method Pointer for Fields of DataType ftFloat
    procedure FloatOnKeyPress(Sender: TObject; var Key: Char);
  end;

var
  Fm_Main: TFm_Main;

implementation

{$R *.DFM}

procedure TFm_Main.dbg_DataTitleClick(Column: TColumn);
var
  vi_Counter: Integer;
  vs_Field: string;
begin
  with dbg_Data do
  begin
    //First, deselect all the Grid�s Columns
    for vi_Counter := 0 to Columns.Count - 1 do
      Columns[vi_Counter].Color := clWindow;

    //Next "Select" the column the user has Clicked on
    Column.Color := clTeal;

    //Get the FieldName of the Selected Column
    vs_Field := Column.FieldName;

    //Order the Grid�s Data by the Selected column
    with qry_Data do
    begin
      DisableControls;
      Close;
      SQL.Clear;
      SQL.Text := QueryStatement + 'ORDER BY ' + vs_Field;
      Open;
      EnableControls;
    end;

    //Get the DataType of the selected Field and change the Edit�s event
    //OnKeyPress to the proper method Pointer
    case Column.Field.DataType of
      ftFloat: Ed_Search.OnKeyPress := FloatOnKeyPress;
    else
      Ed_Search.OnKeyPress := FALphaNumericKeyPress;
    end;
  end;
end; //End of TFm_Main.dbg_DataTitleClick

procedure TFm_Main.FloatOnKeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['0'..'9', #13, #8, #10, #46]) then
    Key := #0;
end; //End of TFm_Main.FloatOnKeyPress

procedure TFm_Main.FormCreate(Sender: TObject);
begin
  //Keep a pointer for the default event Handler
  FALphaNumericKeyPress := Ed_Search.OnKeyPress;

  //Set the original Query SQL Statement
  FQueryStatement := 'SELECT FIELD1, FIELD2, FIELD3 '
    'FROM ANYTABLE ';

  //Select the first Grid�s Column
  dbg_DataTitleClick(dbg_Data.Columns[0]);
end; //End of TFm_Main.FormCreate

procedure TFm_Main.Ed_SearchChange(Sender: TObject);
var
  vi_counter: Integer;
  vs_Field: string;
begin
  with dbg_Data do
  begin
    //First determine wich is the Selected Column
    for vi_Counter := 0 to Columns.Count - 1 do
      if Columns[vi_Counter].Color = clTeal then
      begin
        vs_Field := Columns[vi_Counter].FieldName;
        Break;
      end;

    //Locate the Value in the Query
    with qry_Data do
      case Columns[vi_Counter].Field.DataType of
        ftFloat: Locate(vs_Field, StrToFloat(Ed_Search.Text),
            [loCaseInsensitive, loPartialKey]);
      else
        Locate(vs_Field, Ed_Search.Text, [loCaseInsensitive,
          loPartialKey]);
      end;
  end;
end; //End of TFm_Main.Ed_SearchChange

end.

So, you can customize the code to manage another DataTypes of TFields.

An example of drag and drop between DBGrids

Problem/Question/Abstract:

This sample component and sample project demonstrates an easy way of enabling drag and drop of an arbitrary field in one data aware grid onto an arbitrary field in another data aware grid.

Answer:

An example of drag and drop between DBGrids - by Borland Developer Support Staff

Technical Information Database

TI1562D.txt - An example of drag and drop between DBGrids

Category   :General Programming
Platform   :All Windows
Product    :All32Bit,  

Description:
Title: An example of drag and drop between DBGrids

This sample component and sample project demonstrates an easy way of enabling drag and drop of an arbitrary field in one data aware grid onto an arbitrary field in another data aware grid.

Launch Delphi x.xx (the code will work in 1 and 2 as well with some minor changes).

Do a File|New|Unit. Take the MyDBGrid unit (below) and paste it in the newly created unit. Do a File|Save As. Save the unit as MyDBGrid.pas.

Do a Component|Install Component. Switch to the Info New Package tab. Put MyDBGrid.pas in the Unit file name box. Call the package MyPackage.dpk. Hit Yes when Delphi tells you that the package will be built and installed. Hit OK when Delphi tells you that VCLxx.DPL is needed. The package will now be rebuilt and installed. You will now find the TMyDBGrid component on your Samples tab on your component palette. Close the package editor and save the package.

Do a File|New Application. Right click on the form (Form1) and select View As Text. Take the GridU1 form source (below) and paste it in Form1. Right click on the form and select View As Form. This may take a few moments since it's opening up the tables for you. Take the GridU1 unit (below) and paste it in the unit (Unit1).

Do a File|Save Project As. Save the unit as GridU1.pas. Save the project as GridProj.dpr.

Now, run the project and enjoy the dragging and dropping of fields inbetween or with the two grids.


The MyDBGrid unit

unit MyDBGrid;

interface

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

type
  TMyDBGrid = class(TDBGrid)
  private
    { Private declarations }
    FOnMouseDown: TMouseEvent;
  protected
    { Protected declarations }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  published
    { Published declarations }
    property Row;
    property OnMouseDown read FOnMouseDown write FOnMouseDown;
  end;

procedure Register;

implementation

procedure TMyDBGrid.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
  inherited MouseDown(Button, Shift, X, Y);
end;

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

end.

The GridU1 unit

unit GridU1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;

type
  TForm1 = class(TForm)
    MyDBGrid1: TMyDBGrid;
    Table1: TTable;
    DataSource1: TDataSource;
    Table2: TTable;
    DataSource2: TDataSource;
    MyDBGrid2: TMyDBGrid;
    procedure MyDBGrid1MouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MyDBGrid1DragOver(Sender, Source: TObject;
      X, Y: Integer; State: TDragState; var Accept: Boolean);
    procedure MyDBGrid1DragDrop(Sender, Source: TObject;
      X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  SGC: TGridCoord;

procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DG: TMyDBGrid;
begin
  DG := Sender as TMyDBGrid;
  SGC := DG.MouseCoord(X, Y);
  if (SGC.X > 0) and (SGC.Y > 0) then
    (Sender as TMyDBGrid).BeginDrag(False);
end;

procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: Boolean);
var
  GC: TGridCoord;
begin
  GC := (Sender as TMyDBGrid).MouseCoord(X, Y);
  Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;

procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;
  X, Y: Integer);
var
  DG: TMyDBGrid;
  GC: TGridCoord;
  CurRow: Integer;
begin
  DG := Sender as TMyDBGrid;
  GC := DG.MouseCoord(X, Y);
  with DG.DataSource.DataSet do
  begin
    with (Source as TMyDBGrid).DataSource.DataSet do
      Caption := 'You dragged "' + Fields[SGC.X - 1].AsString + '"';
    DisableControls;
    CurRow := DG.Row;
    MoveBy(GC.Y - CurRow);
    Caption := Caption + ' to "' + Fields[GC.X - 1].AsString + '"';
    MoveBy(CurRow - GC.Y);
    EnableControls;
  end;
end;

end.

The GridU1 form

object Form1: TForm1
  Left = 200
    Top = 108
    Width = 544
    Height = 437
    Caption = 'Form1'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    PixelsPerInch = 96
    TextHeight = 13
    object MyDBGrid1: TMyDBGrid
    Left = 8
      Top = 8
      Width = 521
      Height = 193
      DataSource = DataSource1
      Row = 1
      TabOrder = 0
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object MyDBGrid2: TMyDBGrid
    Left = 7
      Top = 208
      Width = 521
      Height = 193
      DataSource = DataSource2
      Row = 1
      TabOrder = 1
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object Table1: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'ORDERS'
      Left = 104
      Top = 48
  end
  object DataSource1: TDataSource
    DataSet = Table1
      Left = 136
      Top = 48
  end
  object Table2: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'CUSTOMER'
      Left = 104
      Top = 240
  end
  object DataSource2: TDataSource
    DataSet = Table2
      Left = 136
      Top = 240
  end
end

Change the TreeView item height

Problem/Question/Abstract:

How to change the TreeView item height?

Answer:

uses CommCtrl;

{ .... }

procedure SetTreeViewItemHeight(aTreeView: TTreeView; aItemHeight: Word);
begin
aTreeView.Perform(TVM_SETITEMHEIGHT, aItemHeight, 0);
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
SetTreeViewItemHeight(TreeView1, 30);
end;

How to fix the MDI close button and window menu glitches

Problem/Question/Abstract:

I am trying to write a MDI application. I use a main form with a MainMenu. Every child form merges its main menu in the main form's main menu. If one of the child forms gets maximized, the close button (x button in the upper right corner) is grayed out but still works. If I merge the child form's main menu manually, the close button behaves in the same way.

Answer:

Solve 1:

I have tried the following patch to Menus.pas and it works wonders for me. The button no longer disappears or disable and the window menu functions after changes are made to it. I would like to know how well this works for them. Neither of these two fixes are 'hacks' into that they don't cause extra flashing or refreshing. They just fix the 'problematic' code in Menus.pas. The below snippits of code are based on D5.

procedure TMenuItem.RebuildHandle;
const
  cFAF = $04;
var
  I: Integer;
  LRepopulate: Boolean;
begin
  if csDestroying in ComponentState then
    Exit;
  if csReading in ComponentState then
    FStreamedRebuild := True
  else
  begin
    if FMergedWith <> nil then
      FMergedWith.RebuildHandle
    else
    begin
      I := GetMenuItemCount(Handle);
      LRepopulate := I = 0;
      while I > 0 do
      begin
        if (WordRec(LongRec(GetMenuState(Handle, I - 1, MF_BYPOSITION)).Lo).Lo and
          cFAF) = 0 then
        begin
          RemoveMenu(Handle, I - 1, MF_BYPOSITION);
          LRepopulate := True;
        end;
        Dec(I);
      end;
      if LRepopulate then
      begin
        if (FParent = nil) and (FMenu is TMainMenu) and (GetMenuItemCount(Handle) = 0)
          then
        begin
          DestroyMenu(FHandle);
          FHandle := 0;
        end
        else
          PopulateMenu;
        MenuChanged(False);
      end;
    end;
  end;
end;

function TMenu.DispatchPopup(AHandle: HMENU): Boolean;

  function IsMDIWindowMenu(AItem: TMenuItem): Boolean;
  begin
    Result := Assigned(Application.MainForm) and (Application.MainForm.FormStyle =
      fsMDIForm)
      and (Application.MainForm.WindowMenu = AItem);
  end;

var
  Item: TMenuItem;
  LRebuild: Boolean;
begin
  Result := False;
  Item := FindItem(AHandle, fkHandle);
  if Item <> nil then
  begin
    if not (csDesigning in Item.ComponentState) then
      Item.InitiateActions;
    Item.Click;
    LRebuild := Item.InternalRethinkHotkeys(False);
    LRebuild := Item.InternalRethinkLines(False) or LRebuild;
    if LRebuild then
      Item.RebuildHandle;
    if IsMDIWindowMenu(Item) then
      if SendMessage(Application.MainForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0) <> 0
        then
        DrawMenuBar(Application.MainForm.Handle);
    Result := True;
  end
  else if not (csDesigning in ComponentState) and (Self is TPopupMenu) then
    Items.InitiateActions;
end;

You cannot recompile the standard packages, your license does not allow it and there are some units missing anyway. Copy the menus unit to your project directory, modify the copy, and compile it as part of your project. You can copy the produced DCU back into the LIB directory for other projects to use. This will work as long as you don't build with packages and don't change anything in the units interface.


Solve 2:

This piece of code fixes a bug present in all versions of Delphi, that occurs when switching between maximized MDI child windows, causing the close icon to be grayed in Delphi 3 & 4 or the system menu and max/min/close icons to vanish in Delphi 5. Tested in Delphi Client/Server 3, 4 & 5.

{$IFDEF VER100}
{$DEFINE DELPHI3&4}
{$ENDIF}

{$IFDEF VER120}
{$DEFINE DELPHI3&4}
{$ENDIF}

type
  TMDIChild = class(TForm)
    { ... }
  private
    procedure WMMDIActivate(var Msg: TWMMDIActivate); message WM_MDIACTIVATE;
    { ... }
  end;

procedure TMDIChild.WMMDIActivate;
var
  Style: Longint;
begin
  if (Msg.ActiveWnd = Handle) and (biSystemMenu in BorderIcons) then
  begin
    Style := GetWindowLong(Handle, GWL_STYLE);
    if (Style and WS_MAXIMIZE <> 0) and (Style and WS_SYSMENU = 0) then

{$IFDEF DELPHI3&4}
      SetWindowLong(Handle, GWL_STYLE, Style or WS_SYSMENU);
{$ELSE}
      SendMessage(Handle, WM_SIZE, SIZE_RESTORED, 0);
{$ENDIF}
  end;
  inherited;
end;

How to compare the items in a TStringList with the items in the child nodes of a selected node in a TTreeView

Problem/Question/Abstract:

I would like to compare the items in a TStringList with the child nodes of the selected node in a TTreeView and instead of deleting the matching nodes, change the image of the node to one from a TImageList component.

Answer:

Solve 1:

Something like:

var
  T: TTreeNode;
begin
  {Point at the first child of the selected node}
  T := TreeView.Selected.GetFirstChild;
  {Loop over all children of this node}
  while Assigned(T) do
  begin
    {Compare T.Text against contents of a listbox, or whatever...}
    {T set to nil if Selected has no more children}
    T := TreeView.Selected.GetNextChild(T);
  end;
end;

Note this only works with direct children of the Selected node; if you may have to deal with deeper levels in the tree then it gets (marginally) more complex.


Solve 2:

Try one of these:

{ ... }
for i := 0 to TreeView1.Selected.Count - 1 do
  if ListBox1.Items.IndexOf(TreeView1.Selected.Item[i].Text) >= 0 then
    TreeView1.Selected.Item[i].ImageIndex := 4;
{ ... }

var
  child: TTreeNode;
  { ... }
  child := TreeView1.Selected.GetFirstChild;
  while Assigned(child) do
  begin
    if ListBox1.Items.IndexOf(child.Text) >= 0 then
      child.ImageIndex := 4;
    child := child.GetNextSibling
  end;

How to enum font sizes like TFontDialog does

Problem/Question/Abstract:

I would like to get all font sizes for the given font like TFontDialog does. Minimum and maximum font size would be nice, too.

Answer:

Note that the list of font sizes for Truetype fonts is just an arbitrary selection of often-used sizes, you can scale these fonts to nearly any size.

Example for the use of EnumFontFamilies. Project requires two listboxes on the form, nothing else.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  listbox1.items.assign(screen.fonts);
end;

function EnumProc(var elf: TEnumLogFont; var ntm: TNewTextmetric;
  fonttype: Integer; listbox: TListbox): Integer; stdcall;
var
  S: string;
begin
  if fonttype = TRUETYPE_FONTTYPE then
  begin
    listbox.Items.Add(Format('Name: %s', [elf.elfFullName]));
    listbox.Items.Add(Format('Style: %s', [elf.elfStyle]));
  end
  else
    listbox.Items.Add(Format('Name: %s', [elf.elfLogfont.lfFacename]));
  listbox.Items.Add(Format('Size: %d', [elf.elfLogFont.lfHeight]));
  listbox.Items.Add(Format('Weight: %d', [elf.elfLogFont.lfWeight]));
  if elf.elfLogFont.lfItalic <> 0 then
    listbox.Items.Add('This font is italic');
  case fonttype of
    DEVICE_FONTTYPE: S := 'device font';
    RASTER_FONTTYPE: S := 'raster font';
    TRUETYPE_FONTTYPE: S := 'truetype font'
  else
    S := 'unknown font type';
  end;
  listbox.Items.Add(Format('This is a %s', [S]));
  Result := 1;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  listbox2.clear;
  with listbox1 do
    if ItemIndex >= 0 then
      EnumFontFamilies(Self.Canvas.Handle, PChar(Items[ItemIndex]),
        @EnumProc, Longint(listbox2));
end;

end.

Hide and show the title bar of a TForm

Problem/Question/Abstract:

How to hide and show the title bar of a TForm

Answer:

Here is how to hide the titlebar:

procedure TYourFormName.HideTitlebar;
var
  Save: LongInt;
begin
  if BorderStyle = bsNone then
    Exit;
  Save := GetWindowLong(Handle, GWL_STYLE);
  if (Save and WS_CAPTION) = WS_CAPTION then
  begin
    case BorderStyle of
      bsSingle, bsSizeable:
        SetWindowLong(Handle, GWL_STYLE, Save and (not (WS_CAPTION)) or WS_BORDER);
      bsDialog:
        SetWindowLong(Handle, GWL_STYLE, Save and (not (WS_CAPTION)) or DS_MODALFRAME
          or WS_DLGFRAME);
    end;
    Height := Height - GetSystemMetrics(SM_CYCAPTION);
    Refresh;
  end;
end;

And here is how we show it again:

procedure TYourFormName.ShowTitlebar;
var
  Save: LongInt;
begin
  if BorderStyle = bsNone then
    Exit;
  Save := GetWindowLong(Handle, GWL_STYLE);
  if (Save and WS_CAPTION) <> WS_CAPTION then
  begin
    case BorderStyle of
      bsSingle, bsSizeable:
        SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or WS_BORDER);
      bsDialog:
        SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or DS_MODALFRAME or
          WS_DLGFRAME);
    end;
    Height := Height + GetSystemMetrics(SM_CYCAPTION);
    Refresh;
  end;
end;

How to compare two images pixel by pixel

Problem/Question/Abstract:

How can I compare an image pixel by pixel. The images have the same size. But that is accepted that the images have a fault tolerance up 10%.

Answer:

Solve 1:

{ ... }
for x := 0 to image1.width - 1 do
  for y := 0 to image1.height - 1 do
    if image1.picture.bitmap.canvas.pixels[x, y] <>
      image2.picture.bitmap.canvas.pixels[x, y] then
      inc(different);

if different > (image1.width * image1.height / 10) then
  picturedifferent;


Solve 2:

A faster approach:

{ ... }
var
  b1, b2: TBitmap;
  c1, c2: PByte;
  x, y, i, different: integer;
begin
  b1 := Image1.Picture.Bitmap;
  b2 := Image2.Picture.Bitmap;
  assert(b1.PixelFormat = b2.PixelFormat); {they have to be equal}
  different := 0;
  for y := 0 to b1.Height - 1 do
  begin
    c1 := b1.Scanline[y];
    c2 := b2.Scanline[y];
    for x := 0 to b1.Width - 1 do
      for i := 0 to BytesPerPixel - 1 do {1, to 4, dep. on pixelformat}
      begin
        inc(different, integer(c1^ <> c2^));
        inc(c1);
        inc(c2);
      end;
  end;
end;

Using an Int for "different" means your pictures can be at most 715827882 pixels large, or 26754 x 26754, which should be enough for most uses. Depending on how you want to count "equal" you could enforce 32bits per pixel and use PLongWord instead, ditching the BytesPerPixel loop.

Create a Combobox winthin in a Stringgrid

Problem/Question/Abstract:

How to dynamically create a Combobox within a Cell of a StringGrid

Answer:

You need a descendent of TStringgrid that properly reflects WM_COMMAND to embedded controls. The standard grid does not do it since it is not intended to play parent to other controls.

Additionaly simply declare a Set- and GetMethod to access the items of die combobox

unit BWControlStringGrid;

interface

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

type
  TBWControlStringGrid = class(TStringGrid)
  private
    fComboBox: TCombobox;
    procedure WMCommand(var msg: TWMCommand); message WM_COMMAND;
    procedure DblClick; override;
    procedure Click; override;
    procedure RelocateComboBox;
    procedure HideCombobox;
  protected
    procedure KeyPress(var Key: Char); override;
  public
    constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  published
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('hEaDRoOm', [TBWControlStringGrid]);
end;

procedure TBWControlStringGrid.WMCommand(var msg: TWMCommand);
begin
  if EditorMode and (msg.Ctl = fComboBox.Handle) then
    inherited
  else if msg.Ctl <> 0 then
    msg.result :=
      SendMessage(msg.ctl, CN_COMMAND,
      TMessage(msg).wparam,
      TMessage(msg).lparam);
end;

procedure TBWControlStringGrid.KeyPress(var Key: Char);
begin
  if Key = #13 then
    RelocateComboBox
  else
    HideCombobox;

end;

procedure TBWControlStringGrid.DblClick;
begin
  inherited;
  RelocateComboBox;
end;

procedure TBWControlStringGrid.Click;
begin
  inherited;
  HideCombobox;
end;

procedure TBWControlStringGrid.RelocateComboBox;
begin
  fcombobox.boundsrect := CellRect(Selection.Left, Selection.Top);
  fcomboBox.Visible := TRUE;
  fcombobox.setfocus;
end;

procedure TBWControlStringGrid.HideCombobox;
begin
  fcomboBox.Visible := false;
end;

constructor TBWControlStringGrid.Create(AOWner: TComponent);
begin
  inherited Create(Aowner);
  fComboBox := TComboBox.Create(self);
  fComboBox.Parent := self;
  fComboBox.Visible := FALSE;
  Options := Options - [goRangeSelect];
end;

destructor TBWControlStringGrid.Destroy;
begin
  fComboBox.Destroy;
  inherited destroy;
end;

end.

This is great, but is just the skeleton, of course..

There needs to be some mechansim for getting the combo's text/selection into the cell, also for relaying the cells contents into the combo in the first place.

This can be done in the Hide and Relocate methods.

The whole thing can get unwieldy if you add a lot of get/set methods for updating the combos dropdownlist, etc, so making the Combo a Public property, rather than just a private field might help with that - the onus is then on the programmer to deal with the combo directly - it is unlikely, for instance, that the dropdownlist would be the same for each column.

Or two new events could be triggered - OnHide and OnRelocate
eg:

TComboVisibleChangeEvent = procedure(Sender: TObject; Row, Col: Longint; Combo:
  TComboBox; AllowVisibleChange: boolean) of object

fOnHide: TComboVisibleChangeEvent;
fOnRelocate: TComboVisibleChangeEvent;

etc.

This way the Combo would be make public when needed. When the Relocate fires, the dropdownlist could be repopulated, etc

Just ideas for whoever wants them!

Remove the border of a TPageControl

Problem/Question/Abstract:

How to remove the border of a TPageControl

Answer:

{TPageControlEx component
Copyright (c) 1998 Sigbjoern Revheim, Sigbjoern@mad.scientist.com
This component removes the border of the pagecontrol only if there are one ore more tabs.}

unit PageControlEx;

interface

uses
  Windows, Messages, Classes, CommCtrl, ComCtrls, Controls;

type
  TPageControlEx = class(TPageControl)
  private
    FThickFrame: Boolean;
    procedure SetThickFrame(const Value: Boolean);
  protected
    procedure WndProc(var Msg: TMessage); override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property ThickFrame: Boolean read FThickFrame write SetThickFrame default true;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Extra', [TPageControlEx]);
end;

constructor TPageControlEx.Create(AOwner: TComponent);
begin
  inherited;
  FThickFrame := True;
  {DoubleBuffered := True;}
  ParentBackground := False;
end;

procedure TPageControlEx.CreateParams(var Params: TCreateParams);
begin
  inherited;
  {BorderWidth := 0;}
  {Params.Style := Params.Style or WS_POPUP;}
  ParentBackground := False;
end;

procedure TPageControlEx.SetThickFrame(const Value: Boolean);
begin
  if FThickFrame <> Value then
  begin
    FThickFrame := Value;
    RecreateWnd;
  end;
end;

procedure TPageControlEx.WndProc(var Msg: TMessage);
begin
  inherited WndProc(Msg);
  if not FThickFrame and (Msg.Msg = TCM_ADJUSTRECT) then
    with PRect(Msg.LParam)^ do
    begin
      Left := 0;
      Right := ClientWidth;
      Top := Top - 8;
      Bottom := ClientHeight;
    end;
end;

end.

Least squares line fitting in Delphi

Problem/Question/Abstract:

Least squares line fitting in Delphi

Answer:

Example that finds least squares fit for y = Mx + c

procedure LeastSquares(X, Y: array of Extended; var M: Extended; var C: Extended);
var
  SumX, SumY, SumX2, SumXY: Extended;
  n, i: Integer;
begin
  if High(X) <> High(Y) then
    raise
      Exception.Create('LeastSquares() Error - Input X & Y arrays must be
                         of the same length');
  n := High(X) + 1;
  SumX := 0.0;
  SumY := 0.0;
  SumX2 := 0.0;
  SumXY := 0.0;
  for i := 0 to n - 1 do
  begin
    SumX := SumX + X[i];
    SumY := SumY + Y[i];
    SumX2 := SumX2 + (X[i] * X[i]);
    SumXY := SumXY + (X[i] * Y[i]);
  end;
  if (n * SumX2) = (SumX * SumX) then
    raise Exception.Create('LeastSquares() Error - X Values cannot all be the same');
  M := ((SumY * SumX2) - (SumX * SumXY)) / ((n * SumX2) - (SumX * SumX));
  C := ((n * SumXY) - (SumX * SumY)) / ((n * SumX2) - (SumX * SumX));
end;

A Simple Property Editor (2)

Problem/Question/Abstract:

Sometimes, when you create components, you want to make it easier for the developers to use them. This is the time to develop a property editor.

Answer:

INTRODUCTION

In this article I will give you a short introduction to property editor development. This property editor developed here will simlpy allow you to edit string and TCaption properties in a better way, allowing you to add line breaks to strings.

There are two reasons for this property editor. First it is great to add line breaks into the labels caption, second it is fairly simple, therefore a good start for developing a property editor.

STEPS IN CREATING A PROPERTY EDITOR

First a short list of considerations when creating a property editor.

How should the property editor support the developer?
Which components/properties/data types should the editor support?
When do you have enough time to write it? :)

How do we support the developer?

Well, as I have written before, we will give the developer a simple way of adding line breaks to. The form we will create with the Delphi form designer, jsut as we do always. We add a public procedure to it, that will take the old value, load it into a memo field, show the form and return the either new value or the old if the user has not confirmed the changes.

Which components/properties/data are supported?

We will support all components and properties of the types string and TCaption.

DESIGING THE FORM

Start Delphi and close all open files. Create a new form and name it frmStringEditor. Add a memo field to the form and name it mmoStringProperty. Now we need to buttons, one for "OK" and one for "Cancel." Thats all for the design part. Make it fit "nicely." Add event handlers to the to button click procedures!

We will add one public procedure that will accomplish the form show and decide, whether the property is changed or not.

function Edit(var Data: string): Boolean;

The remaining code comes a little later.

CREATING THE PROPERTY EDITOR CLASS

All Property Editors have to be a descendend of the TPropertyEditor class. In our case we will descend from the TStringProperty class, that itself descends from the one previously named.

There are two function we need to override. GetAttributes to tell Delphi that we provide a dialog to manipulate the property. Edit is the function called when the developer calls for the property editor dialog.

TOurStringProperty = class(TStringProperty)
public
  function GetAttributes: TPropertyAttributes; override;
  procedure Edit; override;
end;

The remaining code comes a little later, too.

REGISTERING THE PROPERTY EDITOR

We will install the property editor just like we install components, therefore we have to provide the Register property. In the body we will add a call to the RegisterPropertyEditor function. This function takes four parameters.

Information about the property type handled by the editor
The component/control class this editor is for (nil for all)
The property this editor is for ('' for all)
The property editor class itself

AND NOW THE WHOLE CODE

I have placed this all into one unit developed on Delphi 5 and tested with Delphi 6 Evaluation version. You will need at least the Professional Editions to get it working. Earlier versions of Delphi should work just fine. Cannot test on them, sorry.

This unit assumes that you saved your form under the name of uStringEditor.

unit uStringEditor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, TypInfo
{$IFNDEF VER140}
  , DsgnIntf
{$ELSE}
  , DesignEditors, DesignIntf
{$ENDIF}
  ;

type
  TfrmStringEditor = class(TForm)
    mmoStringProperty: TMemo;
    btnOK: TButton;
    btnCancel: TButton;
    procedure btnOKClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
  private
  public
    function Edit(var Data: string): Boolean;
  end;

  TOurStringProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
  end;

procedure Register;

implementation

{$R *.DFM}

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(TCaption), nil, '', TOurStringProperty);
  RegisterPropertyEditor(TypeInfo(string), nil, '', TOurStringProperty);
end;

function EditConnectionString(
  Component: TComponent; PropInfo: PPropInfo
  ): Boolean;
var
  Str: string;
begin
  Result := False;
  with TfrmStringEditor.Create(Application) do
  try
    Caption := Format('%s.%s string editor', [Component.Name, PropInfo^.Name]);
    Str := GetStrProp(Component, PropInfo);
    if Edit(Str) then
    begin
      SetStrProp(Component, PropInfo, Str);
      Result := True;
    end;
  finally
    Free;
  end;
end;

{ TOurStringProperty }

procedure TOurStringProperty.Edit;
begin
  if EditConnectionString(GetComponent(0) as TComponent, GetPropInfo)
    then
    Modified;
end;

function TOurStringProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog];
end;

{ TfrmStringEditor }

procedure TfrmStringEditor.btnCancelClick(Sender: TObject);
begin
  ModalResult := mrCancel;
end;

procedure TfrmStringEditor.btnOKClick(Sender: TObject);
begin
  ModalResult := mrOk;
end;

function TfrmStringEditor.Edit(var Data: string): Boolean;
begin
  mmoStringProperty.Text := Data;
  if ShowModal = mrOK then
  begin
    Result := Data <> mmoStringProperty.Text;
    Data := mmoStringProperty.Text;
  end
  else
  begin
    Result := False;
  end;
end;

end.

INSTALLING IT

Go to the menu Component | Install Component..., select the your file from the disk and press "OK." After compiling and saving the package you are finished. You may have to restart Delphi for the changes to take place.

How to get BIOS information?

Problem/Question/Abstract:

This code shows you some information about your BIOS:

Answer:

procedure TForm1.FormCreate(Sender: TObject);
begin
  try
    Label1.Caption := string(PChar(Ptr($FE061))); // BIOS Name
    Label2.Caption := string(PChar(Ptr($FE091))); // Copyright
    Label3.Caption := string(PChar(Ptr($FFFF5))); // BIOS Date
    Label4.Caption := string(PChar(Ptr($FEC71))); // Serial Number
  except
    Label1.Caption := 'Unsupported';
    Label2.Caption := 'Unsupported';
    Label3.Caption := 'Unsupported';
    Label4.Caption := 'Unsupported';
  end;
end;

Hint!
This method doesn't work with NT based systems like Windows NT, 2000 and XP.

View CPU debug info

Problem/Question/Abstract:

View CPU debug info

Answer:

Create this value in the registry:

HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging\EnableCPU = "1"

Then start Delphi and you'll have a new menu item: View | CPU Window

Find crosspoint of two lines

Problem/Question/Abstract:

How to calculate the crosspoint of two lines

Answer:

If you want to know if 2 Lines crossing each other, you can use this function below. The lines are given in with the beginning- and end-points. You will find the Coordinates of the Crosspoint in Cross, if the Function anwers True = we did found a crossing;

function GetCrossPointOfLines(pA1, pA2, pB1, pB2: TPoint; var Cross: TPoint): Boolean;
var
  h, i, j, k, l, m: Integer;
  o, p: Extended;
begin
  k := pB1.Y - pA1.Y;
  l := pA2.Y - pA1.Y;
  m := pB2.Y - pB1.Y;
  h := pA2.X - pA1.X;
  i := pB1.X - pA1.X;
  j := pB2.X - pB1.x;
  Result := false;
  if Abs(j * l - m * h) > 0 then
  begin
    p := (k * h - i * l) / (j * l - m * h);
    o := (k * j - i * m) / (j * l - m * h);
    if (o >= 0.0) and (o <= 1.0) and (p >= 0.0) and (p <= 1.0) then
    begin
      Cross.X := Round(pA1.X + o * h);
      Cross.Y := Round(pA1.Y + o * l);
      Result := True;
    end;
  end;
end;

How to paint a translucent (not transparent) rectangle

Problem/Question/Abstract:

I want to have a background image and then draw a translucent, red rectangle over it. The effect would then be like looking through a piece of red glass. How to achieve that?

Answer:

There are a number of different techniques, which vary in the overall effect. A simple algorithm, that doesn't model specular reflection or refraction, is demonstrated by this code:


procedure DrawTransparentRectangle(Canvas: TCanvas; Rect: TRect;
  Color: TColor; Transparency: Integer);
var
  X: Integer;
  Y: Integer;
  C: TColor;
  R, G, B: Integer;
  RR, RG, RB: Integer;
begin
  RR := GetRValue(Color);
  RG := GetGValue(Color);
  RB := GetBValue(Color);
  for Y := Rect.Top to Rect.Bottom - 1 do
    for X := Rect.Left to Rect.Right - 1 do
    begin
      C := Canvas.Pixels[X, Y];
      R := Round(0.01 * (Transparency * GetRValue(C) + (100 - Transparency) * RR));
      G := Round(0.01 * (Transparency * GetGValue(C) + (100 - Transparency) * RG));
      B := Round(0.01 * (Transparency * GetBValue(C) + (100 - Transparency) * RB));
      Canvas.Pixels[X, Y] := RGB(R, G, B);
    end;
end;


This routine is meant to illustrate the principle; in reality, you'd use something other than the (very slow) Pixels property to access the individual pixels of the canvas. For example, if you were dealing with bitmaps, you could use the Scanline property.

The Transparency parameter ranges from 0 (completely opaque) to 100 (completely transparent). With this simple algorithm, transparency values greater than 50 work best. Note that this algorithm is non-physical. The results are not what you'd get with a real piece of colored glass.

Implement the equivalent of TForm.OnCreate for a TFrame

Problem/Question/Abstract:

I miss one thing in frames: The ability of performing some initialization code as I would do in a TForm.OnCreate. So what would be the equivalent for frames?

Answer:

You can override the constructor for example. An alternative is to override the SetParent method and do the initialization after calling the inherited method. This way the frame will have a parent and you can then do things that require a window handle without running into problems. I use a base frame class in my current project that has this feature build in. The relevant parts are given below. In descendents I just override the Initialize method.

{ ... }
type
  {The base class for frames}
  TPLC_BaseFrame = class(TFrame)
  protected
    procedure SetParent(aParent: TWinControl); override;
  public
    procedure Initialize; virtual;
    procedure UnInitialize; virtual;
    destructor Destroy; override;
  end;

procedure TPLC_BaseFrame.Initialize;
begin
  {Override as needed in descendents}
end;

procedure TPLC_BaseFrame.UnInitialize;
begin
  {Override as needed in descendents}
end;

procedure TPLC_BaseFrame.SetParent(aParent: TWinControl);
var
  oldparent: TWinControl;
begin
  oldparent := Parent;
  inherited;
  if (oldparent = nil) and (aParent <> nil) then
    Initialize;
end;

destructor TPLC_BaseFrame.Destroy;
begin
  Uninitialize;
  inherited;
end;

Make a window system modal

Problem/Question/Abstract:

Make a window system modal

Answer:

You need to make a window system modal? The following function does the job (in 16bit Windows only):


SetSysModalWindow(Form1.handle);

Make a single cell in a TStringGrid readonly

Problem/Question/Abstract:

How to make a single cell in a TStringGrid readonly

Answer:

You can use OnSetEditText event for that. Something like:

procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer; const
  Value: string);
begin
  if (ACol = 1) and (ARow = 1) then
    StringGrid1.Cells[ACol, ARow] := 'Read Only!';
end;

Change the border color of a TPanel

Problem/Question/Abstract:

Can I change black line color of the TPanel border (BorderStyle = bsSingle) into i.e. blue line color? I tried to trap the WM_NCPAINT message and to draw over the border line, but it's not working. The border line color is still black.

Answer:

That color is the COLOR_WINDOWFRAME, so you probably do not want to change it in general. But the NC paint handler should work. Here's some sample code to draw a border in red:

{ ... }
type
  TMyPanel = class(TPanel)
  protected
    procedure WM_NCPaint(var Msg: TWMNCPaint); message WM_NCPaint;
  end;

procedure TMyPanel.WM_NCPaint(var Msg: TWMNCPaint);
var
  DC: HDC;
  OldBrush: HBRUSH;
  OldPen: HPEN;
begin
  DC := 0;
  OldBrush := 0;
  OldPen := 0;
  try
    {Must use a WindowDC or you can't draw outside the client area}
    DC := GetWindowDC(Handle);
    {Use a "clear" brush and an appropriately colored pen}
    OldBrush := SelectObject(DC, GetStockObject(NULL_BRUSH));
    Canvas.Pen.Color := clRed;
    OldPen := SelectObject(DC, Canvas.Pen.Handle);
    {Draw the border}
    Rectangle(DC, 0, 0, Width, Height);
    {Tell Windows you did it}
    Msg.Result := 0;
  finally
    {Clean up the mess you made}
    if DC <> 0 then
    begin
      if OldPen <> 0 then
        SelectObject(DC, OldPen);
      if OldBrush <> 0 then
        SelectObject(DC, OldBrush);
      ReleaseDC(Handle, DC);
    end;
  end;
end;

{Dynamic panel creation}

{ ... }
Panel := TMyPanel.Create(Self);
with Panel do
begin
  Parent := Self;
  Left := 10;
  Top := 10;
  {Don't try to do 3D borders or add beveling - keep it simple}
  BevelOuter := bvNone;
  BorderStyle := bsSingle;
  Ctl3d := False;
end;
{ ... }

Clear a TStringGrid

Problem/Question/Abstract:

I have a form with a stringgrid on it. I use the grid to display some data regarding a certain part. How do I clear the grid, that still holds data from the first display, before I display data of a different part?

Answer:

You have to loop over the rows or cols or even cells (depends on how the grid is layed out):

with StringGrid1 do
begin
  perform(WM_SETREDRAW, 0, 0); {block visual updates}
  try
    for i := fixedRows to Rowcount - 1 do
      Rows[i].Clear;
  finally
    perform(WM_SETREDRAW, 1, 0);
    invalidate;
  end;
end;

Since this wipes complete rows it would not be suitable if you have a fixed column on the left that should be preserved, for example.

Using code completion for assignments

Problem/Question/Abstract:

Using code completion for assignments

Answer:

Code Completion is not only good for macros, it can prompt you with a listbox of possible arguments for an assignment statement. To see Code Completion in action, have this piece of code in your OnCreate event handler:

var
  temp1: string;
  temp2: integer;
  temp3: string;
begin
  Form1.Caption :=

After typing the ":=", press [Ctrl][space]. In a moment, you'll see a list of several the variables, methods, and objects that are in scope, and potentially valid assignments.

Since the left side of the assignment (Caption) is a string, you will see temp1 and temp3, but not temp2.

Some of the choices will have an ellipsis (...) after them, indicating an object or record that contains compatible methods or fields for the assignment.

How to parse TAB delimited text files

Problem/Question/Abstract:

How would I go about parsing TAB delimited text files? I'm having difficulty with the chr(9) character.

Answer:

Solve 1:

{ ... }
var
  t: Textfile;
  line: string;
  elements: TStringlist;
begin
  Assignfile(t, filename);
  Reset(t);
  try
    elements := TStringlist.Create;
    try
      while not Eof(t) do
      begin
        ReadLn(t, line);
        {The following ignores empty lines}
        if IScan(#9, line, 1) > 0 then
        begin
          elements.clear;
          SplitString(line, #9, elements);
          ProcessElements(elements); {you write this}
        end;
      end;
    finally
      elements.Free
    end;
  finally
    Closefile(t);
  end;

{Return the position of the first instance of ch in S after position fromPos, or 0 if ch was not found}

function IScan(ch: Char; const S: string; fromPos: Integer): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := fromPos to Length(S) do
  begin
    if S[i] = ch then
    begin
      Result := i;
      Break;
    end;
  end;
end;

{Split the passed string into substrings at the position of the separator character and add the substrings to the passed list. The list is not cleared first!}

procedure SplitString(const S: string; separator: Char; substrings: TStrings);
var
  i, n: Integer;
begin
  if Assigned(substrings) and (Length(S) > 0) then
  begin
    i := 1;
    repeat
      n := IScan(separator, S, i);
      if n = 0 then
        n := Length(S) + 1;
      substrings.Add(Copy(S, i, n - i));
      i := n + 1;
    until
      i > Length(S);
  end;
end;


Solve 2:

procedure DelimitedListToStringList(const S: AnsiString; Delimiter: Char;
  List: TStrings; NullValue: AnsiString);
var
  iPos: Integer;
  Temp, Temp1: AnsiString;
begin
  if not Assigned(List) then
    Exit;
  List.Clear;
  Temp := S;
  iPos := Pos(Delimiter, S);
  while iPos > 0 do
  begin
    SetLength(Temp1, iPos - 1);
    Temp1 := Copy(Temp, 1, iPos - 1);
    if Temp1 = '' then
    begin
      SetLength(Temp1, Length(NullValue));
      Temp1 := NullValue;
    end;
    List.Add(Temp1);
    Delete(Temp, 1, iPos);
    iPos := Pos(Delimiter, Temp);
  end;
  if Temp > '' then
    List.Add(Temp);
end;

How to remove the client edge of a MDI parent form

Problem/Question/Abstract:

How to remove the client edge of a MDI parent form

Answer:

Apparently, in Delphi 4, the logic for the MDI client window edge was changed. If you have the source for Forms.pas, you can see the MDI client window procedure (TCustomForm.ClientWndProc) explicitly changes the client edge on a certain mysterious message ($3F) by calling ShowMDIClientEdge.

Unfortunately, simply replacing the client window procedure doesn't work well. I've finally been able to work out a hack, that replaces the client window procedure, and changes the form style on the fly. This makes sure the form's FormStyle property is not fsMDIForm when the client window procedure wants to call ShowMDIClientEdge, which it does only if the FormStyle property is fsMDIForm. When the FormStyle property changes, however, the window is destroyed (to be recreated when needed). To prevent this, I've overriden the DestroyWnd method.

The following unit is my MDI main form, displayed without a sunken edge:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FUpdating: Boolean;
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    procedure ClientWndProc(var Message: TMessage);
  protected
    procedure DestroyWnd; override;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ClientWndProc(var Message: TMessage);

  procedure DefProc;
  begin
    with Message do
      Result := CallWindowProc(OldWndProc, ClientHandle, Msg, wParam, lParam);
  end;

begin
  if Message.Msg = $3F then
  begin
    FUpdating := True;
    FormStyle := fsNormal;
    DefProc;
    FormStyle := fsMDIForm;
    FUpdating := False;
  end
  else
    DefProc;
end;

procedure TForm1.DestroyWnd;
begin
  if not FUpdating then
    inherited DestroyWnd;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  OldWndProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
  NewWndProc := MakeObjectInstance(ClientWndProc);
  SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(NewWndProc));
  SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle,
    GWL_EXSTYLE) and not WS_EX_CLIENTEDGE);
  SetWindowPos(ClientHandle, 0, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE
    or SWP_NOSIZE or SWP_NOZORDER or SWP_FRAMECHANGED);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)) = NewWndProc then
  begin
    SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(OldWndProc));
    FreeObjectInstance(NewWndProc);
  end;
end;

end.

Closing Internet Explorer from Delphi (Second Way)

Problem/Question/Abstract:

Kill all opened Internet Explorer windows, second way

Answer:

procedure TForm1.Button1Click(Sender: TObject);
// RadikalQ3, www.q3.nu/trucomania
  procedure CierraInternetExplorer;
  var
    Mango: THandle;
  begin
    //Cerramos todas las ventanas del Internet Explorer:
    repeat
      Mango := FindWindow('CabinetWClass', nil);
      if Mango <> 0 then
        SendMessage(Mango, WM_NCDestroy, 0, 0);
    until (Mango = 0);

    repeat
      Mango := FindWindow('IEFrame', nil);
      if Mango <> 0 then
        SendMessage(Mango, WM_NCDestroy, 0, 0);
    until (Mango = 0);
  end;

end;

How to limit MDI child form movement to the client area of the MDI parent form

Problem/Question/Abstract:

Is it possible to limit the MDI client form movement, so that the form cannot be moved outside the client area of the MDI form?

Answer:

Yes, you can handle the WM_WINDOWPOSCHANGING message in the child forms and modify the message parameters if needs be to keep the child fully visible. Of course this is a breach of the standard Windows behaviour.

private {in form declaration}

procedure WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
  message WM_WINDOWPOSCHANGING;

procedure TForm1.WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
var
  r: TRect;
begin
  with msg.Windowpos^ do
  begin
    if (flags and SWP_NOMOVE) = 0 then
    begin
      r := GetClientrect(Application.Mainform.handle, r);
      if x < 0 then
        x := 0;
      if y < 0 then
        y := 0;
      if (x + cx) > r.right then
        x := r.right - cx;
      if (y + cy) > r.bottom then
        y := r.bottom - cy;
    end;
    inherited;
  end;
end;

How to create a TCheckBox with a transparent caption

Problem/Question/Abstract:

Does anyone know how to make the label on a TCheckbox transparent. Just like TLabel?

Answer:

In order to make a check box transparent, you should include the WS_EX_Transparent constant to the extended window style and try to draw caption on your own. Example:

{ ... }
type
  TMyCheckBox = class(TCheckBox)
  protected
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetButtonStyle;
  end;

procedure TMyCheckBox.CNDrawItem(var Message: TWMDrawItem);
var
  XCanvas: TCanvas;
  XCaptionRect, XGlyphRect: TRect;

  procedure xxDrawBitMap(ACanvas: TCanvas);
  const
    xx_h = 13;
    xx_w = 13;
  var
    xxGlyph: TBitmap;
    xxX, xxY, xxStepY, xxStepX: integer;
  begin
    xxGlyph := TBitmap.Create;
    try
      xxGlyph.Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));
      xxY := XGlyphRect.Top + (XGlyphRect.Bottom - XGlyphRect.Top - xx_h) div 2;
      xxX := 2;
      xxStepX := 0;
      xxStepY := 0;
      case State of
        cbChecked: xxStepX := xxStepX + xx_w;
        cbGrayed: xxStepX := xxStepX + xx_w * 3;
      end;
      ACanvas.CopyRect(Rect(xxX, xxY, xxX + xx_w, xxY + xx_h), xxGlyph.Canvas,
        Rect(xxStepX, xxStepY, xx_w + xxStepX, xx_h + xxStepY));
    finally
      xxGlyph.Free;
    end;
  end;

  procedure xxDrawCaption;
  var
    xXFormat: longint;
  begin
    xXFormat := DT_VCENTER + DT_SINGLELINE + DT_LEFT;
    xXFormat := DrawTextBiDiModeFlags(xXFormat);
    DrawText(Message.DrawItemStruct.hDC, PChar(Caption), length(Caption),
      XCaptionRect, xXFormat);
  end;

begin
  XGlyphRect := Message.DrawItemStruct.rcItem;
  XGlyphRect.Right := 20;
  XCaptionRect := Message.DrawItemStruct.rcItem;
  XCaptionRect.Left := XGlyphRect.Right;
  XCanvas := TCanvas.Create;
  try
    XCanvas.Handle := Message.DrawItemStruct.hDC;
    XCanvas.Brush.Style := bsClear;
    xxDrawBitMap(XCanvas);
    xxDrawCaption;
  finally
    XCanvas.Free;
  end;
end;

procedure TMyCheckBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_Transparent;
end;

procedure TMyCheckBox.CreateWnd;
begin
  inherited CreateWnd;
  SetButtonStyle;
end;

procedure TMyCheckBox.SetButtonStyle;
const
  BS_MASK = $000F;
var
  Style: Word;
begin
  if HandleAllocated then
  begin
    Style := BS_CHECKBOX or BS_OWNERDRAW;
    if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
      SendMessage(Handle, BM_SETSTYLE, Style, 1);
  end;
end;

Modify the idapi.cfg settings through code

Problem/Question/Abstract:

Is there a way to change the IDAPI.CFG file from Delphi coding using the BDE API, since I wish to avoid having my users utilize the BDECFG.EXE utility?

Answer:

Here is a unit that is supposed to allow changing the config file:

unit CFGTOOL;

interface

uses
  SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;

type
  TBDEConfig = class(TComponent)
  private
    FLocalShare: Boolean;
    FMinBufSize: Integer;
    FMaxBufSize: Integer;
    FSystemLangDriver: string;
    FParadoxLangDriver: string;
    FMaxFileHandles: Integer;
    FNetFileDir: string;
    FTableLevel: string;
    FBlockSize: Integer;
    FDefaultDriver: string;
    FStrictIntegrity: Boolean;
    FAutoODBC: Boolean;

    procedure Init;
    procedure SetLocalShare(Value: Boolean);
    procedure SetMinBufSize(Value: Integer);
    procedure SetMaxBufSize(Value: Integer);
    procedure SetSystemLangDriver(Value: string);
    procedure SetParadoxLangDriver(Value: string);
    procedure SetMaxFileHandles(Value: Integer);
    procedure SetNetFileDir(Value: string);
    procedure SetTableLevel(Value: string);
    procedure SetBlockSize(Value: Integer);
    procedure SetDefaultDriver(Value: string);
    procedure SetAutoODBC(Value: Boolean);
    procedure SetStrictIntegrity(Value: Boolean);
    procedure UpdateCFGFile(path, item, value: string);

  protected

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property LocalShare: Boolean read FLocalShare write SetLocalShare;
    property MinBufSize: Integer read FMinBufSize write SetMinBufSize;
    property MaxBufSize: Integer read FMaxBufSize write SetMaxBufSize;
    property SystemLangDriver: string read FSystemLangDriver write
      SetSystemLangDriver;
    property ParadoxLangDriver: string read FParadoxLangDriver write
      SetParadoxLangDriver;
    property MaxFileHandles: Integer read FMaxFileHandles write SetMaxFileHandles;
    property NetFileDir: string read FNetFileDir write SetNetFileDir;
    property TableLevel: string read FTableLevel write SetTableLevel;
    property BlockSize: Integer read FBlockSize write SetBlockSize;
    property DefaultDriver: string read FDefaultDriver write SetDefaultDriver;
    property AutoODBC: Boolean read FAutoODBC write SetAutoODBC;
    property StrictIntegrity: Boolean read FStrictIntegrity write SetStrictIntegrity;

  end;

procedure Register;

implementation

function StrToBoolean(Value: string): Boolean;
begin
  if (UpperCase(Value) = 'TRUE') or (UpperCase(Value) = 'ON') or
    (UpperCase(Value) = 'YES') or (UpperCase(Value) = '.T.') then
    Result := True
  else
    Result := False;
end;

function BooleanToStr(Value: Boolean): string;
begin
  if Value then
    Result := 'TRUE'
  else
    Result := 'FALSE';
end;

procedure Register;
begin
  RegisterComponents('Data Access', [TBDEConfig]);
end;

procedure TBDEConfig.Init;
var
  h: hDBICur;
  pCfgDes: pCFGDesc;
  n, v: string;
begin
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\SYSTEM\INIT', h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LOCAL SHARE' then
        FLocalShare := StrToBoolean(v)
      else if n = 'MINBUFSIZE' then
        FMinBufSize := StrToInt(v)
      else if n = 'MAXBUFSIZE' then
        FMaxBufSize := StrToInt(v)
      else if n = 'MAXFILEHANDLES' then
        FMaxFileHandles := StrToInt(v)
      else if n = 'LANGDRIVER' then
        FSystemLangDriver := v
      else if n = 'AUTO ODBC' then
        FAutoODBC := StrToBoolean(v)
      else if n = 'DEFAULT DRIVER' then
        FDefaultDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\INIT', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'NET DIR' then
        FNetFileDir := v
      else if n = 'LANGDRIVER' then
        FParadoxLangDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\TABLE CREATE', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LEVEL' then
        FTableLevel := v
      else if n = 'BLOCK SIZE' then
        FBlockSize := StrToInt(v)
      else if n = 'STRICTINTEGRITY' then
        FStrictIntegrity := StrToBoolean(v);
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

procedure TBDEConfig.SetLocalShare(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LOCAL SHARE', BooleanToStr(Value));
  FLocalShare := Value;
end;

procedure TBDEConfig.SetMinBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MINBUFSIZE', IntToStr(Value));
  FMinBufSize := Value;
end;

procedure TBDEConfig.SetMaxBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXBUFSIZE', IntToStr(Value));
  FMaxBufSize := Value;
end;

procedure TBDEConfig.SetSystemLangDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LANGDRIVER', Value);
  FSystemLangDriver := Value;
end;

procedure TBDEConfig.SetParadoxLangDriver(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'LANGDRIVER', Value);
  FParadoxLangDriver := Value;
end;

procedure TBDEConfig.SetMaxFileHandles(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXFILEHANDLES', IntToStr(Value));
  FMaxFileHandles := Value;
end;

procedure TBDEConfig.SetNetFileDir(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'NET DIR', Value);
  FNetFileDir := Value;
end;

procedure TBDEConfig.SetTableLevel(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'LEVEL', Value);
  FTableLevel := Value;
end;

procedure TBDEConfig.SetBlockSize(Value: Integer);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'BLOCK SIZE', IntToStr(Value));
  FBlockSize := Value;
end;

procedure TBDEConfig.SetStrictIntegrity(Value: Boolean);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'STRICTINTEGRITY',
    BooleanToStr(Value));
  FStrictIntegrity := Value;
end;

procedure TBDEConfig.SetDefaultDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'DEFAULT DRIVER', Value);
  FDefaultDriver := Value;
end;

procedure TBDEConfig.SetAutoODBC(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'AUTO ODBC', BooleanToStr(Value));
  FAutoODBC := Value;
end;

procedure TBDEConfig.UpdateCFGFile;
var
  h: hDbiCur;
  pCfgDes: pCFGDesc;
  pPath: array[0..127] of char;
begin
  StrPCopy(pPath, Path);
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      if StrPas(pCfgDes^.szNodeName) = item then
      begin
        StrPCopy(pCfgDes^.szValue, value);
        Check(DbiModifyRecord(h, pCfgDes, True));
      end;
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

constructor TBDEConfig.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Init;
end;

destructor TBDEConfig.Destroy;
begin
  inherited Destroy;
end;

end.

What is a DispInterface?

Problem/Question/Abstract:

What is a DispInterface?

Answer:

Short answer: it is a specification for an IDispatch interface. Long answer: The IDispatch interface is the basis of all automation. It has two methods that allow pointerless scripting languages to call methods by name, instead of using method pointers: GetIDsOfNames, and Invoke. GetIdsOfNames retrieves the numerical ID of a method with a given name (provided that the object implements another interface that has method with that name). Invoke uses the numerical ID of a method to call that method. The numerical ID of a method is called the DispID. For example, suppose you create an interface that looks like this:

IMyIntf = interface(IDispatch)
['{4D733280-C514-11D4-8481-A68F52CBDB56}']
procedure DoThis;
end;

and an object that implements it that looks like this:

TMyDispatchObj = class(TAutoObject, IMyIntf)
public
procedure DoThis;
end;

Delphi will call both GetIDSOfNames and Invoke for you - all you need to do is use a variant. Like this:

{ ... }
var
AVar: OleVariant;
{ ... }

{ ... }
AVar := CreateComObject(CLASS_TMyAutoObj) as IDispatch;
AVar.DoThis;
{ ... }

Every time you call a method of an variant referencing an IDispatch interface, GetIDsOfNames and Invoke are called for you behind the scenes. However, calling GetIdsOfNames for every method is quite slow. And since all it does is find a numerical ID for a given method name, it might be nice if you could look up that ID in advance and pass it to Invoke directly, rather than go through GetIdsOfNames every time. Enter the DispInterface:

IMyDispInterface = dispinterface
['{4D733284-C514-11D4-8481-A68F52CBDB56}']
procedure DoThis; dispid 1;
end;

This declaration tells Delphi the DispID of each method in an interface. So if you use a DispInterface variable, rather than a variant, Delphi can call Invoke directly using that, rather than go through GetIdsOfNames:

{ ... }
var
Disp: IDispatch;
Dispint: IMyDispInterface;
{ ... }
Disp := CreateComObject(CLASS_TMyAutoObj) as IDispatch;
Dispint := IMyDispInterface(Disp);
Dispint.DoThis;
{ ... }

A DispInterface is not a true interface. When you use a DispInterface, you are actually using the IDispatch interface of an object, just as you are when you use a variant. That's why you can cast an IDispatch interface directly to a dispinterface, as in the second line above. All you're doing here is telling the compiler that you already know what other methods a particular object will implement, and what DispID's can be used to invoke them with.

Accelerate database searches

Problem/Question/Abstract:

How to accelerate database searches

Answer:

Do you want a simple, one-line method for speeding up your database searches? After you know what your search target is but before beginning your search, disable the search table with the DisableControls method. This effectively disconnects the DataSet from the DataSource component. For example:

unit Unit1;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Table1: TTable;
    Button1: TButton;

    procedure TForm1.Button1Click(Sender: TObject);
  var
    SeekValue: string;
    begin
      Table1.DisableControls;
      Table1.FindKey([SeekValue]);
      Table1.EnableConstraints;
    end;

  end.

As the search advances through an index, using the Next method, data aware components attached to the dataset are updated. The speed increase results from severing the connection, avoiding the component updates and restoring the connection when the search is completed.

How to install a new font through code

Problem/Question/Abstract:

How to install a new font through code

Answer:

uses
  Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
  b: bool;
begin
  CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b);
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.LazyWrite := false;
  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false);
  reg.WriteString('TESTMICR (TrueType)', 'FP000100.TTF');
  reg.CloseKey;
  reg.free;
  {Add the font resource}
  AddFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  {Remove the resource lock}
  RemoveFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Adjust the volume on TMediaPlayer

Problem/Question/Abstract:

How to adjust the volume on TMediaPlayer

Answer:

unit MpVolume;

interface

uses Windows, MPlayer;

const
  MCI_SETAUDIO = $0873;
  MCI_DGV_SETAUDIO_VOLUME = $4002;
  MCI_DGV_SETAUDIO_ITEM = $00800000;
  MCI_DGV_SETAUDIO_VALUE = $01000000;

  MCI_DGV_STATUS_VOLUME = $4019;

type
  MCI_DGV_SETAUDIO_PARMS = record
    dwCallback: DWORD;
    dwItem: DWORd;
    dwValue: DWORD;
    dwOver: DWORD;
    lpstrAlgorithm: PChar;
    lpstrQuality: PChar;
  end;

type
  MCI_STATUS_PARMS = record
    dwCallback: DWORD;
    dwReturn: DWORD;
    dwItem: DWORD;
    dwTrack: DWORD;
  end;

  //Remember to add the name of your form to the procedures
function GetMPVolume(MP: TMediaPlayer): Integer;
procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer);

implementation

uses mmsystem;

function GetMPVolume(MP: TMediaPlayer): Integer;
var
  p: MCI_STATUS_PARMS;
begin
  p.dwCallback := 0;
  p.dwItem := MCI_DGV_STATUS_VOLUME;
  mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p));
  Result := p.dwReturn;
  { Volume: 0 - 1000 }
end;

procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer);
var
  p: MCI_DGV_SETAUDIO_PARMS;
begin
  { Volume: 0 - 1000 }
  p.dwCallback := 0;
  p.dwItem := MCI_DGV_SETAUDIO_VOLUME;
  p.dwValue := Volume;
  p.dwOver := 0;
  p.lpstrAlgorithm := nil;
  p.lpstrQuality := nil;
  mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
    MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;

end.

MS Exchange API via CDO (Collaboration Data Objects)

Problem/Question/Abstract:

MS Exchange API via CDO (Collaboration Data Objects)

Answer:

CDO (Collaboration Data Objects) Base Library.
( Talking to MS-Exchange server.)

This is a vast subject that is beyond the scope of this article to detail all here. This library provides the basic building blocks for someone who wants to develop using CDO. There are many references on the Net, but your best source is the CDO.HLP file that ships on the Exchange CD or site http://www.cdolive.com/start.htm. The cdolive.com site is an excellent reference site which discusses all aspects including installation, versions and also downloads. (CDO.HLP is downloadable from here)

My basic class provides the following functionality ..

Utility functions and methods

    function CdoNothing(Obj : OleVariant) : boolean;
    function CdoDefaultProfile : string;
    function VarNothing : IDispatch;

    procedure CdoDisposeList(WorkList : TList);
    procedure CdoDisposeObjects(WorkStrings : TStrings);
    procedure CdoDisposeNodes(WorkData : TTreeNodes);

Create constructors that allow Default profile logon,Specific profile logon and an Impersonated user logon with profile. (This is required for successful logon in Windows Service Applications)

      constructor Create; overload;
   constructor Create(const Profile : string); overload;
   constructor Create(const Profile : string;
                       const UserName : string;
                       const Domain : string;
                       const Password : string); overload;
  
Methods for loading stringlists, treeviews etc. and Object iteration.

      function LoadAddressList(StringList : TStrings) : boolean;
   function LoadObjectList(const FolderOle : OleVariant;
                           List : TList) : boolean;
   function LoadEMailTree(TV : TTreeView;
                          Expand1stLevel : boolean = false;
                          SubjectMask : string = '') : boolean;
   function LoadContactList(const FolderOle : OleVariant;
                            Items : TStrings) : boolean; overload;
   function LoadContactList(const FolderName : string;
                            Items : TStrings) : boolean; overload;
   procedure ShowContactDetails(Contact : OleVariant);

The above load various lists into stringlists,lists or treeviews. Freeing of lists,object constructs within these data structures are freed at each successive call to the load, however the final Deallocation is the responsibility of the developer, You can do this yourself or use the utility functions CdoDisposeXXX(). See code documentation for further understanding.

   function First(const FolderOle : OleVariant;
                  out ItemOle : OleVariant) : boolean;
   function Last(const FolderOle : OleVariant;
                 out ItemOle : OleVariant) : boolean;
   function Next(const FolderOle : OleVariant;
                 out ItemOle : OleVariant) : boolean;
   function Prior(const FolderOle : OleVariant;
                  out ItemOle : OleVariant) : boolean;
   function AsString(const ItemOle : Olevariant;
                     const FieldIdConstant : DWORD) : string;

The above provide iterations thru object such as Inbox,Contacts etc. The AsString returns a fields value from the object such as Email Address,Name,Company Name etc. (There are miriads of these defined in the CONST section &#8220;Field Tags&#8221;).

Properties

         property CurrentUser : OleVariant read FCurrentUser;
     property Connected : boolean read FConnected;
     property LastErrorMess : string read FlastError;
     property LastErrorCode : DWORD read FlastErrorCode;
     property InBox : OleVariant read FOleInBox;
     property OutBox : OleVariant read FOleOutBox;
     property DeletedItems : Olevariant read FOleDeletedItems;
     property SentItems : Olevariant read FOleSentItems;
     property GlobalAddressList : Olevariant read FOleGlobalAddressList;
     property Contacts : Olevariant read FOleContacts;
     property Session : OleVariant read FOleSession;
     property Version : string read GetFVersion;
     property MyName : string read FMyName;
     property MyEMailAddress : string read FMyEMailAddress;

The Create constructor sets up the predefined objects InBox, OutBox, DeletedItems, SentItems, GlobalAddressList, Session and Contacts. The other properties are self explanatary.

As I mentioned earlier the functionality of CDO is vast as objects such as InBox have many methods and properties that included Updating,Inserting Deleting etc. The CDO.HLP file will help to expose these for you. My class is the base of CDO to help simplify building applications and is probably best demonstrated by code snippet examples. Believe me a whole book could be written on this subject, but it is well worth studying as a faster alternative to using MS Outlook API.

uses Cdo_Lib;
var
  Cdo: TcdoSession;
  MailItem: OleVariant;

  // Iterate thru Emails in InBox
begin
  Cdo := TCdoSession.Create;

  if Cdo.Active then
  begin
    Cdo.First(Cdo.InBox, MailItem);

    while true do
    begin
      if not Cdo.Nothing(MailItem) then
      begin
        Subject := MailItem.Subject;

        EMailAddress := Cdo.AsString(MailItem.Sender, CdoPR_EMAIL_AT_ADDRESS);
        EMailName := MailItem.Sender.Name;
        BodyText := MailItem.Text;

        // Do something with data and delete the EMail
        MailItem.Delete;
        // Get the next Email
      end;

      MailItem := Cdo.Next(Cdo.Inbox.MailItem);
    end;
  end;
  Cdo.Free;
end;

// Example of loading emails into a treeview and displaying on treeview click

unit UBrowse;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ToolWin, Menus, ExtCtrls, StdCtrls, Buttons, ImgList,
  CDO_Lib;

type
  TFBrowse = class(TForm)
    Panel1: TPanel;
    Panel3: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    lbFrom: TLabel;
    lbDate: TLabel;
    Memo1: TMemo;
    Panel2: TPanel;
    OKBtn: TBitBtn;
    tvCalls: TTreeView;
    ImageList1: TImageList;
    StatusBar1: TStatusBar;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure tvCallsClick(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
  private
    { Private declarations }
    Doc: OleVariant;
    Cdo: TCdoMapiSession;
  public
    { Public declarations }
  end;

var
  FBrowse: TFBrowse;

implementation

{$R *.DFM}

procedure TFBrowse.FormShow(Sender: TObject);
var
  TN: TTreeNode;
begin
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  Cdo := TCdoMapiSession.Create;
  Cdo.LoadEMailTree(tvCalls, true, '*Support ---*');
  tvCalls.SortType := stText;
  TN := tvCalls.Items[0];
  TN.Expand(false);
  tvCalls.SetFocus;
  Screen.Cursor := crDefault;
end;

procedure TFBrowse.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CdoDisposeNodes(TvCalls.Items);
  Cdo.Free;
end;

procedure TFBrowse.tvCallsClick(Sender: TObject);
var
  TN: TTreeNode;
begin
  TN := tvCalls.Selected;
  Memo1.Clear;
  lbFrom.Caption := '';
  lbDate.Caption := '';

  if TN.Data <> nil then
  begin
    Doc := TOleVarPtr(TN.Data)^;
    btnPrint.Enabled := true;
    Memo1.Text := Doc.Text;
    lbFrom.Caption := Doc.Sender.Name;
    lbDate.Caption := FormatDateTime('dd/mm/yyyy hh:nn', Doc.TimeSent);
  end;
end;

end.

unit CDO_Lib;

// =============================================================================
// CDO and MAPI Library (See CDO.HLP)
//
// The object model for the CDO Library is hierarchical. The following table
// shows the containment hierarchy. Each indented object is a child of the
// object under which it is indented. An object is the parent of every object
// at the next level of indentation under it. For example, an Attachments
// collection and a Recipients collection are both child objects of a
// Message object, and a Messages collection is a parent object of a
// Message object. However, a Messages collection is not a parent object of a
// Recipients collection.
//
//  Session
//  ��    AddressLists collection
//  ��    ��    AddressList
//  ��    ��    ��    Fields collection
//  ��    ��    ��    ��    Field
//  ��    ��    ��    AddressEntries collection
//  ��    ��    ��    ��    AddressEntry
//  ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    Field
//  ��    ��    ��    ��    AddressEntryFilter
//  ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    Field
//  ��    Folder (Inbox or Outbox)
//  ��    ��    Fields collection
//  ��    ��    ��    Field
//  ��    ��    Folders collection
//  ��    ��    ��    Folder
//  ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    Field
//  ��    ��    ��    ��    [ Folders ... Folder ... ]
//  ��    ��    ��    ��    Messages collection
//  ��    ��    ��    ��    ��    AppointmentItem
//  ��    ��    ��    ��    ��    ��    RecurrencePattern
//  ��    ��    ��    ��    ��    GroupHeader
//  ��    ��    ��    ��    ��    MeetingItem
//  ��    ��    ��    ��    ��    Message
//  ��    ��    ��    ��    ��    ��    Attachments collection
//  ��    ��    ��    ��    ��    ��    ��    Attachment
//  ��    ��    ��    ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    ��    ��    ��    Field
//  ��    ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    ��    Field
//  ��    ��    ��    ��    ��    ��    Recipients collection
//  ��    ��    ��    ��    ��    ��    ��    Recipient
//  ��    ��    ��    ��    ��    ��    ��    ��    AddressEntry
//  ��    ��    ��    ��    ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    ��    ��    ��    ��    Field
//  ��    ��    ��    ��    ��    MessageFilter
//  ��    ��    ��    ��    ��    ��    Fields collection
//  ��    ��    ��    ��    ��    ��    ��    Field
//  ��    InfoStores collection
//  ��    ��    InfoStore
//  ��    ��    ��    Fields collection
//  ��    ��    ��    ��    Field
//  ��    ��    ��    Folder [as expanded under Folders]
//
//  The notation "[ Folders ... Folder ... ]" signifies that any Folder object
//  can contain a Folders collection of subfolders, and each subfolder can
//  contain a Folders collection of more subfolders, nested to an
//  arbitrary level.
// =============================================================================

interface

uses Forms, Windows, SysUtils, Classes, Registry, ComObj, Variants, ComCtrls,
  Controls, Masks;

const
  // MAPI Property Tags

  // Field Tags
  CdoPR_7BIT_DISPLAY_NAME = $39FF001E;
  CdoPR_AB_DEFAULT_DIR = $3D060102;
  CdoPR_AB_DEFAULT_PAB = $3D070102;
  CdoPR_AB_PROVIDER_ID = $36150102;
  CdoPR_AB_PROVIDERS = $3D010102;
  CdoPR_AB_SEARCH_PATH = $3D051102;
  CdoPR_AB_SEARCH_PATH_UPDATE = $3D110102;
  CdoPR_ACCESS = $0FF40003;
  CdoPR_ACCESS_LEVEL = $0FF70003;
  CdoPR_ACCOUNT = $3A00001E;
  CdoPR_ACKNOWLEDGEMENT_MODE = $00010003;
  CdoPR_ADDRTYPE = $3002001E;
  CdoPR_ALTERNATE_RECIPIENT = $3A010102;
  CdoPR_ALTERNATE_RECIPIENT_ALLOWED = $0002000B;
  CdoPR_ANR = $360C001E;
  CdoPR_ASSISTANT = $3A30001E;
  CdoPR_ASSISTANT_TELEPHONE_NUMBER = $3A2E001E;
  CdoPR_ASSOC_CONTENT_COUNT = $36170003;
  CdoPR_ATTACH_ADDITIONAL_INFO = $370F0102;
  CdoPR_ATTACH_DATA_BIN = $37010102;
  CdoPR_ATTACH_DATA_OBJ = $3701000D;
  CdoPR_ATTACH_ENCODING = $37020102;
  CdoPR_ATTACH_EXTENSION = $3703001E;
  CdoPR_ATTACH_FILENAME = $3704001E;
  CdoPR_ATTACH_LONG_FILENAME = $3707001E;
  CdoPR_ATTACH_LONG_PATHNAME = $370D001E;
  CdoPR_ATTACH_METHOD = $37050003;
  CdoPR_ATTACH_MIME_TAG = $370E001E;
  CdoPR_ATTACH_NUM = $0E210003;
  CdoPR_ATTACH_PATHNAME = $3708001E;
  CdoPR_ATTACH_RENDERING = $37090102;
  CdoPR_ATTACH_SIZE = $0E200003;
  CdoPR_ATTACH_TAG = $370A0102;
  CdoPR_ATTACH_TRANSPORT_NAME = $370C001E;
  CdoPR_ATTACHMENT_X400_PARAMETERS = $37000102;
  CdoPR_AUTHORIZING_USERS = $00030102;
  CdoPR_AUTO_FORWARD_COMMENT = $0004001E;
  CdoPR_AUTO_FORWARDED = $0005000B;
  CdoPR_BEEPER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_BIRTHDAY = $3A420040;
  CdoPR_BODY = $1000001E;
  CdoPR_BODY_CRC = $0E1C0003;
  CdoPR_BUSINESS_ADDRESS_CITY = $3A27001E;
  CdoPR_BUSINESS_ADDRESS_COUNTRY = $3A26001E;
  CdoPR_BUSINESS_ADDRESS_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_BUSINESS_ADDRESS_POSTAL_CODE = $3A2A001E;
  CdoPR_BUSINESS_ADDRESS_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_BUSINESS_ADDRESS_STREET = $3A29001E;
  CdoPR_BUSINESS_FAX_NUMBER = $3A24001E;
  CdoPR_BUSINESS_HOME_PAGE = $3A51001E;
  CdoPR_BUSINESS_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_BUSINESS2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_CALLBACK_TELEPHONE_NUMBER = $3A02001E;
  CdoPR_CAR_TELEPHONE_NUMBER = $3A1E001E;
  CdoPR_CELLULAR_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_CHILDRENS_NAMES = $3A58101E;
  CdoPR_CLIENT_SUBMIT_TIME = $00390040;
  CdoPR_COMMENT = $3004001E;
  CdoPR_COMMON_VIEWS_ENTRYID = $35E60102;
  CdoPR_COMPANY_MAIN_PHONE_NUMBER = $3A57001E;
  CdoPR_COMPANY_NAME = $3A16001E;
  CdoPR_COMPUTER_NETWORK_NAME = $3A49001E;
  CdoPR_CONTACT_ADDRTYPES = $3A54101E;
  CdoPR_CONTACT_DEFAULT_ADDRESS_INDEX = $3A550003;
  CdoPR_CONTACT_EMAIL_ADDRESSES = $3A56101E;
  CdoPR_CONTACT_ENTRYIDS = $3A531102;
  CdoPR_CONTACT_VERSION = $3A520048;
  CdoPR_CONTAINER_CLASS = $3613001E;
  CdoPR_CONTAINER_CONTENTS = $360F000D;
  CdoPR_CONTAINER_FLAGS = $36000003;
  CdoPR_CONTAINER_HIERARCHY = $360E000D;
  CdoPR_CONTAINER_MODIFY_VERSION = $36140014;
  CdoPR_CONTENT_CONFIDENTIALITY_ALGORITHM_ID = $00060102;
  CdoPR_CONTENT_CORRELATOR = $00070102;
  CdoPR_CONTENT_COUNT = $36020003;
  CdoPR_CONTENT_IDENTIFIER = $0008001E;
  CdoPR_CONTENT_INTEGRITY_CHECK = $0C000102;
  CdoPR_CONTENT_LENGTH = $00090003;
  CdoPR_CONTENT_RETURN_REQUESTED = $000A000B;
  CdoPR_CONTENT_UNREAD = $36030003;
  CdoPR_CONTENTS_SORT_ORDER = $360D1003;
  CdoPR_CONTROL_FLAGS = $3F000003;
  CdoPR_CONTROL_ID = $3F070102;
  CdoPR_CONTROL_STRUCTURE = $3F010102;
  CdoPR_CONTROL_TYPE = $3F020003;
  CdoPR_CONVERSATION_INDEX = $00710102;
  CdoPR_CONVERSATION_KEY = $000B0102;
  CdoPR_CONVERSATION_TOPIC = $0070001E;
  CdoPR_CONVERSION_EITS = $000C0102;
  CdoPR_CONVERSION_PROHIBITED = $3A03000B;
  CdoPR_CONVERSION_WITH_LOSS_PROHIBITED = $000D000B;
  CdoPR_CONVERTED_EITS = $000E0102;
  CdoPR_CORRELATE = $0E0C000B;
  CdoPR_CORRELATE_MTSID = $0E0D0102;
  CdoPR_COUNTRY = $3A26001E;
  CdoPR_CREATE_TEMPLATES = $3604000D;
  CdoPR_CREATION_TIME = $30070040;
  CdoPR_CREATION_VERSION = $0E190014;
  CdoPR_CURRENT_VERSION = $0E000014;
  CdoPR_CUSTOMER_ID = $3A4A001E;
  CdoPR_DEF_CREATE_DL = $36110102;
  CdoPR_DEF_CREATE_MAILUSER = $36120102;
  CdoPR_DEFAULT_PROFILE = $3D04000B;
  CdoPR_DEFAULT_STORE = $3400000B;
  CdoPR_DEFAULT_VIEW_ENTRYID = $36160102;
  CdoPR_DEFERRED_DELIVERY_TIME = $000F0040;
  CdoPR_DELEGATION = $007E0102;
  CdoPR_DELETE_AFTER_SUBMIT = $0E01000B;
  CdoPR_DELIVER_TIME = $00100040;
  CdoPR_DELIVERY_POINT = $0C070003;
  CdoPR_DELTAX = $3F030003;
  CdoPR_DELTAY = $3F040003;
  CdoPR_DEPARTMENT_NAME = $3A18001E;
  CdoPR_DEPTH = $30050003;
  CdoPR_DETAILS_TABLE = $3605000D;
  CdoPR_DISC_VAL = $004A000B;
  CdoPR_DISCARD_REASON = $00110003;
  CdoPR_DISCLOSE_RECIPIENTS = $3A04000B;
  CdoPR_DISCLOSURE_OF_RECIPIENTS = $0012000B;
  CdoPR_DISCRETE_VALUES = $0E0E000B;
  CdoPR_DISPLAY_BCC = $0E02001E;
  CdoPR_DISPLAY_CC = $0E03001E;
  CdoPR_DISPLAY_NAME = $3001001E;
  CdoPR_DISPLAY_NAME_PREFIX = $3A45001E;
  CdoPR_DISPLAY_TO = $0E04001E;
  CdoPR_DISPLAY_TYPE = $39000003;
  CdoPR_DL_EXPANSION_HISTORY = $00130102;
  CdoPR_DL_EXPANSION_PROHIBITED = $0014000B;
  CdoPR_EMAIL_ADDRESS = $3003001E;
  CdoPR_EMAIL_AT_ADDRESS = $39FE001E;
  CdoPR_END_DATE = $00610040;
  CdoPR_ENTRYID = $0FFF0102;
  CdoPR_EXPIRY_TIME = $00150040;
  CdoPR_EXPLICIT_CONVERSION = $0C010003;
  CdoPR_FILTERING_HOOKS = $3D080102;
  CdoPR_FINDER_ENTRYID = $35E70102;
  CdoPR_FOLDER_ASSOCIATED_CONTENTS = $3610000D;
  CdoPR_FOLDER_TYPE = $36010003;
  CdoPR_FORM_CATEGORY = $3304001E;
  CdoPR_FORM_CATEGORY_SUB = $3305001E;
  CdoPR_FORM_CLSID = $33020048;
  CdoPR_FORM_CONTACT_NAME = $3303001E;
  CdoPR_FORM_DESIGNER_GUID = $33090048;
  CdoPR_FORM_DESIGNER_NAME = $3308001E;
  CdoPR_FORM_HIDDEN = $3307000B;
  CdoPR_FORM_HOST_MAP = $33061003;
  CdoPR_FORM_MESSAGE_BEHAVIOR = $330A0003;
  CdoPR_FORM_VERSION = $3301001E;
  CdoPR_FTP_SITE = $3A4C001E;
  CdoPR_GENDER = $3A4D0002;
  CdoPR_GENERATION = $3A05001E;
  CdoPR_GIVEN_NAME = $3A06001E;
  CdoPR_GOVERNMENT_ID_NUMBER = $3A07001E;
  CdoPR_HASATTACH = $0E1B000B;
  CdoPR_HEADER_FOLDER_ENTRYID = $3E0A0102;
  CdoPR_HOBBIES = $3A43001E;
  CdoPR_HOME_ADDRESS_CITY = $3A59001E;
  CdoPR_HOME_ADDRESS_COUNTRY = $3A5A001E;
  CdoPR_HOME_ADDRESS_POST_OFFICE_BOX = $3A5E001E;
  CdoPR_HOME_ADDRESS_POSTAL_CODE = $3A5B001E;
  CdoPR_HOME_ADDRESS_STATE_OR_PROVINCE = $3A5C001E;
  CdoPR_HOME_ADDRESS_STREET = $3A5D001E;
  CdoPR_HOME_FAX_NUMBER = $3A25001E;
  CdoPR_HOME_TELEPHONE_NUMBER = $3A09001E;
  CdoPR_HOME2_TELEPHONE_NUMBER = $3A2F001E;
  CdoPR_ICON = $0FFD0102;
  CdoPR_IDENTITY_DISPLAY = $3E00001E;
  CdoPR_IDENTITY_ENTRYID = $3E010102;
  CdoPR_IDENTITY_SEARCH_KEY = $3E050102;
  CdoPR_IMPLICIT_CONVERSION_PROHIBITED = $0016000B;
  CdoPR_IMPORTANCE = $00170003;
  CdoPR_INCOMPLETE_COPY = $0035000B;
  CdoPR_INITIAL_DETAILS_PANE = $3F080003;
  CdoPR_INITIALS = $3A0A001E;
  CdoPR_INSTANCE_KEY = $0FF60102;
  CdoPR_INTERNET_APPROVED = $1030001E;
  CdoPR_INTERNET_ARTICLE_NUMBER = $0E230003;
  CdoPR_INTERNET_CONTROL = $1031001E;
  CdoPR_INTERNET_DISTRIBUTION = $1032001E;
  CdoPR_INTERNET_FOLLOWUP_TO = $1033001E;
  CdoPR_INTERNET_LINES = $10340003;
  CdoPR_INTERNET_MESSAGE_ID = $1035001E;
  CdoPR_INTERNET_NEWSGROUPS = $1036001E;
  CdoPR_INTERNET_NNTP_PATH = $1038001E;
  CdoPR_INTERNET_ORGANIZATION = $1037001E;
  CdoPR_INTERNET_PRECEDENCE = $1041001E;
  CdoPR_INTERNET_REFERENCES = $1039001E;
  CdoPR_IPM_ID = $00180102;
  CdoPR_IPM_OUTBOX_ENTRYID = $35E20102;
  CdoPR_IPM_OUTBOX_SEARCH_KEY = $34110102;
  CdoPR_IPM_RETURN_REQUESTED = $0C02000B;
  CdoPR_IPM_SENTMAIL_ENTRYID = $35E40102;
  CdoPR_IPM_SENTMAIL_SEARCH_KEY = $34130102;
  CdoPR_IPM_SUBTREE_ENTRYID = $35E00102;
  CdoPR_IPM_SUBTREE_SEARCH_KEY = $34100102;
  CdoPR_IPM_WASTEBASKET_ENTRYID = $35E30102;
  CdoPR_IPM_WASTEBASKET_SEARCH_KEY = $34120102;
  CdoPR_ISDN_NUMBER = $3A2D001E;
  CdoPR_KEYWORD = $3A0B001E;
  CdoPR_LANGUAGE = $3A0C001E;
  CdoPR_LANGUAGES = $002F001E;
  CdoPR_LAST_MODIFICATION_TIME = $30080040;
  CdoPR_LATEST_DELIVERY_TIME = $00190040;
  CdoPR_LOCALITY = $3A27001E;
  CdoPR_LOCATION = $3A0D001E;
  CdoPR_MAIL_PERMISSION = $3A0E000B;
  CdoPR_MANAGER_NAME = $3A4E001E;
  CdoPR_MAPPING_SIGNATURE = $0FF80102;
  CdoPR_MDB_PROVIDER = $34140102;
  CdoPR_MESSAGE_ATTACHMENTS = $0E13000D;
  CdoPR_MESSAGE_CC_ME = $0058000B;
  CdoPR_MESSAGE_CLASS = $001A001E;
  CdoPR_MESSAGE_DELIVERY_ID = $001B0102;
  CdoPR_MESSAGE_DELIVERY_TIME = $0E060040;
  CdoPR_MESSAGE_DOWNLOAD_TIME = $0E180003;
  CdoPR_MESSAGE_FLAGS = $0E070003;
  CdoPR_MESSAGE_RECIP_ME = $0059000B;
  CdoPR_MESSAGE_RECIPIENTS = $0E12000D;
  CdoPR_MESSAGE_SECURITY_LABEL = $001E0102;
  CdoPR_MESSAGE_SIZE = $0E080003;
  CdoPR_MESSAGE_SUBMISSION_ID = $00470102;
  CdoPR_MESSAGE_TO_ME = $0057000B;
  CdoPR_MESSAGE_TOKEN = $0C030102;
  CdoPR_MHS_COMMON_NAME = $3A0F001E;
  CdoPR_MIDDLE_NAME = $3A44001E;
  CdoPR_MINI_ICON = $0FFC0102;
  CdoPR_MOBILE_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_MODIFY_VERSION = $0E1A0014;
  CdoPR_MSG_STATUS = $0E170003;
  CdoPR_NDR_DIAG_CODE = $0C050003;
  CdoPR_NDR_REASON_CODE = $0C040003;
  CdoPR_NEWSGROUP_NAME = $0E24001E;
  CdoPR_NICKNAME = $3A4F001E;
  CdoPR_NNTP_XREF = $1040001E;
  CdoPR_NON_RECEIPT_NOTIFICATION_REQUESTED = $0C06000B;
  CdoPR_NON_RECEIPT_REASON = $003E0003;
  CdoPR_NORMALIZED_SUBJECT = $0E1D001E;
  CdoPR_OBJECT_TYPE = $0FFE0003;
  CdoPR_OBSOLETED_IPMS = $001F0102;
  CdoPR_OFFICE_LOCATION = $3A19001E;
  CdoPR_OFFICE_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_OFFICE2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_ORGANIZATIONAL_ID_NUMBER = $3A10001E;
  CdoPR_ORIG_MESSAGE_CLASS = $004B001E;
  CdoPR_ORIGIN_CHECK = $00270102;
  CdoPR_ORIGINAL_AUTHOR_ADDRTYPE = $0079001E;
  CdoPR_ORIGINAL_AUTHOR_EMAIL_ADDRESS = $007A001E;
  CdoPR_ORIGINAL_AUTHOR_ENTRYID = $004C0102;
  CdoPR_ORIGINAL_AUTHOR_NAME = $004D001E;
  CdoPR_ORIGINAL_AUTHOR_SEARCH_KEY = $00560102;
  CdoPR_ORIGINAL_DELIVERY_TIME = $00550040;
  CdoPR_ORIGINAL_DISPLAY_BCC = $0072001E;
  CdoPR_ORIGINAL_DISPLAY_CC = $0073001E;
  CdoPR_ORIGINAL_DISPLAY_NAME = $3A13001E;
  CdoPR_ORIGINAL_DISPLAY_TO = $0074001E;
  CdoPR_ORIGINAL_EITS = $00210102;
  CdoPR_ORIGINAL_ENTRYID = $3A120102;
  CdoPR_ORIGINAL_SEARCH_KEY = $3A140102;
  CdoPR_ORIGINAL_SENDER_ADDRTYPE = $0066001E;
  CdoPR_ORIGINAL_SENDER_EMAIL_ADDRESS = $0067001E;
  CdoPR_ORIGINAL_SENDER_ENTRYID = $005B0102;
  CdoPR_ORIGINAL_SENDER_NAME = $005A001E;
  CdoPR_ORIGINAL_SENDER_SEARCH_KEY = $005C0102;
  CdoPR_ORIGINAL_SENSITIVITY = $002E0003;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ADDRTYPE = $0068001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_EMAIL_ADDR = $0069001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ENTRYID = $005E0102;
  CdoPR_ORIGINAL_SENT_REPRESENTING_NAME = $005D001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_SEARCH_KEY = $005F0102;
  CdoPR_ORIGINAL_SUBJECT = $0049001E;
  CdoPR_ORIGINAL_SUBMIT_TIME = $004E0040;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ADDRTYPE = $007B001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_EMAIL_ADDR = $007C001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ENTRYID = $10120102;
  CdoPR_ORIGINALLY_INTENDED_RECIPIENT_NAME = $00200102;
  CdoPR_ORIGINATING_MTA_CERTIFICATE = $0E250102;
  CdoPR_ORIGINATOR_AND_DL_EXPANSION_HISTORY = $10020102;
  CdoPR_ORIGINATOR_CERTIFICATE = $00220102;
  CdoPR_ORIGINATOR_DELIVERY_REPORT_REQUESTED = $0023000B;
  CdoPR_ORIGINATOR_NON_DELIVERY_REPORT_REQ = $0C08000B;
  CdoPR_ORIGINATOR_REQUESTED_ALTERNATE_RECIP = $0C090102;
  CdoPR_ORIGINATOR_RETURN_ADDRESS = $00240102;
  CdoPR_OTHER_ADDRESS_CITY = $3A5F001E;
  CdoPR_OTHER_ADDRESS_COUNTRY = $3A60001E;
  CdoPR_OTHER_ADDRESS_POST_OFFICE_BOX = $3A64001E;
  CdoPR_OTHER_ADDRESS_POSTAL_CODE = $3A61001E;
  CdoPR_OTHER_ADDRESS_STATE_OR_PROVINCE = $3A62001E;
  CdoPR_OTHER_ADDRESS_STREET = $3A63001E;
  CdoPR_OTHER_TELEPHONE_NUMBER = $3A1F001E;
  CdoPR_OWN_STORE_ENTRYID = $3E060102;
  CdoPR_OWNER_APPT_ID = $00620003;
  CdoPR_PAGER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_PARENT_DISPLAY = $0E05001E;
  CdoPR_PARENT_ENTRYID = $0E090102;
  CdoPR_PARENT_KEY = $00250102;
  CdoPR_PERSONAL_HOME_PAGE = $3A50001E;
  CdoPR_PHYSICAL_DELIVERY_BUREAU_FAX_DELIVERY = $0C0A000B;
  CdoPR_PHYSICAL_DELIVERY_MODE = $0C0B0003;
  CdoPR_PHYSICAL_DELIVERY_REPORT_REQUEST = $0C0C0003;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS = $0C0D0102;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS_REQUESTED = $0C0E000B;
  CdoPR_PHYSICAL_FORWARDING_PROHIBITED = $0C0F000B;
  CdoPR_PHYSICAL_RENDITION_ATTRIBUTES = $0C100102;
  CdoPR_POST_FOLDER_ENTRIES = $103B0102;
  CdoPR_POST_FOLDER_NAMES = $103C001E;
  CdoPR_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_POST_REPLY_DENIED = $103F0102;
  CdoPR_POST_REPLY_FOLDER_ENTRIES = $103D0102;
  CdoPR_POST_REPLY_FOLDER_NAMES = $103E001E;
  CdoPR_POSTAL_ADDRESS = $3A15001E;
  CdoPR_POSTAL_CODE = $3A2A001E;
  CdoPR_PREFERRED_BY_NAME = $3A47001E;
  CdoPR_PREPROCESS = $0E22000B;
  CdoPR_PRIMARY_CAPABILITY = $39040102;
  CdoPR_PRIMARY_FAX_NUMBER = $3A23001E;
  CdoPR_PRIMARY_TELEPHONE_NUMBER = $3A1A001E;
  CdoPR_PRIORITY = $00260003;
  CdoPR_PROFESSION = $3A46001E;
  CdoPR_PROFILE_NAME = $3D12001E;
  CdoPR_PROOF_OF_DELIVERY = $0C110102;
  CdoPR_PROOF_OF_DELIVERY_REQUESTED = $0C12000B;
  CdoPR_PROOF_OF_SUBMISSION = $0E260102;
  CdoPR_PROOF_OF_SUBMISSION_REQUESTED = $0028000B;
  CdoPR_PROVIDER_DISPLAY = $3006001E;
  CdoPR_PROVIDER_DLL_NAME = $300A001E;
  CdoPR_PROVIDER_ORDINAL = $300D0003;
  CdoPR_PROVIDER_SUBMIT_TIME = $00480040;
  CdoPR_PROVIDER_UID = $300C0102;
  CdoPR_RADIO_TELEPHONE_NUMBER = $3A1D001E;
  CdoPR_RCVD_REPRESENTING_ADDRTYPE = $0077001E;
  CdoPR_RCVD_REPRESENTING_EMAIL_ADDRESS = $0078001E;
  CdoPR_RCVD_REPRESENTING_ENTRYID = $00430102;
  CdoPR_RCVD_REPRESENTING_NAME = $0044001E;
  CdoPR_RCVD_REPRESENTING_SEARCH_KEY = $00520102;
  CdoPR_READ_RECEIPT_ENTRYID = $00460102;
  CdoPR_READ_RECEIPT_REQUESTED = $0029000B;
  CdoPR_READ_RECEIPT_SEARCH_KEY = $00530102;
  CdoPR_RECEIPT_TIME = $002A0040;
  CdoPR_RECEIVE_FOLDER_SETTINGS = $3415000D;
  CdoPR_RECEIVED_BY_ADDRTYPE = $0075001E;
  CdoPR_RECEIVED_BY_EMAIL_ADDRESS = $0076001E;
  CdoPR_RECEIVED_BY_ENTRYID = $003F0102;
  CdoPR_RECEIVED_BY_NAME = $0040001E;
  CdoPR_RECEIVED_BY_SEARCH_KEY = $00510102;
  CdoPR_RECIPIENT_CERTIFICATE = $0C130102;
  CdoPR_RECIPIENT_NUMBER_FOR_ADVICE = $0C14001E;
  CdoPR_RECIPIENT_REASSIGNMENT_PROHIBITED = $002B000B;
  CdoPR_RECIPIENT_STATUS = $0E150003;
  CdoPR_RECIPIENT_TYPE = $0C150003;
  CdoPR_RECORD_KEY = $0FF90102;
  CdoPR_REDIRECTION_HISTORY = $002C0102;
  CdoPR_REFERRED_BY_NAME = $3A47001E;
  CdoPR_REGISTERED_MAIL_TYPE = $0C160003;
  CdoPR_RELATED_IPMS = $002D0102;
  CdoPR_REMOTE_PROGRESS = $3E0B0003;
  CdoPR_REMOTE_PROGRESS_TEXT = $3E0C001E;
  CdoPR_REMOTE_VALIDATE_OK = $3E0D000B;
  CdoPR_RENDERING_POSITION = $370B0003;
  CdoPR_REPLY_RECIPIENT_ENTRIES = $004F0102;
  CdoPR_REPLY_RECIPIENT_NAMES = $0050001E;
  CdoPR_REPLY_REQUESTED = $0C17000B;
  CdoPR_REPLY_TIME = $00300040;
  CdoPR_REPORT_ENTRYID = $00450102;
  CdoPR_REPORT_NAME = $003A001E;
  CdoPR_REPORT_SEARCH_KEY = $00540102;
  CdoPR_REPORT_TAG = $00310102;
  CdoPR_REPORT_TEXT = $1001001E;
  CdoPR_REPORT_TIME = $00320040;
  CdoPR_REPORTING_DL_NAME = $10030102;
  CdoPR_REPORTING_MTA_CERTIFICATE = $10040102;
  CdoPR_REQUESTED_DELIVERY_METHOD = $0C180003;
  CdoPR_RESOURCE_FLAGS = $30090003;
  CdoPR_RESOURCE_METHODS = $3E020003;
  CdoPR_RESOURCE_PATH = $3E07001E;
  CdoPR_RESOURCE_TYPE = $3E030003;
  CdoPR_RESPONSE_REQUESTED = $0063000B;
  CdoPR_RESPONSIBILITY = $0E0F000B;
  CdoPR_RETURNED_IPM = $0033000B;
  CdoPR_ROW_TYPE = $0FF50003;
  CdoPR_ROWID = $30000003;
  CdoPR_RTF_COMPRESSED = $10090102;
  CdoPR_RTF_IN_SYNC = $0E1F000B;
  CdoPR_RTF_SYNC_BODY_COUNT = $10070003;
  CdoPR_RTF_SYNC_BODY_CRC = $10060003;
  CdoPR_RTF_SYNC_BODY_TAG = $1008001E;
  CdoPR_RTF_SYNC_PREFIX_COUNT = $10100003;
  CdoPR_RTF_SYNC_TRAILING_COUNT = $10110003;
  CdoPR_SEARCH = $3607000D;
  CdoPR_SEARCH_KEY = $300B0102;
  CdoPR_SECURITY = $00340003;
  CdoPR_SELECTABLE = $3609000B;
  CdoPR_SEND_INTERNET_ENCODING = $3A710003;
  CdoPR_SEND_RICH_INFO = $3A40000B;
  CdoPR_SENDER_ADDRTYPE = $0C1E001E;
  CdoPR_SENDER_EMAIL_ADDRESS = $0C1F001E;
  CdoPR_SENDER_ENTRYID = $0C190102;
  CdoPR_SENDER_NAME = $0C1A001E;
  CdoPR_SENDER_SEARCH_KEY = $0C1D0102;
  CdoPR_SENSITIVITY = $00360003;
  CdoPR_SENT_REPRESENTING_ADDRTYPE = $0064001E;
  CdoPR_SENT_REPRESENTING_EMAIL_ADDRESS = $0065001E;
  CdoPR_SENT_REPRESENTING_ENTRYID = $00410102;
  CdoPR_SENT_REPRESENTING_NAME = $0042001E;
  CdoPR_SENT_REPRESENTING_SEARCH_KEY = $003B0102;
  CdoPR_SENTMAIL_ENTRYID = $0E0A0102;
  CdoPR_SERVICE_DELETE_FILES = $3D10101E;
  CdoPR_SERVICE_DLL_NAME = $3D0A001E;
  CdoPR_SERVICE_ENTRY_NAME = $3D0B001E;
  CdoPR_SERVICE_EXTRA_UIDS = $3D0D0102;
  CdoPR_SERVICE_NAME = $3D09001E;
  CdoPR_SERVICE_SUPPORT_FILES = $3D0F101E;
  CdoPR_SERVICE_UID = $3D0C0102;
  CdoPR_SERVICES = $3D0E0102;
  CdoPR_SPOOLER_STATUS = $0E100003;
  CdoPR_SPOUSE_NAME = $3A48001E;
  CdoPR_START_DATE = $00600040;
  CdoPR_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_STATUS = $360B0003;
  CdoPR_STATUS_CODE = $3E040003;
  CdoPR_STATUS_STRING = $3E08001E;
  CdoPR_STORE_ENTRYID = $0FFB0102;
  CdoPR_STORE_PROVIDERS = $3D000102;
  CdoPR_STORE_RECORD_KEY = $0FFA0102;
  CdoPR_STORE_STATE = $340E0003;
  CdoPR_STORE_SUPPORT_MASK = $340D0003;
  CdoPR_STREET_ADDRESS = $3A29001E;
  CdoPR_SUBFOLDERS = $360A000B;
  CdoPR_SUBJECT = $0037001E;
  CdoPR_SUBJECT_IPM = $00380102;
  CdoPR_SUBJECT_PREFIX = $003D001E;
  CdoPR_SUBMIT_FLAGS = $0E140003;
  CdoPR_SUPERSEDES = $103A001E;
  CdoPR_SUPPLEMENTARY_INFO = $0C1B001E;
  CdoPR_SURNAME = $3A11001E;
  CdoPR_TELEX_NUMBER = $3A2C001E;
  CdoPR_TEMPLATEID = $39020102;
  CdoPR_TITLE = $3A17001E;
  CdoPR_TNEF_CORRELATION_KEY = $007F0102;
  CdoPR_TRANSMITABLE_DISPLAY_NAME = $3A20001E;
  CdoPR_TRANSPORT_KEY = $0E160003;
  CdoPR_TRANSPORT_MESSAGE_HEADERS = $007D001E;
  CdoPR_TRANSPORT_PROVIDERS = $3D020102;
  CdoPR_TRANSPORT_STATUS = $0E110003;
  CdoPR_TTYTDD_PHONE_NUMBER = $3A4B001E;
  CdoPR_TYPE_OF_MTS_USER = $0C1C0003;
  CdoPR_USER_CERTIFICATE = $3A220102;
  CdoPR_USER_X509_CERTIFICATE = $3A701102;
  CdoPR_VALID_FOLDER_MASK = $35DF0003;
  CdoPR_VIEWS_ENTRYID = $35E50102;
  CdoPR_WEDDING_ANNIVERSARY = $3A410040;
  CdoPR_X400_CONTENT_TYPE = $003C0102;
  CdoPR_X400_DEFERRED_DELIVERY_CANCEL = $3E09000B;
  CdoPR_XPOS = $3F050003;
  CdoPR_YPOS = $3F060003;

  // General
  PR_IPM_PUBLIC_FOLDERS_ENTRYID = $66310102;
  CdoDefaultFolderCalendar = 0;
  CdoDefaultFolderContacts = 5;
  CdoDefaultFolderDeletedItems = 4;
  CdoDefaultFolderInbox = 1;
  CdoDefaultFolderJournal = 6;
  CdoDefaultFolderNotes = 7;
  CdoDefaultFolderOutbox = 2;
  CdoDefaultFolderSentItems = 3;
  CdoDefaultFolderTasks = 8;

  // Message Recipients
  CdoTo = 1;
  CdoCc = 2;
  CdoBcc = 3;

  // Attachment Types
  CdoFileData = 1;
  CdoFileLink = 2;
  CdoOLE = 3;
  CdoEmbeddedMessage = 4;

  // AddressEntry DisplayType
  CdoUser = 0; //        A local messaging user.
  CdoDistList = 1; //        A public distribution list.
  CdoForum = 2; //        A forum, such as a bulletin board or a public folder.
  CdoAgent = 3; //        An automated agent, such as Quote-of-the-Day.
  CdoOrganization = 4;
  //        A special address entry defined for large groups, such as a helpdesk.
  CdoPrivateDistList = 5; //        A private, personally administered distribution list.
  CdoRemoteUser = 6; //        A messaging user in a remote messaging system.

  // Error Codes
  CdoE_OK = 0;
  CdoE_ACCOUNT_DISABLED = $80040124;
  CdoE_AMBIGUOUS_RECIP = $80040700;
  CdoE_BAD_CHARWIDTH = $80040103;
  CdoE_BAD_COLUMN = $80040118;
  CdoE_BAD_VALUE = $80040301;
  CdoE_BUSY = $8004010B;
  CdoE_CALL_FAILED = $80004005;
  CdoE_CANCEL = $80040501;
  CdoE_COLLISION = $80040604;
  CdoE_COMPUTED = $8004011A;
  CdoE_CORRUPT_DATA = $8004011B;
  CdoE_CORRUPT_STORE = $80040600;
  CdoE_DECLINE_COPY = $80040306;
  CdoE_DISK_ERROR = $80040116;
  CdoE_END_OF_SESSION = $80040200;
  CdoE_EXTENDED_ERROR = $80040119;
  CdoE_FAILONEPROVIDER = $8004011D;
  CdoE_FOLDER_CYCLE = $8004060B;
  CdoE_HAS_FOLDERS = $80040609;
  CdoE_HAS_MESSAGES = $8004060A;
  CdoE_INTERFACE_NOT_SUPPORTED = $80004002;
  CdoE_INVALID_ACCESS_TIME = $80040123;
  CdoE_INVALID_BOOKMARK = $80040405;
  CdoE_INVALID_ENTRYID = $80040107;
  CdoE_INVALID_OBJECT = $80040108;
  CdoE_INVALID_PARAMETER = $80070057;
  CdoE_INVALID_TYPE = $80040302;
  CdoE_INVALID_WORKSTATION_ACCOUNT = $80040122;
  CdoE_LOGON_FAILED = $80040111;
  CdoE_MISSING_REQUIRED_COLUMN = $80040202;
  CdoE_NETWORK_ERROR = $80040115;
  CdoE_NO_ACCESS = $80070005;
  CdoE_NO_RECIPIENTS = $80040607;
  CdoE_NO_SUPPORT = $80040102;
  CdoE_NO_SUPPRESS = $80040602;
  CdoE_NON_STANDARD = $80040606;
  CdoE_NOT_ENOUGH_DISK = $8004010D;
  CdoE_NOT_ENOUGH_MEMORY = $8007000E;
  CdoE_NOT_ENOUGH_RESOURCES = $8004010E;
  CdoE_NOT_FOUND = $8004010F;
  CdoE_NOT_IN_QUEUE = $80040601;
  CdoE_NOT_INITIALIZED = $80040605;
  CdoE_NOT_ME = $80040502;
  CdoE_OBJECT_CHANGED = $80040109;
  CdoE_OBJECT_DELETED = $8004010A;
  CdoE_PASSWORD_CHANGE_REQUIRED = $80040120;
  CdoE_PASSWORD_EXPIRED = $80040121;
  CdoE_SESSION_LIMIT = $80040112;
  CdoE_STRING_TOO_LONG = $80040105;
  CdoE_SUBMITTED = $80040608;
  CdoE_TABLE_EMPTY = $80040402;
  CdoE_TABLE_TOO_BIG = $80040403;
  CdoE_TIMEOUT = $80040401;
  CdoE_TOO_BIG = $80040305;
  CdoE_TOO_COMPLEX = $80040117;
  CdoE_TYPE_NO_SUPPORT = $80040303;
  CdoE_UNABLE_TO_ABORT = $80040114;
  CdoE_UNABLE_TO_COMPLETE = $80040400;
  CdoE_UNCONFIGURED = $8004011C;
  CdoE_UNEXPECTED_ID = $80040307;
  CdoE_UNEXPECTED_TYPE = $80040304;
  CdoE_UNKNOWN_CPID = $8004011E;
  CdoE_UNKNOWN_ENTRYID = $80040201;
  CdoE_UNKNOWN_FLAGS = $80040106;
  CdoE_UNKNOWN_LCID = $8004011F;
  CdoE_USER_CANCEL = $80040113;
  CdoE_VERSION = $80040110;
  CdoE_WAIT = $80040500;
  CdoW_APPROX_COUNT = $00040482;
  CdoW_CANCEL_MESSAGE = $00040580;
  CdoW_ERRORS_RETURNED = $00040380;
  CdoW_NO_SERVICE = $00040203;
  CdoW_PARTIAL_COMPLETION = $00040680;
  CdoW_POSITION_CHANGED = $00040481;

type
  TOleVarPtr = ^OleVariant;

  TCdoMapiSession = class(TObject)
  private
    FImpersonated: boolean;
    FLastErrorCode: DWORD;
    FMyName,
      FMyEMailAddress,
      FLastError: string;
    FCurrentUser,
      FOleGlobalAddressList,
      FOleDeletedItems,
      FOleOutBox, FOleSentItems,
      FOleInbox, FOleContacts,
      FOleSession: OleVariant;
    FConnected: boolean;
    function GetFVersion: string;
  protected
    procedure SetOleFolders;
  public
    // System
    constructor Create; overload;
    constructor Create(const Profile: string); overload;
    constructor Create(const Profile: string;
      const UserName: string;
      const Domain: string;
      const Password: string); overload;
    destructor Destroy; override;

    // User
    function LoadAddressList(StringList: TStrings): boolean;
    function LoadObjectList(const FolderOle: OleVariant; List: TList): boolean;
    function LoadEMailTree(TV: TTreeView; Expand1stLevel: boolean = false;
      SubjectMask: string = ''): boolean;
    function LoadContactList(const FolderOle: OleVariant;
      Items: TStrings): boolean; overload;
    function LoadContactList(const FolderName: string;
      Items: TStrings): boolean; overload;
    procedure ShowContactDetails(Contact: OleVariant);

    function First(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Last(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Next(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Prior(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function AsString(const ItemOle: Olevariant; const FieldIdConstant: DWORD):
      string;

    // Properties
    property CurrentUser: OleVariant read FCurrentUser;
    property Connected: boolean read FConnected;
    property LastErrorMess: string read FlastError;
    property LastErrorCode: DWORD read FlastErrorCode;
    property InBox: OleVariant read FOleInBox;
    property OutBox: OleVariant read FOleOutBox;
    property DeletedItems: Olevariant read FOleDeletedItems;
    property SentItems: Olevariant read FOleSentItems;
    property GlobalAddressList: Olevariant read FOleGlobalAddressList;
    property Contacts: Olevariant read FOleContacts;
    property Session: OleVariant read FOleSession;
    property Version: string read GetFVersion;
    property MyName: string read FMyName;
    property MyEMailAddress: string read FMyEMailAddress;
  end;

  // Function Prototypes
function CdoNothing(Obj: OleVariant): boolean;
function CdoDefaultProfile: string;
procedure CdoDisposeList(WorkList: TList);
procedure CdoDisposeObjects(WorkStrings: TStrings);
procedure CdoDisposeNodes(WorkData: TTreeNodes);

function VarNothing: IDispatch;

// -----------------------------------------------------------------------------
implementation

// ===================================
// Emulate VB function IS NOTHING
// ===================================

function CdoNothing(Obj: OleVariant): boolean;
begin
  Result := IDispatch(Obj) = nil;
end;

// ============================================
// Emulate VB function VarX := Nothing
// ============================================

function VarNothing: IDispatch;
var
  Retvar: IDispatch;
begin
  Retvar := nil;
  Result := Retvar;
end;

// ============================================
// Get Default Message profile from registry
// ============================================

function CdoDefaultProfile: string;
var
  WinReg: TRegistry;
  Retvar: string;
begin
  Retvar := '';
  WinReg := TRegistry.Create;

  if
    WinReg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles', false) then
  begin
    Retvar := WinReg.ReadString('DefaultProfile');
    WinReg.CloseKey;
  end;

  WinReg.Free;
  Result := Retvar;
end;

// =================================================
// Disposes of any memory allocations in a TList
// =================================================

procedure CdoDisposeList(WorkList: TList);
var
  i: integer;
begin
  if WorkList <> nil then
    for i := 0 to WorkList.Count - 1 do
      if WorkList[i] <> nil then
        dispose(WorkList[i]);
end;

// ====================================================
// Disposes of any memory allocations in a TStringList
// ====================================================

procedure CdoDisposeObjects(WorkStrings: TStrings);
var
  i: integer;
begin
  if WorkStrings <> nil then
    for i := 0 to WorkStrings.Count - 1 do
      if WorkStrings.Objects[i] <> nil then
        dispose(TOleVarPtr(WorkStrings.Objects[i]));
end;

// ====================================================
// Disposes of any memory allocations in a TTreeView
// ====================================================

procedure CdoDisposeNodes(WorkData: TTreeNodes);
var
  i: integer;
  TN: TTreeNode;
begin
  if WorkData <> nil then
  begin
    for i := 0 to WorkData.Count - 1 do
    begin
      TN := WorkData[i];
      if TN.Data <> nil then
        dispose(TOleVarPtr(TN.Data));
    end;
  end;
end;

// -----------------------------------------------------------------------------
// TCdoMapiSession
// -----------------------------------------------------------------------------

// ================
// Default Profile
// ================

constructor TCdoMapiSession.Create;
begin
  FImpersonated := false;
  FLastError := '';
  FLastErrorCode := CdoE_OK;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(CdoDefaultProfile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ===========================
// With Specified Profile
// ===========================

constructor TCdoMapiSession.Create(const Profile: string);
begin
  FImpersonated := false;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================================================
// Impersonate amother user and use specified profile
// ======================================================

constructor TCdoMapiSession.Create(const Profile: string;
  const UserName: string;
  const Domain: string;
  const Password: string);
var
  SecurityH: THandle;
begin
  FImpersonated := false;
  try
    LogonUser(PChar(UserName), PChar(Domain), PChar(Password),
      LOGON32_LOGON_SERVICE,
      LOGON32_PROVIDER_DEFAULT, SecurityH);
    FImpersonated := ImpersonateLoggedOnUser(SecurityH);
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile, Password, false, true);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================
// Free and Clean up
// ======================

destructor TCdoMapiSession.Destroy;
begin
  if FConnected then
    FOleSession.LogOff;
  FCurrentUser := Unassigned;
  FOleGlobalAddressList := Unassigned;
  FOleSentItems := Unassigned;
  FOleContacts := Unassigned;
  FOleOutBox := Unassigned;
  FOleDeletedItems := Unassigned;
  FOleInBox := Unassigned;
  FOleSession := Unassigned;
  if FImpersonated then
    RevertToSelf;
  inherited Destroy;
end;

// =======================================================
// Addition initialization called by Create() oveloads
// =======================================================

procedure TCdoMapiSession.SetOleFolders;
begin
  try
    FOleGlobalAddressList :=
      FOleSession.AddressLists['Global Address List'].AddressEntries;
  except
    FOleGlobalAddressList := VarNothing;
  end;

  try
    FOleContacts := FOleSession.AddressLists['Contacts'].AddressEntries;
  except
    FOleContacts := VarNothing;
  end;

  try
    FOleInBox := FOleSession.InBox.Messages;
  except
    FOleInBox := VarNothing;
  end;

  try
    FOleOutBox := FOleSession.OutBox.Messages;
  except
    FOleOutBox := VarNothing;
  end;

  try
    FOleDeletedItems :=
      FOleSession.GetDefaultFolder(CdoDefaultFolderDeletedItems).Messages;
  except
    FOleDeletedItems := VarNothing;
  end;

  try
    FOleSentItems := FOleSession.GetDefaultFolder(CdoDefaultFolderSentItems).Messages;
  except
    FOleSentItems := VarNothing;
  end;

  try
    FCurrentUser := FOleSession.CurrentUser;
    FMyName := FCurrentUser.Name;
  except
    FCurrentUser := VarNothing;
  end;

  FConnected := true;
  FMyEMailAddress := AsString(FCurrentUser, CdoPR_EMAIL_AT_ADDRESS);
end;

// ======================
// Return CDO Version
// ======================

function TCdoMapiSession.GetFVersion: string;
begin
  if FConnected then
    Result := FOleSession.Version
  else
    Result := 'Not Connected';
end;

// ========================================================
// Fill a string list with all available address lists
// ========================================================

function TCdoMapiSession.LoadAddressList(StringList: TStrings): boolean;
var
  Addr: OleVariant;
  i: integer;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    StringList.Clear;
    try
      Addr := FOleSession.AddressLists;
      for i := 1 to Addr.Count do
        StringList.Add(Addr.Item[i].Name);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
      end;
    end;

    Addr := Unassigned;
  end;

  Result := Retvar;
end;

// =================================================
// Iteration functions
// =================================================

function TCdoMapiSession.First(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetFirst;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Last(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetLast;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Next(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetNext;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Prior(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetPrior;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

// =========================
// Field Get Routines
// =========================

function TCdoMapiSession.AsString(const ItemOle: Olevariant;
  const FieldIdConstant: DWORD): string;
var
  Retvar: string;
begin
  if FConnected then
  begin
    // Special case for EMail Address - Resolve to normal form
    if FieldIdConstant = CdoPR_EMAIL_AT_ADDRESS then
    begin
      try
        RetVar := ItemOle.Fields[CdoPR_EMAIL_AT_ADDRESS];
      except
        try
          Retvar := ItemOle.Fields[CdoPR_EMAIL_ADDRESS];
        except
          on E: Exception do
          begin
            FLastError := E.Message;
            FLastErrorCode := CdoE_INVALID_OBJECT;
            Retvar := '';
          end;
        end;
      end;
    end
    else
    begin
      try
        RetVar := ItemOle.Fields[FieldIdConstant];
      except
        on E: Exception do
        begin
          FLastError := E.Message;
          FLastErrorCode := CdoE_INVALID_OBJECT;
          Retvar := '';
        end;
      end;
    end;
  end
  else
    Retvar := '';

  Result := Retvar;
end;

// ================================================
// Load EMail folders Messages into a TTreeView
// Allocations in Nodes are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeNodes or dispose of the allocations
// yourself at Application end
// ================================================

function TCdoMapiSession.LoadEMailTree(TV: TTreeView;
  Expand1stLevel: boolean = false;
  SubjectMask: string = ''): boolean;
var
  DocPtr: TOleVarPtr;
  Item: OleVariant;
  TN, RN, XN: TTreeNode;
  Retvar,
    Images: boolean;

  procedure AddTree(const Name: string; Folder: Olevariant);
  begin
    if First(Folder, Item) then
    begin
      TN := TV.Items.AddChildObject(RN, Name, nil);
      if Images then
      begin
        TN.ImageIndex := 0;
        TN.SelectedIndex := 0;
      end;

      while true do
      begin
        if (SubjectMask = '') or (MatchesMask(Item.Subject, SubjectMask)) then
        begin
          New(DocPtr);
          DocPtr^ := Item;
          if Item.Subject = '' then
            XN := TV.Items.AddChildObject(TN, '<No Subject> - ' + Item.Sender.Name,
              DocPtr)
          else
            XN := TV.Items.AddChildObject(TN, Item.Subject, DocPtr);

          if Images then
          begin
            XN.ImageIndex := 1;
            XN.SelectedIndex := 1;
          end;
        end;

        if not Next(Folder, Item) then
          break;
      end;
    end;
  end;

begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeNodes(TV.Items);
    TV.Items.Clear;
    TV.Items.BeginUpdate;
    TN := nil;
    RN := nil;
    RN := TV.Items.AddObject(RN, 'Personal Folders', nil);
    Images := (TV.Images <> nil) and (TV.Images.Count >= 2);
    if Images then
    begin
      RN.ImageIndex := 0;
      RN.SelectedIndex := 0;
    end;

    try
      AddTree('Inbox', InBox);
      AddTree('Outbox', OutBox);
      AddTree('Sent Items', SentItems);
      AddTree('Deleted Items', DeletedItems);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    if Expand1stLevel then
      TV.Items[0].Expand(false);
    TV.Items.EndUpdate;
    Screen.Cursor := crDefault;
    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Contact list into a TStringList
// Allocations in Objects are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeObjects or dispose of the allocations yourself at
// Application end.
//
// Format "[LastName FirstName]EMailAddress"
// ===============================================================

function TCdoMapiSession.LoadContactList(const FolderOle: OleVariant;
  Items: TStrings): boolean;
var
  ContactPtr: TOleVarPtr;
  Contact: OleVariant;
  AddrType,
    FullName,
    LastName, FirstName, Email: string;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeObjects(Items);
    Items.Clear;
    Items.BeginUpdate;

    try
      if First(FolderOle, Contact) then
      begin
        while true do
        begin
          LastName := trim(AsString(Contact, CdoPR_SURNAME));
          FirstName := trim(AsString(Contact, CdoPR_GIVEN_NAME));
          EMail := AsString(Contact, CdoPR_EMAIL_AT_ADDRESS);
          AddrType := AsString(Contact, CdoPR_ADDRTYPE);

          if (EMail <> '') and (AddrType <> 'FAX') then
          begin
            New(ContactPtr);
            ContactPtr^ := Contact;
            FullName := trim(LastName + ' ' + FirstName);
            Items.AddObject('[' + FullName + ']' + EMail, TObject(ContactPtr));
          end;

          if not Next(FolderOle, Contact) then
            break;
        end;

        Retvar := true;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Items.EndUpdate;
    Contact := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

function TCdoMapiSession.LoadContactList(const FolderName: string;
  Items: TStrings): boolean;
var
  Contacts: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    try
      Contacts := FOleSession.AddressLists[FolderName].AddressEntries;
      if not CdoNothing(Contacts) then
      begin
        Retvar := LoadContactList(Contacts, Items);
      end;
      Contacts := Unassigned;
    except
      on E: Exception do
      begin
        CdoDisposeObjects(Items);
        Items.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Folder list into a TList
// Allocations in Objects are freed at each call to
// LoadObjectList, but you are responsible to call
// CdoDisposeList or dispose of the allocations yourself at
// Application end.
// ===============================================================

function TCdoMapiSession.LoadObjectList(const FolderOle: OleVariant;
  List: TList): boolean;
var
  ItemPtr: TOleVarPtr;
  Item: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeList(List);
    List.Clear;

    try
      if First(FolderOle, Item) then
      begin
        while true do
        begin
          New(ItemPtr);
          ItemPtr^ := Item;
          List.Add(ItemPtr);

          if not Next(FolderOle, Item) then
            break;
        end;
      end;
    except
      on E: Exception do
      begin
        CdoDisposeList(List);
        List.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =================================================================
// The CDO method Details() gives an error if cancel is pressed
// =================================================================

procedure TCdoMapiSession.ShowContactDetails(Contact: OleVariant);
begin
  if not CdoNothing(Contact) then
  try
    Contact.Details(Application.Handle);
  except
    // Not interested - either a dialog appears or not
  end;
end;

end.