Check if a TTreeView is fully expanded or collapsed

Problem/Question/Abstract:

How to check if a TTreeView is fully expanded or collapsed

Answer:

function IsTreeviewFullyExpanded(tv: TTreeview): Boolean;
var
  node: TTreenode;
begin
  Assert(Assigned(tv));
  if tv.items.count > 0 then
  begin
    node := tv.Items[0];
    Result := true;
    while Result and Assigned(node) do
    begin
      Result := node.Expanded or not node.HasChildren;
      node := node.GetNext;
    end;
  end
  else
    Result := false
end;

function IsTreeviewFullyCollapsed(tv: TTreeview): Boolean;
var
  node: TTreenode;
begin
  Assert(Assigned(tv));
  if tv.items.count > 0 then
  begin
    node := tv.Items[0];
    Result := true;
    while Result and Assigned(node) do
    begin
      Result := not (node.Expanded and node.HasChildren);
      node := node.GetNext;
    end;
  end
  else
    Result := false
end;

How to open a specific drive when you have two CD-ROM drives

Problem/Question/Abstract:

How to open a specific drive when you have two CD-ROM drives

Answer:

function IsDriveCD(Drive: Char): boolean;
var
  DrivePath: string;
begin
  DrivePath := Drive + ':\';
  Result := (GetDriveType(PChar(DrivePath)) = DRIVE_CDROM);
end;

function EjectCD(Drive: Char): boolean;
var
  mp: TMediaPlayer;
begin
  Result := false;
  if not IsDriveCD(Drive) then
    exit;
  mp := TMediaPlayer.Create(nil);
  try
    mp.Visible := false;
    mp.Parent := Application.Mainform;
    mp.Shareable := true;
    mp.DeviceType := dtCDAudio;
    mp.FileName := Drive + ':';
    mp.Open;
    mp.Eject;
    mp.Close;
  finally
    mp.Free;
  end;
end;

How to make a dynamically created TLabel draggable

Problem/Question/Abstract:

How to make a dynamically created TLabel draggable

Answer:

Create a new project with an empty form, add StdCtls to the Uses clause (for the TLabel class, you can also add a single label at design time). Add a handler to the forms OnClick method, then modify the unit as below. Compile and run, click on the form to create a label, drag on a label to move it.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormClick(Sender: TObject);
  private
    { Private declarations }
    downX, downY: Integer;
    dragging: Boolean;
    procedure ControlMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure ControlMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TCracker = class(TControl);
  { Needed since TControl.MouseCapture is protected }

procedure TForm1.FormClick(Sender: TObject);
var
  pt: TPoint;
begin
  {get cursor position, convert to client coordinates}
  GetCursorPos(pt);
  pt := ScreenToClient(pt);
  {create label with top left corner at mouse position}
  with TLabel.Create(Self) do
  begin
    SetBounds(pt.x, pt.y, width, height);
    Caption := Format('Hit at %d, %d', [pt.x, pt.y]);
    Color := clBlue;
    Font.Color := clWhite;
    Autosize := true;
    Parent := Self;
    {attach the drag handlers}
    OnMouseDown := ControlMouseDown;
    OnMouseUp := ControlMouseUp;
    OnMouseMove := ControlMouseMove;
  end;
end;

procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  downX := X;
  downY := Y;
  dragging := TRue;
  with TCracker(Sender) do
  begin
    MouseCapture := True;
    Color := clRed;
  end;
end;

procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if dragging then
    with Sender as TControl do
    begin
      Left := X - downX + Left;
      Top := Y - downY + Top;
    end;
end;

procedure TForm1.ControlMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if dragging then
  begin
    dragging := False;
    with TCracker(Sender) do
    begin
      MouseCapture := False;
      Color := clBlue;
    end;
  end;
end;

end.

How to detect if a point lies within a polygon

Problem/Question/Abstract:

Can anyone help me with detecting if the screen coordinates that a user has clicked on lies within a defined polygon?

Answer:

The code below is from Wm. Randolph Franklin with some minor modifications for speed. It returns 1 for strictly interior points, 0 for strictly exterior, and 0 or 1 for points on the boundary.

function PointInPolygonTest(x, y: Integer; aList: array of TPoint): Boolean;
var
  L, I, J: Integer;

  function xp(aVal: Integer): Integer;
  begin
    Result := PPoint(@aList[aVal]).X;
  end;

  function yp(aVal: Integer): Integer;
  begin
    Result := PPoint(@aList[aVal]).Y;
  end;

begin
  Result := False;
  L := Length(aList);
  if L = 0 then
    exit;
  J := L - 1;
  for I := 0 to L - 1 do
  begin
    if ((((yp(I) <= y) and (y < yp(J))) or ((yp(J) <= y) and (y < yp(I)))) and
      (x < (xp(J) - xp(I)) * (y - yp(I)) / (yp(J) - yp(I)) + xp(I))) then
      Result := not Result;
    J := I;
  end;
end;

How to write a list of strings to the registry

Problem/Question/Abstract:

I want to save the contents of a stringlist to the registry and later read it back. How can I do this?

Answer:

Save a list of strings to the registry. It will write each string as a key value with the key being the index of each string element and the value being the key.


procedure TDPRegistry.SaveStringListInRegistry(_RootKey: HKEY; _Localkey: string;
  Strings: TStrings);
var
  TR: TRegIniFile;
  LStringIndex: Integer;
begin
  TR := TRegIniFile.Create('');
  try
    case _RootKey of { default is RootKey=HKEY_CURRENT_USER }
      HKEY_CLASSES_ROOT,
        HKEY_CURRENT_USER,
        HKEY_LOCAL_MACHINE,
        HKEY_USERS,
        HKEY_PERFORMANCE_DATA,
        HKEY_CURRENT_CONFIG,
        HKEY_DYN_DATA: TR.RootKey := _RootKey;
    end;
    TR.EraseSection(_Localkey); {make sure no entries for this section/ key}
    with TRegistry(TR) do
    begin
      if OpenKey(_Localkey, true) then
      begin
        try
          for LStringIndex := 0 to Strings.Count - 1 do
          begin
            WriteString(IntToStr(LStringIndex), Strings[LStringIndex]);
          end; {for each string in the list}
        finally
          CloseKey;
        end;
      end;
    end;
  finally
    TR.Free;
  end;
end;

{Get list of strings from registry}

procedure TDPRegistry.GetStringListFromRegistry(_RootKey: HKEY; _Localkey: string;
  Strings: TStrings);
var
  TR: TRegIniFile;
  LStringIndex: Integer;
  RegKeyInfo: TRegKeyInfo;
begin
  Strings.Clear; {start with no elements in string list}
  TR := TRegIniFile.Create('');
  try
    case _RootKey of { default is  RootKey=HKEY_CURRENT_USER  }
      HKEY_CLASSES_ROOT,
        HKEY_CURRENT_USER,
        HKEY_LOCAL_MACHINE,
        HKEY_USERS,
        HKEY_PERFORMANCE_DATA,
        HKEY_CURRENT_CONFIG,
        HKEY_DYN_DATA: TR.RootKey := _RootKey;
    end;
    {TR.ReadSectionValues(_Localkey, Strings); doesn't work nicely because it
    returns strings as "1=Value", "2=Value"...}
    with TRegistry(TR) do
    begin
      if OpenKey(_Localkey, true) then
      begin
        try
          if (GetKeyInfo(RegKeyInfo)) then
          begin
            for LStringIndex := 0 to RegKeyInfo.NumValues - 1 do
            begin
              Strings.Add(ReadString(IntToStr(LStringIndex)));
            end; {for each value associated with this key}
          end; {got key information}
        finally
          CloseKey;
        end;
      end;
    end;
  finally
    TR.Free;
  end;
end;

Resize a TControl object graphically

Problem/Question/Abstract:

Move or resize graphically a TControl object by using another objet that has all the necessary code.

Answer:

The unit showed bellow is for the TControlHandler class.

TControlHandler can manipulate graphically any descendant of the TControl class. A TControl objet can be selected by the TControlHandler Control property : a border appears surrounding the control passed to this method as  reference. At run-time, you can then change its location or change its size with the mouse.
For example, in an application, create a TControlHandler at startup :

FControlHandler := TControlHandler.Create(Self);

To manipulate a Button1 objet placed on the form, write the following instruction :

FControlHandler.Control := Button1;

You can choose another control by assigning a new TControl's reference ; the previous one is deselected.


unit ControlHandler;

// Written by Bertrand Goetzmann (http://www.object-everywhere.com)

interface

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

type
  TControlPoint = (pcTopLeft, pcTopRight, pcBottomLeft, pcBottomRight, pcOther);

  TControlHandler = class(TCustomControl)
  private
    Rgn: HRGN;
    R, R1: TRect;
    Pos: TPoint;
    Pt: TControlPoint;
    bDrag: Boolean;
  protected
    FControl: TControl;
    procedure SetRegion;
    function GetControlPoint(const Point: TPoint): TControlPoint;
    procedure Paint; override;
    procedure MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer);
    procedure MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer);
    procedure MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetControl(Control: TControl);
  published
    property Control: TControl read FControl write SetControl;
  end;

implementation

const
  LARGEUR = 5;

  // M�thodes de TControlHandler

constructor TControlHandler.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := AOwner as TWinControl;

  Rgn := 0;
  bDrag := False;

  OnMouseDown := MouseDown;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end;

destructor TControlHandler.Destroy;
begin
  if Rgn <> 0 then
    DeleteObject(Rgn);
  inherited Destroy;
end;

function TControlHandler.GetControlPoint(const Point: TPoint): TControlPoint;
begin
  Result := pcOther;
  if PtInRect(Rect(0, 0, LARGEUR, LARGEUR), Point) then
    Result := pcTopLeft
  else if PtInRect(Rect(Width - LARGEUR, 0, Width, LARGEUR), Point) then
    Result := pcTopRight
  else if PtInRect(Rect(0, Height - LARGEUR, LARGEUR, Height), Point) then
    Result := pcBottomLeft
  else if PtInRect(Rect(Width - LARGEUR, Height - LARGEUR, Width, Height), Point) then
    Result := pcBottomRight;
end;

procedure TControlHandler.MouseDown(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  Pos.x := X;
  Pos.y := Y;
  bDrag := True;

  R := Rect(FControl.Left, FControl.Top, FControl.Left + FControl.Width, FControl.Top
    + FControl.Height);
  R1 := Rect(FControl.Left, FControl.Top, FControl.Left + FControl.Width, FControl.Top
    + FControl.Height);

  Pt := GetControlPoint(Pos);

  Visible := False;
end;

procedure TControlHandler.MouseUp(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  Screen.Cursor := crDefault;
  bDrag := False;

  Control.Left := R.Left;
  Control.Top := R.Top;
  Control.Width := R.Right - R.Left;
  Control.Height := R.Bottom - R.Top;

  SetRegion;

  Visible := True;
end;

procedure TControlHandler.MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
begin
  case GetControlPoint(Point(X, Y)) of
    pcTopLeft:
      Cursor := crSizeNWSE;
    pcTopRight:
      Cursor := crSizeNESW;
    pcBottomLeft:
      Cursor := crSizeNESW;
    pcBottomRight:
      Cursor := crSizeNWSE;
    pcOther:
      Cursor := crDrag;
  end;

  if not bDrag then
    Exit;

  case Pt of
    pcTopLeft:
      begin
        R.Left := R1.Left + X - Pos.x;
        R.Top := R1.Top + Y - Pos.y;
      end;
    pcTopRight:
      begin
        R.Right := R1.Right + X - Pos.x;
        R.Top := R1.Top + Y - Pos.y;
      end;
    pcBottomLeft:
      begin
        R.Left := R1.Left + X - Pos.x;
        R.Bottom := R1.Bottom + Y - Pos.y;
      end;
    pcBottomRight:
      begin
        R.Right := R1.Right + X - Pos.x;
        R.Bottom := R1.Bottom + Y - Pos.y;
      end;
    pcOther:
      begin
        R.Left := R1.Left + X - Pos.x;
        R.Top := R1.Top + Y - Pos.y;
        R.Right := R1.Right + X - Pos.x;
        R.Bottom := R1.Bottom + Y - Pos.y;
      end;
  end;

  with FControl do
  begin
    Left := R.Left;
    Top := R.Top;
    Width := R.Right - R.Left;
    Height := R.Bottom - R.Top;
  end;
end;

procedure TControlHandler.SetRegion;
var
  Rgn1, Rgn2: HRGN;
begin
  if Rgn <> 0 then
    DeleteObject(Rgn);
  Visible := False;

  Left := Control.Left - LARGEUR;
  Top := Control.Top - LARGEUR;
  Width := Control.Width + 2 * LARGEUR;
  Height := Control.Height + 2 * LARGEUR;

  Rgn := CreateRectRgn(0, 0, Width, Height);
  Rgn1 := CreateRectRgn(0, 0, Width, Height);
  Rgn2 := CreateRectRgn(LARGEUR, LARGEUR, Control.Width + LARGEUR, Control.Height +
    LARGEUR);
  CombineRgn(Rgn, Rgn1, Rgn2, RGN_DIFF);
  DeleteObject(Rgn1);
  DeleteObject(Rgn2);
  SetWindowRgn(Handle, Rgn, True);

  Visible := True;
end;

procedure TControlHandler.SetControl(Control: TControl);
begin
  FControl := Control;
  SetRegion;
end;

procedure TControlHandler.Paint;
begin
  with Canvas do
  begin
    Brush.Color := clBlack;
    Brush.Style := bsBDiagonal;
    Rectangle(0, 0, Width, Height);

    // Dessiner les poignets
    Brush.Style := bsSolid;
    FillRect(Rect(0, 0, LARGEUR, LARGEUR));
    FillRect(Rect(Width - LARGEUR, 0, Width, LARGEUR));
    FillRect(Rect(0, Height - LARGEUR, LARGEUR, Height));
    FillRect(Rect(Width - LARGEUR, Height - LARGEUR, Width, Height));
  end;
end;

end.


Component Download: http://perso.worldonline.fr/objecteverywhere/control.zip

Remove all components of a certain type at run time

Problem/Question/Abstract:

How to remove all components of a certain type at run time

Answer:

//implementation:

procedure Tform1.freeInstances(aClass: TClass);
var
  i: Integer;
begin
  for i := formFacture.ControlCount - 1 downto 0 do
    if (Controls[i] is aClass) then
    begin
      (Controls[i] as aClass).Free;
        //instead of free you can put anything you need here
    end;
end;

//calling:

procedure Tform1.Button1Click(Sender: TObject);
begin
  freeInstances(TEdit); //will free all tedit on form1
end;

How to get the size of a text file without opening it

Problem/Question/Abstract:

How to get the size of a text file without opening it

Answer:

Returns the size, in bytes, of the passed file:

function TextfileSize(const name: string): LongInt;
var
  SRec: TSearchRec;
begin
  if FindFirst(name, faAnyfile, SRec) = 0 then
  begin
    Result := SRec.Size;
    Sysutils.FindClose(SRec);
  end
  else
    Result := 0;
end;

How to create a hotspot

Problem/Question/Abstract:

I need something like a hotspot that would lie above everything else and under certain conditions trap mouse events and under other conditions, let them through. I understand, to get the mouse events before anybody else it must be a TWinControl descendant? How do I make it transparent then?

Answer:

Here's one I wrote a couple of years ago. It isn't a TWinControl descendant, TGraphicControl instead, but it handles MouseEnter and MouseLeave. If you want others, you need to add them

{
TEXSHotSpot:
HotSpot Component which allows developers to insert a "HotSpot" on top of an image or panel but lets the background show through and handle mouse entering and leaving the rectangle region of the component.

New Property:
ShowBorder- Use this if you want a border to show around the hotspot when the mouse is over it. Similar to the flat speedbutton look.
}

unit EXSHotSpot;

interface

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

type
  TEXSHotSpot = class(TGraphicControl)
  private
    { Private declarations }
    FMouseInControl: Boolean;
    FShowBorder: Boolean;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure DrawBorder;
    function GetShowBorder: Boolean;
    procedure SetShowBorder(Value: Boolean);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Align;
    property Enabled;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
    property OnDragDrop;
    property OnEndDrag;
    property ShowBorder: Boolean read GetShowBorder write SetShowBorder;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

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

procedure TEXSHotSpot.DrawBorder;
var
  R: TRect;
begin
  R := ClientRect;
  InflateRect(R, -1, -1);
  Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
end;

procedure TEXSHotSpot.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if not FMouseInControl and Enabled then
  begin
    FMouseInControl := True;
    if FShowBorder then
      DrawBorder;
  end;
end;

procedure TEXSHotSpot.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FMouseInControl and Enabled then
  begin
    FMouseInControl := False;
    Invalidate;
  end;
end;

constructor TEXSHotSpot.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Height := 105;
  Width := 105;
end;

destructor TEXSHotSpot.Destroy;
begin
  inherited Destroy;
end;

function TEXSHotSpot.GetShowBorder: Boolean;
begin
  Result := FShowBorder;
end;

procedure TEXSHotSpot.SetShowBorder(Value: Boolean);
begin
  if Value <> FShowBorder then
    FShowBorder := Value;
  Repaint;
end;

end.

Set a printer settings

Problem/Question/Abstract:

How can I set a some printer settings?

Answer:

At first, of course, you must open the printer device (as I described in previous tip " to get a printer settings").

Now you can set the any settings (supported only, of course) in properties of DevMode^ variable and add a "assigned" flag in DevMode^.dmFields.
After that you need call a SetPrinter procedure and unlock device.

View small example:

procedure SetPrinterSettings(FPrinter: TPrinter);
var
  FDevice: PChar;
  FDriver: PChar;
  FPort: PChar;
  DeviceMode: THandle;
  DevMode: PDeviceMode;
begin
  {to get a current printer settings}
  FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
  {lock a printer device}
  DevMode := GlobalLock(DeviceMode);

  {set a paper size as A4-Transverse}
  if ((DevMode^.dmFields and DM_PAPERSIZE) = DM_PAPERSIZE) then
  begin
    DevMode^.dmFields := DevMode^.dmFields or DM_PAPERSIZE;
    DevMode^.dmPaperSize := DMPAPER_A4_TRANSVERSE;
  end;

  {set a paper source as Tractor bin}
  if ((DevMode^.dmFields and DM_DEFAULTSOURCE) = DM_DEFAULTSOURCE) then
  begin
    DevMode^.dmFields := DevMode^.dmFields or DM_DEFAULTSOURCE;
    DevMode^.dmDefaultSource := DMBIN_TRACTOR;
  end;

  {set a Landscape orientation}
  if ((DevMode^.dmFields and DM_ORIENTATION) = DM_ORIENTATION) then
  begin
    DevMode^.dmFields := DevMode^.dmFields or DM_ORIENTATION;
    DevMode^.dmOrientation := DMORIENT_LANDSCAPE;
  end;

  {set a printer settings}
  FPrinter.SetPrinter(FDevice, FDriver, FPort, DeviceMode);

  {unlock a device}
  GlobalUnlock(DeviceMode);
end;

If you need to change the paper size to custom size for example, 100mm x 100mm, you must assign the custom width and height to dmPaperWidth and dmPaperLength and include the DM_PAPERWIDTH/DM_PAPERLENGTH flags to dmFields property:

DevMode^.dmPaperWidth := PaperSizeWidth;
DevMode^.dmPaperLength := PaperSizeHeight;
DevMode^.dmFields := DevMode^.dmFields or DM_PAPERWIDTH or DM_PAPERLENGTH;

Copy one table from Access database in to another Access database

Problem/Question/Abstract:

How to copy one table from Access database in to another Access database

Answer:

If I am not wrong you have an Access db with multiple tables and you want to copy one of these tables into another Access db. For this case i would do the next:

Create database TrasportDB.mdb - use ADOX.
Copy table from source table into TransportDB.mdb with Select * Into [TransportTable] in "FullPath\TransportDB.mdb" From SourceTable.
Deliver TransportDB.mdb on destination computer.
Copy table from TransportTable into DestTable with Select * Into [DestTable] From [TransportTable] in "FullPath\TransportDB.mdb".

FullPath is the path to TransportDB.mdb and is different on source and dest computers.

This way you will use native access methods that should be more reliable and faster than using ADO methods. If you need to perform more complete tasks you should use replication from Microsoft Jet and Replication objects (import this typelib).

Determine if a COM object is registered

Problem/Question/Abstract:

At startup I need to determine if a COM server has been registered. If not, I will call RegisterComServer. Now I am calling RegisterComServer every time the application starts, which I do not think is a good idea. Is there a proper way to test for it being registered?

Answer:

You can try several methods:

a) Use CLSIDFromProgID method:

{ ... }
var
  strOLE: string;
begin
  strOLE = "YourCOMServer.Application"; {your ProgID}
  if (CLSIDFromProgID(PWideChar(WideString(strOLE), ClassID) = S_OK) then
    begin
      { ... }
    end;
end;

b) Check the registry:

{ ... }
const
  cKEY = '\SOFTWARE\Classes\CLSID\%s\InprocServer32';
var
  sKey: string;
  sComServer: string;
  exists: boolean;
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    sKey := format(cKEY, [GuidToString(ClassID)]);
    if Reg.OpenKey(sKey, False) then
    begin
      sComServer := Reg.ReadString('');
      if FileExists(sComServer) then
      begin
        { ... }
      end;
    end;
  finally
    Reg.free;
  end;
end;

How to get a range of text from a TRichEdit without setting a selection

Problem/Question/Abstract:

How to get a range of text from a TRichEdit without setting a selection

Answer:

Sometimes while using RichEdit you need to get just a part of the text from that control, without setting a selection and using the SelText property. The code below shows the way to do that :

{overrides wrong TTextRange definition in RichEdit.pas}
TTextRange = record
  chrg: TCharRange;
  lpstrText: PAnsiChar;
end;

function REGetTextRange(RichEdit: TRichEdit; BeginPos, MaxLength: Integer): string;
{RichEdit: RichEdit control
BeginPos: absolute  index of first char
MaxLength: maximum chars to retrieve}
var
  TextRange: TTextRange;
begin
  if MaxLength > 0 then
  begin
    SetLength(Result, MaxLength);
    with TextRange do
    begin
      chrg.cpMin := BeginPos;
      chrg.cpMax := BeginPos + MaxLength;
      lpstrText := PChar(Result);
    end;
    SetLength(Result, SendMessage(RichEdit.Handle, EM_GETTEXTRANGE, 0,
      longint(@TextRange)));
  end
  else
    Result := '';
end;

This function can be used to extract a word under the current mouse pointer position:

function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
{ function returns absolute character position for given cursor coordinates}
var
  P: TPoint;
begin
  P := Point(X, Y);
  Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, longint(@P));
end;

function REExtractWordFromPos(RichEdit: TRichEdit; X, Y: Integer): string;
{ X, Y: point coordinates in rich edit control }
{returns word under current cursor position}
var
  BegPos, EndPos: Integer;
begin
  BegPos := RECharIndexByPos(RichEdit, X, Y);
  if (BegPos < 0) or
    (SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
    WB_CLASSIFY, BegPos) and (WBF_BREAKLINE or WBF_ISWHITE) < > 0) then
  begin
    result := '';
    exit;
  end;
  if SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
    WB_CLASSIFY, BegPos - 1) and (WBF_BREAKLINE or WBF_ISWHITE) = 0 then
    BegPos := SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
      WB_MOVEWORDLEFT, BegPos);
  EndPos := SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
    WB_MOVEWORDRIGHT, BegPos);
  Result := TrimRight(REGetTextRange(RichEdit, BegPos, EndPos - BegPos));
end;

Check if OLE object is installed

Problem/Question/Abstract:

How can I check if OLE object is installed?

Answer:

Sometimes in development if you use OLE automation of some obejct, your application will not work because application is not installed on client computer. For example, you use MS excel automation but MS Excel is not  installed.

You can easy check if OLE object is installed and correctly registered using CLSIDFromProgID function (for MS Excel as example only):

var
  ClassID: TCLSID;
  strOLEObject: string;
begin
  strOLEObject := 'Excel.Application';
  if (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) = S_OK) then
  begin

  end
  else
  begin

  end
end;

In same manner you can check any other required OLE object.

Find the contrasting colour (2)

Problem/Question/Abstract:

I have x items, and I want to assign a color for each, but I want the colors to be as different as possible. I think the best would be to distribute x points with the greatest distance possible in an RGB cube. I have no idea how to implement that, or is there some other solution?

Answer:

You can use the invers color:

InversColor := ColorToRGB(AColor) xor $FFFFFF;

I you need a maximal contrast, the result is black or white, dependent of the brightness:

function MaximumContrastColor(Value: TColor): TColor;
var
  R, G, B: Integer;
  Min, Max: Integer;
begin
  Value := ColorToRGB(Value);
  R := GetRValue(Value);
  G := GetGValue(Value);
  B := GetBValue(Value);
  Min := R;
  if Min > G then
    Min := G;
  if Min > B then
    Min := B;
  Max := R;
  if Max < G then
    Max := G;
  if Max < B then
    Max := B;
  if Min + Max > 255 then
    Result := clBlack
  else
    Result := clWhite;
end;

How to save a complete directory

Problem/Question/Abstract:

Is there an API function which gives all the subdirectories and all the files of one particular directory (in order to save a whole directory for example )?

Answer:

You can copy a whole directory with one instruction using the ShFileOperation API function:


procedure TForm1.Button2Click(Sender: TObject);
var
  OpStruc: TSHFileOpStruct;
  frombuf, tobuf: array[0..128] of Char;
begin
  FillChar(frombuf, Sizeof(frombuf), 0);
  FillChar(tobuf, Sizeof(tobuf), 0);
  StrPCopy(frombuf, 'd:\brief\*.*');
  StrPCopy(tobuf, 'd:\temp\brief');
  with OpStruc do
  begin
    Wnd := Handle;
    wFunc := FO_COPY;
    pFrom := @frombuf;
    pTo := @tobuf;
    fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
    fAnyOperationsAborted := False;
    hNameMappings := nil;
    lpszProgressTitle := nil;
  end;
  ShFileOperation(OpStruc);
end;


If you need a list of all files and subdirs you have to do a recursive scan using FindFirst/ FindNext.

Custom message identifier: WM_APP +? or WM_USER +?

Problem/Question/Abstract:

I'm declaring a custom message identifier. Do I start from WM_APP or WM_USER?

Answer:

If you use a message internally in a custom control you typically base the message ID on WM_USER. If you use a custom message with a control derived from a standard windows or third-party control you are better off using WM_APP as the base, unless you definitely know from the documentation of the parent control what the highest message number it uses is (many controls use messages > WM_USER).

So it mainly depends in what context you intend to use the message. If only a TForm descendent will ever handle it you can base it on WM_USER since a form only handles messages < WM_USER or >= CM_BASE.

Extracting And Validating Email Addresses

Problem/Question/Abstract:

This code example introduces a new way to validate Email Addresses with domain name (TLD) validation !!

Answer:

Code #1

function IsEMail(EMail: string): Boolean;
var
  s: string;
  ETpos: Integer;
begin
  ETpos := pos('@', EMail);
  if ETpos > 1 then
  begin
    s := copy(EMail, ETpos + 1, Length(EMail));
    if (pos('.', s) > 1) and (pos('.', s) < length(s)) then
      Result := true
    else
      Result := false;
  end
  else
    Result := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if isemail(Edit1.Text) then
  begin
    ShowMessage('eMail-Adresse!');
  end;
end;


Code #2

MaxDomains = 174;

DomainList: array[0..MaxDomains] of string[3] = (
  'AD', 'AE', 'AG', 'AI', 'AM', 'AR', 'AS', 'AT', 'AU', 'AW', 'AZ', 'BA', 'BE', 'BF',
  'BG', 'BH', 'BM', 'BN', 'BO', 'BR', 'BS', 'BW', 'BY', 'BZ', 'CA', 'CC', 'CH', 'CI',
  'CK', 'CL', 'CN', 'CO', 'COM', 'CR', 'CU', 'CY', 'CZ', 'DE', 'DK', 'DM', 'DO', 'DZ',
  'EC', 'EDU', 'EE', 'EG', 'ES', 'ET', 'FI', 'FJ', 'FK', 'FM', 'FO', 'FR', 'GB', 'GE',
  'GF', 'GH', 'GI', 'GL', 'GOV', 'GR', 'GT', 'GU', 'GW', 'GY', 'HK', 'HN', 'HR', 'HU',
  'ID', 'IE', 'IL', 'IN', 'INT', 'IO', 'IR', 'IS', 'IT', 'JM', 'JO', 'JP', 'KE', 'KG',
  'KH', 'KI', 'KM', 'KR', 'KW', 'KY', 'KZ', 'LB', 'LI', 'LK', 'LT', 'LU', 'LV', 'MA',
  'MC', 'MD', 'MIL', 'MK', 'MN', 'MO', 'MR', 'MT', 'MU', 'MV', 'MX', 'MY', 'MZ', 'NA',
  'NC', 'NE', 'NET', 'NF', 'NG', 'NI', 'NL', 'NO', 'NP', 'NU', 'NZ', 'OM', 'ORG',
  'PA', 'PE', 'PF', 'PG', 'PH', 'PK', 'PL', 'PR', 'PT', 'PY', 'QA', 'RO', 'RU', 'SA',
        'SE', 'SG', 'SI', 'SK', 'SL', 'SM', 'SN', 'ST', 'SU', 'SV', 'SZ', 'TC', 'TF', 'TG',
  'TH', 'TM', 'TO',  'TR', 'TT', 'TW', 'TZ', 'UA', 'UG', 'UK', 'US', 'UY', 'UZ', 'VA',
  'VE', 'VI', 'VN',  'YE', 'YU', 'ZA', 'ZM', 'ZW');

function InDomainList(email: string): boolean;

var
  tel: word;
  st: string;

begin
  tel := length(email);
  while (tel > 0) and (email[tel] <> '.') do
    dec(tel);
  st := copy(email, tel + 1, length(email));

  for tel := 0 to maxdomains do
    if st = DomainList[tel] then
    begin
      InDomainList := true;
      inc(hittable[tel]);
      exit;
    end;
  InDomainList := false;
end;


Have Fun !!!

How to make a TMemo show the chosen line

Problem/Question/Abstract:

How can I have a memo show a chosen line? In fact my program does some work and puts information in a memo, I would like the last line of the memo to be always visible. I tried MyMemo.ScrollBy(0, MaxInt), but that does not work.

Answer:

with Memo1 do
begin
  SelLength := 0;
  SelStart := Perform(EM_LINEINDEX, LineNo, 0);
  Perform(EM_SCROLLCARET, 0, 0);
end;

LineNo hold the line number you want to scroll to.

How to validate input in a TEdit

Problem/Question/Abstract:

How to validate input in a TEdit

Answer:

Assuming you're using regular TEdit components, during OnExit, you will see irregular behavior from controls if you attempt to change focus at that time. The solution is to post a message to your form in the TEdit's OnExit event handler. This user-defined posted message will indicate that the coast is clear to begin validating input. Since posted messages are placed at the end of the message queue, this gives Windows the opportunity to complete the focus change before you attempt to change the focus back to another control:

unit Unit5;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Mask;

const
  {User-defined message}
  um_ValidateInput = wm_User + 100;

type
  TForm5 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Button1: TButton;
    procedure EditExit(Sender: TObject);
    procedure EditEnter(Sender: TObject);
  private
    Refocusing: TObject;
    {User-defined message handler}
    procedure ValidateInput(var M: TMessage); message um_ValidateInput;
  end;

var
  Form5: TForm5;

implementation

{$R *.DFM}

procedure TForm5.ValidateInput(var M: TMessage);
var
  E: TEdit;
begin
  {The following line is my validation. I want to make sure the first character is a lower case
  alpha character. Note the typecast of lParam to a TEdit}
  E := TEdit(M.lParam);
  if not (E.Text[1] in ['a'..'z']) then
  begin
    Refocusing := E; {Avoid a loop}
    ShowMessage('Bad input'); {Yell at the user}
    TEdit(E).SetFocus; {Set focus back}
  end;
end;

procedure TForm5.EditExit(Sender: TObject);
begin
  {Post a message to myself which indicates it's time to validate the input. Pass the TEdit
  instance (Self) as the message lParam}
  if Refocusing = nil then
    PostMessage(Handle, um_ValidateInput, 0, longint(Sender));
end;

procedure TForm5.EditEnter(Sender: TObject);
begin
  if Refocusing = Sender then
    Refocusing := nil;
end;

end.

Editor keyboard shortcut - column selection

Problem/Question/Abstract:

Editor Keyboard Shortcut - Column Selection

Answer:

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

Column selection keyboard shorcuts are defined as follows:

Shortcut
Description
Alt+Shift+Left Arrow
Selects the column to the left of the cursor
Alt+Shift+Right Arrow
Selects the column to the right of the cursor
Alt+Shift+Up Arrow
Moves the cursor up one line and selects the column from the left of the starting cursor position
Alt+Shift+Down Arrow
Moves the cursor down one line and selects the column from the left of the starting cursor position
Alt+Shift+Page Up
Moves the cursor up one screen and selects the column from the left of the starting cursor position
Alt+Shift+Page Down
Moves the cursor down one line and selects the column from the right of the starting cursor position
Alt+Shift+End
Selects the column from the cursor position to the end of the current line
Alt+Shift+Home
Selects the column from the cursor position to the start of the current line


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

Set the background colour of a word in a TRichEdit

Problem/Question/Abstract:

I have a RichEdit control where my code outputs text into, formatting certain words or phrases with different font colors. This works fine, but I would also like to set the background of certain words to be different colors. MSWord allows this with the Highlight option, and I can copy and paste highlighted text from MSWord into my RichEdit control, so I have to assume that this is possible to do in code as well. Can anyone provide me with sample code or guidance on doing this in code?

Answer:

The version 1 richedit control introduced with Win95 did not have this ability and this version is what the TRichedit class was wrapped around. So it does not give you access to all the new abilities in the version 3 control you find on WinMe, 2K, and XP. You could delve into the murky depth of the API and send appropriate messages to the control:

uses
  richedit;

procedure TForm1.Button1Click(Sender: TObject);
var
  cf: TCharFormat2;
begin
  fillchar(cf, sizeof(cf), 0);
  cf.cbSize := sizeof(cf);
  cf.dwMask := CFM_BACKCOLOR;
  cf.crBackColor := ColorToRGB(clYellow);
  richedit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, lparam(@cf));
end;

Storing Font information in the registry - with one key only

Problem/Question/Abstract:

Storing Font information in the registry - with one key only

Answer:

If you came in a situation to store font information in the registry, because you want to allow your users to customize your application, then you may have faced the fact that the TRegistry class does not provide WriteFont(), ReadFont() functions.

The first thought would be to make a sub key for each item in your application and write the font information as a combination of Strings and Integers.

WriteString(key, Font.FaceName);
WriteInteger(key, Font.Size);

Obviously not the most elegant code. Here's an elegant solution - store the font information as binary data! The Windows API provides a TLogFont structure that describes a font. It includes all properties that the Borland TFont class provides except the font's color. We'll use an extended logical description that contains the Windows (T)LogFont and the color. For information on TLogFont open help file Win32.hlp and search for LogFont.

// saves/ reads a font to/ from the registry
//
// read like this:
//   fEditorFont := TFont.Create;
//   fEditorFont.name := 'Courier New';
//   fEditorFont.Size := 10;
//   LoadFont(sKey, 'Editor', fEditorFont);
//
// and save like this:
//   SaveFont(sKey, 'Editor', fEditorFont);
unit sFontStorage;
interface
uses
  Graphics, Windows, Registry;

procedure LoadFont(const sKey, sItemID: string; var aFont: TFont);
procedure SaveFont(const sKey, sItemID: string; aFont: TFont);

implementation

type
  TFontDescription = packed record
    Color: TColor;
    LogFont: TLogFont;
  end;

procedure LoadFont(const sKey, sItemID: string; var aFont: TFont);
var
  iSiz: Integer;
  FontDesc: TFontDescription;
begin
  with TRegistry.Create do
  begin
    if OpenKey(sKey, False) then
    try
      iSiz := SizeOf(FontDesc);
      if ReadBinaryData(sItemID, FontDesc, iSiz) = SizeOf(FontDesc) then
      begin
        aFont.Handle := CreateFontIndirect(FontDesc.LogFont);
      end;
      aFont.Color := FontDesc.Color;
    finally
      CloseKey;
    end;
    // free the registry object
    Free;
  end;
end;

procedure SaveFont(const sKey, sItemID: string; aFont: TFont);
var
  iSiz: Integer;
  FontDesc: TFontDescription;
begin
  with TRegistry.Create do
  begin
    iSiz := SizeOf(FontDesc.LogFont);
    if GetObject(aFont.Handle, iSiz, @FontDesc.LogFont) > 0 then
    begin
      f OpenKey(sKey, True) then
        try
        FontDesc.Color := aFont.Color;
        WriteBinaryData(sItemID, FontDesc, SizeOf(FontDesc));
      finally
        CloseKey;
      end;
    end;
    // free the registry object
    Free;
  end;
end;

end.

Default Array Properties

Problem/Question/Abstract:

By using default array properties, you can abbreviate your calls by using the syntax Class[I] as opposed to Class.Items[I].

Answer:

Delphi supports abbreviated calls to the default class array property.  This can be used in any delphi class that uses defaults such as TStringList.

For Example:

use MyStringList[Index] in place of MyStringList.Strings[Index]

This is somewhat useful for cleaning up the code, especially if you are accessing the property in question often.

To add this feature to your own classes, simply add the "default" directive (storage specifier) after the array (indexed) property you want to use as the default.

For Example:

type
  TMyGraphicList = class
  public
    property Names[Index: Integer]: string read GetName write SetName;
    property Objects[Index: Integer]: TObject read GetObj write SetObj;
    property Images[Index: Integer]: TImage read Get write set; default;
    {...}
  end;

By adding the "default" directive after the Images property we have designated the Images array property as the default.  

Access can now be abbreviated such as this:

for I := 0 to MyGraphicList.Count - 1 do
begin
  AName := MyGraphicList.Names[I];
  AObject := MyGraphicList.Objects[I];
  AImage := MyGraphicList[I]; // instead of MyGraphicList.Images[I]
end;

NOTE: There can be only one default array property for each class.  Entering a second would generate a compiler error.

IMPORTANT: "Array" properties are different than "attribute" properties, and the default directive takes on a different meaning for each.  When used on an attribute property, the default directive (storage specifier) releates to how Delphi saves the values of published properties in form (.DFM) files.

Shaking a form

Problem/Question/Abstract:

Shaking a Form

Answer:

Solve 1:

Just put a button in your form and insert these commands in the OnClick Event !

procedure TForm1.Button1Click(Sender: TObject);
var
  N: Integer; //Counter
  TL, TT: Integer; //Backup for LEFT and TOP of teh FORM
begin
  TL := Left; //Backups Left of the Form
  TT := Top; //Backups Top  of the Form
  //*********************************************************************
  for N := 1 to 40 do
  begin //Counter Time
    Left := (TL - 10) + (Random(20)); {Shake Range in Horizontal Driection}
    Top := (TT - 10) + (Random(20)); {Shake Range in Vertical  Driection}
  end;
  //*********************************************************************
  Left := TL; //Restores Left of the Form
  Top := TT; //Restores Top  of the Form
end;


Solve 2:

var
  iipt: Integer;

procedure Tform1.FormCreate;
begin
  iipt := Form1.Left;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  so: Integer;
begin
  so := 0;
  repeat
    if Form1.Left = iipt - 10 then
    begin
      so := so + 1;
      repeat
        Form1.Left := Form1.Left + 1;
      until Form1.Left = iipt
    end
    else
      repeat
        Form1.Left := Form1.Left - 1;
      until Form1.Left = iipt - 10;
  until so = 2;
end;


Solve 3:

for i := 2 to 7 do
begin
  for j := 0 to 10 do
  begin
    if int(int((i - 1) / 2) / 2) * 2 = int((i - 1) / 2) then
      frmMain.Left := frmMain.Left + 1
    else
      frmMain.Left := frmMain.Left - 1;
  end;
end;

Dynamic Arrays in Delphi

Problem/Question/Abstract:

Dynamic Arrays in Delphi

Answer:

Borland Delphi 4 features a number of Object Pascal language enhancements, as usual. In this article, I'll address a very handy language enhancement takes the ideas of Open Parameters and Long Strings back to the basics of arrays in the so-called Dynamic Arrays.

In Delphi 4, in addition to declaring static arrays such as

X: array[1..42] of string;

we can now also declare dynamic arrays. Dynamic arrays specify type information (the number of dimensions and the type of the elements) but not the number of elements. Thus

X: array of string;

M: array of array of Integer;

declares two dynamic arrays. X is a one-dimensional arrays of Strings, while M is a two dimensional array of Integers (like a Matrix).

Dynamic arrays do not have a fixed size or length. Instead, memory for a dynamic array is (re-)allocated when we assign a value to the array or pass it to the SetLength procedure. Hence, the above declarations for X and M do not allocate memory. To create the array in memory, call SetLength. For example, given the declarations above,

SetLength(X, 42);

allocates an array of 42 Strings, indexed 0 to 41. Dynamic arrays are always integer-indexed, always starting from 0.

After calling SetLength, the previous content of the dynamic array - if any - is copied along (so data never gets lost if we constantly increase or decrease the length of the array). Using the above knowledge, we can write a small - and very inefficient, of course - program to read a number of lines from a textfile, and only allocate the exact number of strings that are needed.

{$R+}
{$APPTYPE CONSOLE}
var
  X: array of string;
  i: Integer;
begin
  while not eof do
  begin
    SetLength(X, Length(X) + 1); // very inefficient...
    readln(X[High(X)])
  end;
  for i := 0 to High(X) do
    writeln(X[i])
end.

Dynamic-array variables are implicitly pointers and are managed by the same reference-counting technique used for Long Strings. To deallocate a dynamic array, assign nil to a variable that references the array or pass the variable to Finalize; either of these methods disposes of the array, provided there are no other references to it.

{$R+}
program Delphi4;
{$APPTYPE CONSOLE}
uses
  Dialogs;
var
  X, Y: array of string;
  i: Integer;
begin
  SetLength(X, 7);
  Y := X;
  X[3] := 'Dynamic Arrays in Delphi 4';
  SetLength(X, 42);
  Y := X;
  SetLength(Y, 4);
  ShowMessage(Y[3]);
  X := nil;
  Finalize(Y);
end.




Warning: we should not apply the dereference operator (^) to a dynamic-array variable or pass it to the New or Dispose procedure.

If X and Y are variables of the same dynamic-array type, X:=Y allocates X to the length of Y and points X to the same array as Y. Unlike strings, arrays are not automatically copied (i.e. made unique) before they are written to, but they keep pointed to the same - shared - memory area! For example, after this code executes

var
  X, Y: array of string;
begin
  SetLength(X, 1);
  X[0] := 'Hello, world';
  Y := X;
  Y[0] := 'Answer';
end;

the value of X[0] is 'Answer'.

Unlike Long Strings, that get "split" when we change one of them (to get a unique copy), dynamic arrays keep pointed to the same area. A bit unexpected, perhaps, but at least we don't get delayed performance hits (like with Long Strings)...
Of course, since dynamic array contents are copied when we call SetLength, that's also all it takes (a call to SetLength) to create a unique copy of a dynamic array.

Assigning to a dynamic-array index (for example, X[42] := 'Answer') does not reallocate the array (we need to call SetLength to do that). Out-of-range indexes are not reported at compile time, but will raise an exception at run-time (with $R+ compiler directive).

When dynamic-array variables are compared, their references are compared, not their array values. Thus, after execution of the code

var
  X, Y: array of string;
begin
  SetLength(X, 1);
  SetLength(Y, 1);
  X[0] := 'Hello, world!';
  Y[0] := 'Hello, world!';
end;

X = Y returns False but X[0] = Y[0] returns True.

To truncate a dynamic array, pass it to the Copy function and assign the result back to the array variable. For example, if X is a dynamic array, X := Copy(X, 0, 2) truncates all but the first 2 elements of X.

Once a dynamic array has been allocated, we can pass it to the standard functions Length, High, and Low. Length returns the number of elements in the array, High returns the array's highest possible index (Length - 1), and Low always returns 0. For a zero-length array, High indeed returns -1, so in that case High(X) < Low(X).

To instantiate the multi-dimensional array M (see declaration on top of this paper), we need to call SetLength with two integer arguments:

SetLength(M, 10, 5);

allocates an 10-by-5 array, and M[9,4] denotes an element of that array.

We can also create multidimensional dynamic arrays that are not rectangular. The first step is to call SetLength, passing it parameters for the first n dimensions of the array. For example,

var
  M: array of array of Integer;
begin
  SetLength(M, 10);

allocates ten rows for M but no columns. Then, we can allocate the columns one at a time (giving them different lengths); for example

SetLength(M[2], 42);

makes the third column of M 42 integers long. At this point (even if the other columns haven't been allocated) we can assign values to the third column for example, M[2][41] := 7.

Deleting or renaming open files

Problem/Question/Abstract:

Sometimes I need to handle files that are used by windows before they are loaded in the boot process, like a DLL or a VxD for example. How do I do that?

Answer:

Windows NT have a function called MoveFileEx that deletes files at reboot if used with the MOVEFILE_DELAY_UNTIL_REBOOT flag. Unfortunately, Windows 9x doesn't support this flag. So what do we do?

Every time you reboot, windows look for a file called WININIT.INI in the Windows directory. This file can contains Delete / Rename / Copy directives that will be excuted before anything is loaded (or almost). You can place commands in the [Rename] section using the syntax DESTINATION=SOURCE. If Destination is NUL, then the file will be deleted. Filenames and paths must use SHORT FILENAMES (because this file is processed before long filenames support is even loaded).

Please note that contrary to the example found in win32.hlp, you cannot use WritePrivateProfileString() or TIniFile to access this file because there might be duplicates values. If there is already one NUL value, TIniFile would overwrite it instead of creating a new one. So you better use TStringList instead.

Here are some example entries:

[rename]
NUL=C:\TEMP.TXT
NUL=C:\TEMP2.TXT
C:\NEW_DIR\EXISTING.TXT=C:\EXISTING.TXT
C:\NEW_DIR\NEWNAME.TXT=C:\OLDNAME.TXT
C:\EXISTING.TXT=C:\TEMP\NEWFILE.TXT

Below is the function DeleteLater that will just add NUL=Filename to wininit.ini, create the file if it doesn't exist, and also create the section if needed.

procedure DeleteLater(Filename: string);
var
  Wininit: string;
  Buffer: array[0..MAX_PATH] of char;
  I, J: integer;
  Ini: TStringList;
begin
  FillChar(Buffer, SizeOf(Buffer), 0);
  GetWindowsDirectory(Buffer, SizeOf(Buffer));
  Wininit := IncludeTrailingBackslash(Buffer) + 'Wininit.ini';

  Ini := TStringList.Create;
  try
    if FileExists(Wininit) then
      Ini.LoadFromFile(Wininit);
    for I := 0 to Ini.Count - 1 do
      Ini[I] := Uppercase(Ini[I]);

    J := Ini.IndexOf('[RENAME]');
    if J = -1 then
    begin
      Ini.Add('[Rename]');
      J := 0;
    end;
    FillChar(Buffer, SizeOf(Buffer), 0);
    GetShortPathName(PChar(Filename), Buffer, SizeOf(Buffer));
    Ini.Insert(J + 1, 'NUL=' + Buffer);
    Ini.SaveToFile(Wininit);
  finally
    Ini.Free;
  end;
end;

Redefining TCP/IP Client...

Problem/Question/Abstract:

How do we create a TCP/IP Server/Client in Delphi?

Answer:

This article is a redefined version of my previous article "Making an application a TCP/IP Client(with sample code)". May be this is of late but hope it&#8217;s helpful. In this article, I tried to explain/discuss, in general, how to create TCP-IP clients and servers with Delphi.

What I tried to demonstrate in that sample code?

I tried to demonstrate a simple TCP-IP client application that connects to a specific port on a TCP-IP server and exchanges data. I did not say anything about the server except that my application was talking to a TCP-IP server written in Java. But all you need to talk to a server is the address/host and port/service details. And to talk to the server, you have to make sure that the server is running. That&#8217;s it. You don&#8217;t need to worry about how that server is implemented unless you want to develop both the server and client by yourself.  In this article, let me give you a brief overview of how to write a TCP-IP server in Delphi.

This is what I have done in that source code:

Established a connection to the server when the application starts.
Used a SendXml procedure to send data to the server.
Used OnClientSocketRead event to read back the data from the server.
Used OnClientSocketError event to catch the errors

You will see a Boolean flag called fWaiting in both the SendXml and OnClientSocketRead procedures. In my application, I will send some data to the server and wait for the server to respond back. I&#8217;ll essentially wait for the OnClientSocketRead event to happen hoping that the server responds ASAP. That is the reason I used the Boolean flag fWaiting.

Where to start to have an idea of what TCP-IP client and TCP-IP server?

For people who want to try, I would suggest them to have a look at the demo project called Chat.dpr in both Delphi 5 and 6.  Following are the paths where you can find the demo project:

Delphi 5:
C:\ Program Files\Borland\Delphi5\Demos\Internet\Chat\chat.dpr

Delphi 6:
C:\ Program Files\Borland\Delphi6\Demos\Internet\Chat\chat.dpr

What is basically a TCP-IP client?

It&#8217;s an application that connects to a specific port on a TCP-IP server and exchanges data either as a stream or text.

What do you need to create one with Delphi?

All you need is a TClientSocket component available on the internet palette and set the following properties:

Address: You can enter the IP address of the TCP-IP server that this client connects to.

Host: Instead of Address you can enter an alias name for the IP address here in the Host property. It&#8217;s obvious to set either the Address or Host property. But what happens if you set both? Host property takes precedence over the Address property.
Setting the Host property would be better compared to the Address property since even if you change the TCP-IP server to some other machine or change the IP address to something else, as long as you keep the alias name same, you are fine; you don&#8217;t need to worry about changing it on the TCP-IP client. (Even though it&#8217;s a slight overhead of resolving the host name to its corresponding IP address, it&#8217;s worth having it)

Port: It&#8217;s a valid integer port number where the TCP-IP server listens. (and responds.) It&#8217;s always a fixed number assigned by the server. To this port number, the client will connect to and send and receive data.

Service: As Host and Address properties are linked together in one way, Port and Service properties are also linked. In general, Service is something the TCP-IP server can provide to its clients like http, ftp. These standard services have been assigned a specific port number on the server. (e.g. http &#8211; port 80). How that works? On the server, there is a services file which maps services to their respective ports. So like that, you can have your own service description that maps to a specific port number on the server. In that case, the client can connect to the service using the Service property and interact.

ClientType: This property determines whether the interaction between the server and client occurs synchronously or asynchronously.

ctNonBlocking &#8211; The default. This indicates that the interaction between the server and client occurs asynchronously. i.e. the client can send data to the server and wait for the OnRead data to occur whenever the data is sent back from the server.
ctBlocking &#8211; This is used for interaction to occur synchronously between the server and the client.

When to make the client code thread-safe?

If more than one request is sent to the server from a client application at a time, then the client code should be thread-safe. Otherwise, the request-response may collide.


TCP-IP Server
TCP-IP Client 1
Code should be
Multiple requests at a time
Thread-safe
Code should be thread-safe
ServerType = stThreadBlocking
ClientType = ctBlocking

          
Fig. 1. A TCP-IP server receiving multiple requests from a single client at a time.

TCP-IP Server
TCP-IP Client 1
Code should be
Single request at a time
Thread-safe
Code need not be thread-safe
ServerType = stThreadBlocking
ClientType = ctNonBlocking

TCP-IP Client 2
Single request at a time
Code need not be thread-safe
ClientType = ctNonBlocking


Fig. 2. A TCP-IP Server receiving multiple requests from various clients at a time.

When to make the server code thread-safe?

If more than one request is received either from a client application or different client applications at a time, then the server code should be thread-safe. This is applicable to all TCP-IP servers written in other languages also.

Hope I&#8217;m making myself clear on the thread-safe part.

Which is the best place to put the TClientSocket component in an application?

You can put the component either in a Form or DataModule. If you just have a single form in the client application that talks to a server, then it&#8217;s okay to put the TClientSocket component in that form. But if you have many forms in the client application, then it&#8217;s better to put the component in a DataModule and use that DataModule wherever needed. I used a DataModule in my client application since I had many forms each talking to the server at a different point of time.

How do you establish a connection to the server?

Set all those properties mentioned above and then set either the Active property to true or call the Open method. Once you establish a connection, you can send the data using either the SendText or SendStream method. And you can use the OnClientSocketRead event to read the data back from the server.

What is a TCP-IP server?

It&#8217;s an application that listens at a particular port and responds to clients. It could be any standard servers like http, ftp or a custom server made for your specific application.

What do you need to create on with Delphi?

As with the client, you need a TServerSocket component with the following properties set:

Port: You can assign any valid integer value. To this port, the client can connect to and interact with the server.

Service: As I told previously, you can have a service name associated with a port number.

Whenever we say server, it should be able to serve more than one client obviously; then only it makes sense to have a server. Right? Now the next question is how these clients are talking to the server: more than one client at a time or one client at a time. It leads to the following property setting that determines whether the clients talk to the server synchronously or asynchronously.

How do we handle more than one client requests at a time?

The answer is to spawn a new thread for each client request. This can be achieved by setting the ServerType property to stThreadBlocking. Does spawning and destroying a thread for each client request an overhead? Yes. Obviously. But if our application design requires it, then there is no other way; you have to have that overhead. Can we reduce that overhead of creating and destroying threads? Yes. We can. How? Cache those threads. Right.
The ThreadCacheSize property serves that purpose. The default value is 10 but this value depends on your client application needs. You should be very careful in setting this value. If you set it to a maximum value, you will end up in memory problems. If you set it to a very low value, the client will have a wait time for each request. So you have to determine a best value based on the client statistics.

If the client requests are coming one at a time, then you can set the ServerType property to stNonBlocking.

How do we read data back from the client?

As with ClientSocket, we have OnClientRead event to read data from the client among other events.

That&#8217;s all. Hope you can write yourself both a client and server with this information.

Virtual Methods and Polymorphism Part 1

Problem/Question/Abstract:

Virtual Methods, Inside Out

Answer:

Polymorphism is perhaps the cornerstone of object-oriented programming (OOP). Without it, OOP would have only encapsulation and inheritance - data buckets and hierarchical families of data buckets - but no way to uniformly manipulate related objects.

Polymorphism is the key to leveraging your programming investments to enable a relatively small amount of code to drive a wide variety of behaviors, without requiring carnal knowledge of the implementation details of those behaviors. However, before you can extend existing Delphi components, or design new, extensible component classes, you must have a firm understanding of how polymorphism works and the opportunities it provides.

True to its name, polymorphism allows objects to have "many forms" in Delphi, and a component writer typically uses a mix of all these forms to implement a new component. In this article, we'll closely review the implementation and use of one of Delphi's polymorphism providers, the virtual method, and some of its more peculiar sand traps and exotic applications, e.g. its part in making .EXEs smaller. (Dynamic methods, message methods, and class reference types are Delphi's other polymorphism providers, but are outside the scope of this article.)

This article assumes you are familiar with Delphi class declaration syntax and general OOP principles. If you're a bit rusty with these concepts, you should first refer to the Delphi Language Reference. Also note that in this article, "virtual" denotes the general term that applies to all forms of virtual methods (i.e. methods declared with virtual, dynamic, or override), and "virtual" denotes the specific term that refers only to methods declared with the virtual directive. For example, most polymorphism concepts and issues apply to all virtual methods, but there are a few noteworthy items that apply only to virtual methods.  

Review: Syntax of Virtual Methods

Here's a review of the two kinds of virtual methods and four language directives used to declare them:

Virtual methods come in two flavors: virtual and dynamic. The only difference between them is their internal implementations; that is, they use different techniques to achieve the same results.
Calls to virtual methods are dispatched more quickly than calls to dynamic methods.
Seldom-overridden virtual methods require much more storage space for their compiler-generated tables than dynamic methods.
The keywords, virtual and dynamic, always introduce a new method name into a class' name space.
The override directive redefines the implementation of an existing virtual method (virtual or dynamic) that a class inherits from an ancestor.
The override method uses the same dispatch mechanism (virtual or dynamic) as the inherited virtual method it replaces.
The abstract directive indicates that no method body is associated with that virtual method declaration. Abstract declarations are useful for defining a purely conceptual interface, which is in turn useful for maintaining absolute separation between the user of a class and its implementation.
The abstract directive can only be used in the declaration of new virtual (virtual or dynamic) methods; you can't make an implemented method abstract after the fact.
A class type that contains one or more abstract methods is an abstract class.
A class type that contains nothing but abstract methods (no static methods, no virtual methods, no data fields) is called an abstract interface (or, in C++ circles, a pure virtual interface).

Polymorphism in Action

What do virtual methods do? In general, they allow a method call to be directed, at run time, to the appropriate piece of code, appropriate for the type of the object instance used to make the call. For this to be interesting, you must have more than one class type, and the class types must be related by inheritance from a common ancestor.

Figure 1 shows three classes we'll use to explore the execution characteristics of polymorphism: a simple base class named TBaseGadget that defines a static method named NotVirtual and a virtual method, ThisIsVirtual; and two descendant classes, TKitchenGadget and TOfficeGadget, that override the ThisIsVirtual method they inherit from TBaseGadget. TOfficeGadget also introduces a new static method named NotVirtual and a new virtual method named NewMethod.

type
  TBaseGadget = class
    procedure NotVirtual(X: Integer);
    procedure ThisIsVirtual(Y: Integer); virtual;
  end;

  TKitchenGadget = class(TBaseGadget)
    procedure ThisIsVirtual(Y: Integer); override;
  end;

  TOfficeGadget = class(TBaseGadget);

function NewMethod: Longint; virtual;
  procedure NotVirtual(X, Y, Z: Integer);
    procedure ThisIsVirtual(Y: Integer); override;
end;
Figure 1: Three classes to explore polymorphism.

Identical names in different classes aren't related. Declaring a static method in a descendant that happens to have the same name as a static method in an ancestor is not a true override. Other than same-name similarity, no relationship exists between static methods declared in a descendant and static methods declared in an ancestor class. Your brain makes an association, but the compiler does not. For instance, TBaseGadget has a NotVirtual method, and TOfficeGadget has a disparate method, also named NotVirtual.

If we start with a variable P of type TBaseGadget, we can assign to it an instance of a TBaseGadget; or an instance of one of its descendants, such as a TKitchenGadget or TOfficeGadget. Recall that Delphi object instance variables are pointers to the instance data allocated from the global heap, and that pointers of a class type are type compatible with all descendants of that type. We can then call methods using the instance variable P:

var
  P: TBaseGadget;
begin
  P := TBaseGadget.Create;
  P.NotVirtual(10); { Call TBaseGadget.NotVirtual }
  P.ThisIsVirtual(5); { Call TBaseGadget.ThisIsVirtual }
  P.Free;
end;

(In the interest of brevity, I'll fold the execution traces into comments in the source code. You can step through the sample code to verify the execution trace.)

If P refers to an instance of TKitchenGadget, the execution trace would resemble the code in Figure 2. Nothing remarkable here; we have one call to a static method going to the version defined in the ancestor type, and one call to a virtual method going to the version of the method associated with the object instance type.

var
  P: TBaseGadget;
begin
  P := TKitchenGadget.Create;
  P.NotVirtual(10); { Call TBaseGadget.NotVirtual }
  P.ThisIsVirtual(5); { Call TKitchenGadget.ThisIsVirtual }
  P.Free;
end;
Figure 2: Execution with an instance of TKitchenGadget.

You may deduce that the inherited static method, NotVirtual, is called because TKitchenGadget doesn't override it. This observation is correct, but the explanation is flawed, as Figure 3 shows. If P refers to an instance of TOfficeGadget, you may be a little puzzled by the result.

var
  P: TBaseGadget;
begin
  P := TOfficeGadget.Create;
  P.NotVirtual(10); { Call TBaseGadget.NotVirtual }
  { The compiler will not allow the following two lines:
   P.NotVirtual(1,2,3);   "Too many parameters"
   P.NewMethod;           "Method identifier expected" }
  P.ThisIsVirtual(5); { Call TOfficeGadget.ThisIsVirtual }
  P.Free;
end;
Figure 3: Execution with an instance of TOfficeGadget.

Static method calls are resolved by variable type. Although TOfficeGadget has its own NotVirtual method, and P refers to an instance of TOfficeGadget, why does TBaseGadget.NotVirtual get called instead? This occurs because static (non-virtual) method calls are resolved at compile time according to the type of the variable used to make the call. For static methods, what the variable refers to is immaterial. In this case, P's type is TBaseGadget, meaning the NotVirtual method associated with P's declared type is TBaseGadget.NotVirtual.

Notice that NewMethod defined in TOfficeGadget is out of reach of a TBaseGadget variable. P can only access fields and methods defined in its TBaseGadget object type.

New names obscure inherited names. Let's say P is declared as a variable of type TOfficeGadget. The following method call would be allowed:

P.NotVirtual(1, 2, 3)

However, this method call:

P.NotVirtual(1)

would not be allowed, because TOfficeGadget.NotVirtual requires three parameters.

TOfficeGadget.NotVirtual obscures the TBaseGadget.NotVirtual method name in all instances and descendants of TOfficeGadget. The inherited method is still a part of TOfficeGadget (proven by the code in Figure 3); you just can't get to it directly from TOfficeGadget and descendant types.

To get past this, you must typecast the instance variable:

TBaseGadget(P).NotVirtual(1)

If P were declared as a TOfficeGadget variable, P.NewMethod would also be allowed, because the compiler can "see" NewMethod in a TOfficeGadget variable.

Descendant >= ancestor. An instance of a descendant type could be greater than its ancestor type in both services and data. However, the descendant-type instance can never be less than what its ancestors define. This makes it possible for you to use a variable of an ancestral type (e.g. TBaseGadget) to refer to an instance of a descendant type without loss of information.

Inheritance is a one-way street. With a variable of a particular class type, you can access any public symbol (field, property, or method) defined in any of that class' ancestors. You can assign an instance of a descendant class into that variable, but cannot access any new fields or methods defined by the descendant class. The fields of the descendant class are certainly in the instance data that the variable refers to, yet the compiler has no way of knowing that run-time situation at compile time.

There are two ways around this "nearsightedness" of ancestral class types:

Typecasting - The programmer assumes a lot and forces the compiler to treat the variable as a descendant type.
Virtual methods - The magic of virtual will call the method appropriate to the type of the associated instance, determined at run time.

Ancestors set the standard. Why do we care about the nearsightedness of ancestral classes? Why not simply use the matching variable type when you create or manipulate an object instance? Sometimes this is the simplest thing to do. However, this "simplest" solution falls apart when you begin talking about manipulating multiple classes that do almost the same things.

Ancestral class types set the minimum interface standard through which we can access a set of related objects. Polymorphism is the use of virtual methods to make one verb (method name) produce one of many possible actions depending on the context (the instance). To have multiple, possible actions, you must have multiple class types (e.g. TKitchenGadget and TOfficeGadget) each potentially defining a different implementation of a particular method.

To be able to make one call that could cover those multiple class types, the method must be defined in a class from which all the multiple class types descend - in an ancestral class such as TBaseGadget. The ancestral class, then, is the least common denominator for behavior across a set of related classes.

For polymorphism to work, all the actions common to the group of classes need to at least be named in a common ancestor. If every descendant is required to override the ancestor's method, the ancestral method doesn't need to do anything at all; it can be declared abstract.

If there is a behavior that is common to most of the classes in the group, the ancestor class can pick up that default behavior and leave the descendants to override the defaults only when necessary. This consolidates code higher in the class hierarchy, for greater code reuse and smaller total code size. However, providing default behaviors in an ancestor class can also complicate the design issues of creating flexible, extensible classes, since what is done by ancestors usually cannot be entirely undone.

Polymorphism lets ancestors reach into descendants. Another aspect of polymorphism doesn't appear to involve instance pointer types at all - at least not explicitly.

Consider the code fragment in Figure 4. The TBaseGadget.NotVirtual method contains an unqualified call to ThisIsVirtual. When P refers to an instance of TKitchenGadget, P.NotVirtual will call TBaseGadget.NotVirtual. Nothing new, so far. However, when that code calls ThisIsVirtual, it will execute TKitchenGadget.ThisIsVirtual. Surprise! Even within the depths of TBaseGadget, a non-virtual method, a virtual method call is directed to the appropriate code.

procedure TBaseGadget.NotVirtual;
begin
  ThisIsVirtual(17);
end;

var
  P: TBaseGadget;

begin
  P := TKitchenGadget.Create;
  P.NotVirtual(10); { Call TBaseGadget.NotVirtual }
  P.Free;
end.
Figure 4: Polymorphism allows ancestors to call into descendants.

How can this be? The resolution of virtual method calls depends on the object instance associated with the call. A pointer to the object instance is secretly passed into all method calls, surfacing inside methods as the Self identifier. Inside TBaseGadget.NotVirtual, a call to ThisIsVirtual is actually a call to Self. ThisIsVirtual. Self, in this context, operates like a variable of type TBaseGadget that refers to an instance of type TKitchenGadget. Thus, when the instance type is TKitchenGadget, the virtual method call resolves, at run time, to TKitchenGadget.ThisIsVirtual.

How is this useful? An ancestral method - virtual or not - can call a sequence of virtual methods. The descendants can determine the specific behavior of one or more of those virtual methods. The ancestor determines the sequence in which the methods are called, plus miscellaneous setup and cleanup code. The ancestor, however, does not completely determine the final behavior of the descendants. The descendants inherit the sequence logic from the ancestor, and can override one or more of the steps in that sequence. But, the descendants don't have to reproduce the entire sequence logic. This is one of the ways OOP promotes code reuse.

Fully-qualified method calls are reduced to static calls. As a footnote, consider what happens if TBaseGadget.NotVirtual contains a qualified call to TBaseGadget.ThisIsVirtual:

procedure TBaseGadget.NotVirtual;
begin
  TBaseGadget.ThisIsVirtual(17);
end;

Although ThisIsVirtual is a virtual method, a fully-qualified method call will compile down to a regular static method call. You've specified that you want only the TBaseGadget.ThisIsVirtual method called, so the compiler does exactly what you tell it to do. Dispatching this as a virtual method call may call some other version of that method, which would violate your explicit instructions. Except in special circumstances, you don't want this in your code because it defeats the whole purpose of making ThisIsVirtual virtual.

The Virtual Method Table

A Virtual Method Table (VMT) is an array of pointers to all the virtual methods defined in a class and all the virtual methods the class inherits from its ancestors. A VMT is created by the compiler for every class type, because all classes descend from TObject and TObject has a virtual destructor named Destroy. In Delphi, VMTs are stored in the program's code space. Only one VMT exists per class type; multiple instances of the same class type refer to the same VMT. At run time, the VMT is a read-only lookup table.

Structure of the VMT. The first four bytes of data in an object instance are a pointer to that class type's VMT. The VMT pointer points to the first entry in the VMT's list of four-byte pointers to the entry points of the class' virtual methods. Since methods can never be deleted in descendant classes, the location of a virtual method in the VMT is the same throughout all descendant classes. Thus, the compiler can view a virtual method simply as a unique entry in the class' VMT. As we'll see shortly, this is exactly how virtual method calls are dispatched. Thinking of virtual methods as indexes into an array of code pointers will also help us visualize how method name conflicts are resolved by the compiler.

The VMT does not contain information indicating how many virtual methods are stored in it or where the VMT ends. The VMT is constructed by the compiler and accessed by compiler-generated code, so it doesn't need to make notes to itself about size or number of entries. (This does, however, make it difficult for BASM code to call virtual methods.)

Optimization note. A descendant of a class with virtual methods gets a new copy of the ancestor's VMT table. The descendant can then add new virtual methods or override inherited virtual methods without affecting the ancestor's VMT. For example, if the ancestor has a 12-entry VMT, the descendant has at least a 12-entry VMT. Every descendant class type of that ancestor, and all descendants of those descendants, will have at least 12 entries in their individual VMTs.

All these VMTs occupy memory. For most programs, this won't be a problem, but extraordinarily large class types with thousands of virtual methods and/or thousands of descendants could consume quite a bit of memory, both in RAM and .EXE file size; dynamic methods are much more space efficient, but incur a slight execution speed penalty.

Now let's examine the mechanics behind the magic of virtual method calls.

Inside a virtual method call. When the compiler is compiling your source code and encounters a call to a virtual method identifier, it generates a special sequence of machine instructions that will unravel the appropriate call destination at run time. The following machine code snippets assume compiler optimizations are enabled, and stack frames are disabled:

// Machine code for statement P.SomeVirtualMethod;

{ Move instance data address (P^) into EAX }
MOV EAX, [EBP + 4]
{ Move instance's VMT address into ECX }
MOV ECX, [EAX]
{ Call address stored at VMT index 2 }
CALL[ECX + 08]

The VMT pointer is always stored at offset 0 (zero) in the instance data. In this example, the method being called is the third virtual method of a class, including inherited virtual methods. The first virtual method is at offset 0, the second at offset 4, and the third at offset 8.

Conclusion

That's it - all the magic of virtual methods and polymorphism boils down to this: the indicator of which virtual method to invoke on the instance data is stored in the instance data itself.

In Part II, we'll conclude our series with a discussion of abstract interfaces and how virtual methods can defeat and enhance "smart linking." See you then.

Parse a wave file

Problem/Question/Abstract:

Access each chunk within a wave file is a tricky business but sometime you need to access the actual samples/data to get what you want...so how can that be done?

Answer:

A WAV file is binary file in the RIFF format, RIFF format enables the user to haev multiple information in the same file which can either be used or not.

The information is stored in chunks, each chunk have its type (4 chars) and side (dword) so it can be skipped if you are not interested in the data or to be read from the file.

You can download the demo software that shows wave file in a signal display graph with functions as: paning, zoom, multiple audio channels and more from

http://www.com-n-sense.com/ftproot/SignalDisplay.zip

(the zip file contains the wavefileparser component and signaldisplay component).

The following code parses WAV files into accessable chunks:

{*==============================================================================
          Copyright (C) 2002, All rights reserved, Com-N-Sense Ltd
================================================================================
File: WaveFileParser.pas
Author: Liran Shahar, Com-N-Sense Ltd
Updated: 24/03/2002
Purpose: Parsing wave file into chunks
================================================================================
  24/03/2002, Liran Shahar
  - Initial release.
==============================================================================*}
unit WaveFileParser;

interface

uses
  Sysutils, Classes;

type
  TChunkType = array[1..4] of char;

  PChunk = ^TChunk;
  TChunk = packed record
    cType: TChunkType;
    dwSize: cardinal;
    pData: pointer;
  end;

  TcnsWaveFileParser = class(TPersistent)
  private
    FFilename: AnsiString;
    Chunks: TList;
  protected
    procedure SetFilename(AFilename: AnsiString); virtual;
    function GetChunksCount: integer; virtual;
    function GetChunk(Index: integer): PChunk; virtual;
    procedure ProcessFile; virtual;
    procedure ClearChunks; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function GetChunkByType(ChunkType: TChunkType): PChunk; virtual;
    property Filename: AnsiString read FFilename write SetFilename;
    property ChunksCount: integer read GetChunksCount;
    property Chunk[Index: integer]: PChunk read GetChunk;
  end;

implementation

const
  RIFF_SIGNATURE = 'RIFF';
  WAVE_SIGNATURE = 'WAVE';

type
  TRIFFHeader = packed record
    cSignature: TChunkType;
    dwSize: cardinal;
    cType: TChunkType;
  end;

constructor TcnsWaveFileParser.Create;
begin
  inherited Create;
  FFilename := '';
  Chunks := TList.Create;
end;

destructor TcnsWaveFileParser.Destroy;
begin
  ClearChunks;
  inherited Destroy;
end;

procedure TcnsWaveFileParser.SetFilename(AFilename: AnsiString);
begin
  if FFilename <> AFilename then
  begin
    ClearChunks;
    FFilename := AFilename;
    ProcessFile;
  end; // if
end;

function TcnsWaveFileParser.GetChunksCount: integer;
begin
  Result := Chunks.Count;
end;

function TcnsWaveFileParser.GetChunk(Index: integer): PChunk;
begin
  Result := nil;
  if (Index > -1) and (Index < Chunks.Count) then
    Result := Chunks[Index];
end;

procedure TcnsWaveFileParser.ProcessFile;
var
  WaveFile: TFileStream;
  Header: TRIFFHeader;
  Chunk: PChunk;
begin
  try
    WaveFile := TFileStream.Create(FFilename, fmOpenRead + fmShareDenyWrite);
    WaveFile.Read(Header, sizeof(Header));
    if (AnsiCompareText(Header.cSignature, RIFF_SIGNATURE) = 0) and
      (AnsiCompareText(Header.cType, WAVE_SIGNATURE) = 0) then
    begin
      while WaveFile.Position < WaveFile.Size do
      begin
        Chunk := AllocMem(sizeof(TChunk));
        with Chunk^ do
        begin
          WaveFile.Read(cType, sizeof(cType));
          WaveFile.Read(dwSize, sizeof(dwSize));
          pData := AllocMem(dwSize);
          WaveFile.Read(pData^, dwSize);
        end; // with
        Chunks.Add(Chunk);
      end; // while
    end; // if
  finally
    FreeAndNil(WaveFile);
  end;
end;

procedure TcnsWaveFileParser.ClearChunks;
var
  Chunk: PChunk;
begin
  while Chunks.Count > 0 do
  begin
    Chunk := Chunks[0];
    Chunks.Delete(0);
    if assigned(Chunk^.pData) then
      FreeMem(Chunk^.pData);
    dispose(Chunk);
  end; // while
end;

function TcnsWaveFileParser.GetChunkByType(ChunkType: TChunkType): PChunk;
var
  iIndex: integer;
begin
  Result := nil;
  iIndex := 0;
  while iIndex < Chunks.Count do
    if AnsiCompareText(PChunk(Chunks[iIndex])^.cType, ChunkType) = 0 then
    begin
      Result := Chunks[iIndex];
      break;
    end
    else
      iIndex := iIndex + 1;
end;

end.


Component Download: http://www.com-n-sense.com/ftproot/SignalDisplay.zip

Avoid direct input into a TDBGrid when there is a lookup list available (2)

Problem/Question/Abstract:

Could somebody please tell me how I can make a column in a dbgrid only accept a value from a picklist without the user being able to type something into the cell manually?

Answer:

Override the Grid's protected KeyPress, like this:

procedure TPresPLRMask_DbGrid.KeyPress(var Key: Char);
var
  col: TColumn;
begin
  inherited;
  if SelectedIndex < 0 then
    exit;
  col := Columns[SelectedIndex];
  if (col.PickList.Count > 0) and (col.ButtonStyle = cbsAuto) then
  begin
    {no keys allowed except the TAB key (arrow keys down fire KeyPress,
    they don't need to be handled here)}
    if (Key <> #9) then
    begin
      Key := #0;
      Abort;
    end;
  end;
end;