Miscellaneous Part 3

Avoiding using stale pointers

"David S. Becker" <dsb@plaza.ds.adp.com>

I've written a very simple unit, and devised some simple methods, to help prevent the usage of stale pointers. My biggest recommendation is to add an 'initialization' section to ALL UNITS WHICH CONTAIN POINTER OR OBJECT VARIABLES and set all the pointers (object variables are really pointers too) to nil. This will ensure that the pointers are all nilified before they are ever used. Then, simply reset pointers to nil after freeing them. My unit contains a Nilify() function for setting pointers to nil, as well as special versions of Free, Dispose, and FreeMem (called NilXXX) which test for nil before freeing memory, and resets the pointer to nil once it has been freed. I've also included a special version of Assigned(), called IsNil(), which takes a const parameter instead of a var parameter, which means you can use it on properties, etc.

This unit, of course, does nothing to the VCL, so you can still get stale pointers back from the VCL... But strict adherence to the functions in this unit should help ensure YOU don't make a mistake. The only condition on its use/distribution is that you forward any changes or suggestions you might have to me. Use it and program in good health! 

unit Pointers;

{
  Author: David S. Becker (dsb@plaza.ds.adp.com)
  Date: 1/27/97
  Copyright: None
  Distribution Rights:  Free, unlimited use, provided you forward any and all
    changes or suggestions you have to me.

  This unit was created to aid in the managment of pointers and objects.  Since
  the compiler does not initialize pointers or objects to nil, and does not set
  them to nil when freed, it is possible to accidentally reference stale
  pointers.  For this reason, I recommend you add an 'initialization' section to
  all units and call Nilify() on all pointers/objects in that unit.  This
  will ensure that all pointers/objects start off as nil.  Furthermore, you
  should use the NilFree (for objects), NilDispose (for pointers created with
  New), and NilFreeMem (for pointers created with GetMem) instead of their
  standard counterparts.  These procedures are safe to call on nil pointer/
  objects, as they check for nil before performing any action.  After freeing
  the memory allocated to the pointer/object, they reset the pointer to nil.  If
  you are strict in your use of these procedures, your risk of accessing stale
  pointer is greatly reduced.  (Of course, you can still get stale pointers from
  the VCL as it obviously doesn't use these functions.)
}

{==============================================================================}
interface

{------------------------------------------------------------------------------}
{ Checks a pointer against nil }
{ NOTE: This function differs from Assigned() in that Assigned() requires a }
{ variable, whereas IsNil() does not.                                       }
function IsNil(const p: Pointer): Boolean;
{ Sets a pointer to nil }
procedure Nilify(var p);
{ Frees a non-nil object, then sets it to nil }
procedure NilFree(o: TObject);
{ Frees a non-nil pointer created by New, then sets it to nil }
procedure NilDispose(var p: Pointer);
{ Frees a non-nil pointer, then sets it to nil }
procedure NilFreeMem(var p: Pointer; size: Word);

{==============================================================================}
implementation

{------------------------------------------------------------------------------}
function IsNil(const p: Pointer): Boolean;
begin
  Result := (p = nil);
end;

{------------------------------------------------------------------------------}
procedure Nilify(var p);
begin
  Pointer(p) := nil;
end;

{------------------------------------------------------------------------------}
procedure NilFree(o: TObject);
begin
  if not IsNil(o) then begin
    o.Free;
    Nilify(o);
  end;
end;

{------------------------------------------------------------------------------}
procedure NilDispose(var p: Pointer);
begin
  if not IsNil(p) then begin
    Dispose(p);
    Nilify(p);
  end;
end;

{------------------------------------------------------------------------------}
procedure NilFreeMem(var p: Pointer; size: Word);
begin
  if not IsNil(p) then begin
    FreeMem(p,size);
    Nilify(p);
  end;
end;

end.

Multi Language Applications

Eddie Shipman <eshipman@inetport.com>

For anyone needing to do multi-language apps and don't want to write a lot of code checking what language the program is running, see below. I compiled a stringtable resource into my exe and this is how I used it for multi-language dialogs.

Instead of using the Runtime directives to check what language, I used a runtime variable to set the index for the messages into the stringtable and then load the messages from there depending upon the language. You could also create different stringtables for each language and then compiling them in by using the compile directives.

Here is some example code, give it a try: 

unit French1;

interface

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

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

var
  Form1: TForm1;
  StringIndex : Integer;
implementation

{$R *.DFM}

{$R MULTLANG.RES}

{ Here is the way the resource file for this project looks:
 1, "Attention"
 2, "No Condition definition selected!"
 3, "Always"
 4, "Cannot delete the 'always' condition."
 5, "Confirmation"
 6, "Delete the condition?"
 7, "Yes"
 8, "No"
 9, "Attention"
 10, "Pas de condition Selectionn�e"
 11, "Toulours"
 12, "Ne peux effacer la condition 'Toujours'"
 13, "Confirmation"
 14, "Effacer cette condition?"
 15, "&Oui"
 16, "&Non"
}

procedure TForm1.FormActivate(Sender: TObject);
var
  {inifile : TIniFile; Optional}
  ProgramLanguage : String;
begin
  { Here, I just set it to French }
   ProgramLanguage := 'fra';
  { You can optionally get the language from Win.INI:}
  {inifile := TInifile.Create('WIN.INI');
   ProgramLanguage := inifile.ReadString('intl', 'sLanguage', 'enu');
   inifile.Free;}
  { Forgive me if I leave out any languages, Tthese are th only ones
    in my setup.inf for my copy of Windows.

   dan = Danish
   nld = Dutch
   enu = English (American)
   eng = English (International)
   fin = Finnish
   fra = French
   frc = French Canadian
   deu = German
   isl = Icelandic
   ita = Italian
   nor = Norwegian
   ptg = Portuguese
   esp = Spanish
   esn = Spanish (Modern)
   sve = Swedish

}
   if ProgramLanguage = 'enu' then
   begin
      StringIndex := 0;
   end
   else
      if ProgramLanguage = 'fra' then
      begin
         StringIndex := 8;
      end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
   i,j,k : integer;
   DialogForm : tform;
begin
   Application.NormalizeTopMosts;
   {no Condition Selected!}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex+2),mtWarning,[mbOK]);
   {Attention}
   DialogForm.caption := LoadStr(StringIndex + 1);
   DialogForm.showmodal;
   Application.RestoreTopMosts;
   {Cannot Delete the 'always' condition}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex+4),mtWarning,[mbOK]);
   {Always}
   DialogForm.caption := LoadStr(StringIndex + 3);
   DialogForm.showmodal;
   Application.RestoreTopMosts;
   {Delete the condition?}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex+6),mtInformation, [mbYes, mbNo]);
   {confirmation}
   DialogForm.caption := LoadStr(StringIndex + 5);
   for j := 0 to DialogForm.controlCount-1 do
   begin
      if DialogForm.controls[j] is tButton then
         with tButton(DialogForm.controls[j]) do
         begin
            if caption = '&Yes' then caption := LoadStr(StringIndex+7);
            if caption = '&No' then caption := LoadStr(StringIndex+8);
          end;
    end;
   DialogForm.showmodal;
end;

end.

Associated Executable

Michael Ax <ax@HREF.COM>

unit UcShell;

{ Author: Michael Ax   http://www.axsystems.com/
  Copyright (c) 1995..1997 Michael Ax.  All Rights Reserved.
  This source code is part of TPack from HREF Tools Corp.
  Obtain purchasing and additional information by sending an email to
  software@href.com (any subject, any message)...
  or visit us on the web at http://www.href.com/software/
}

interface

uses Classes, SysUtils, Windows, ShellApi, Forms;

{---------------------------------------------------------------}

function WinExecutableName(const AssociatedFile:string):String;

procedure WinShellOpen(const AssociatedFile:string);
procedure WinShellPrint(const AssociatedFile:string);
procedure WinShellExecute(const Operation,AssociatedFile:string);

{---------------------------------------------------------------}

implementation

Const
  cStrBufSize= 80;

{---------------------------------------------------------------}


function WinExecutableName(const AssociatedFile:string):String;
//HINSTANCE FindExecutable(
//    LPCTSTR lpFile,   // pointer to string for filename
//    LPCTSTR lpDirectory,      // pointer to string for default directory
//    LPTSTR lpResult   // pointer to buffer for string for executable file
on return
//   );
begin
  SetLength(result,cStrBufSize); //ucshell
  FindExecutable(pchar(AssociatedFile),'',pchar(result));
  SetLength(result,strlen(pchar(result)));
end;

//

procedure WinShellExecute(const Operation,AssociatedFile:string);
var
  a1:string;
begin
  a1:=Operation;
  if a1='' then
    a1:='open';
  ShellExecute(
    application.handle			//hWnd: HWND
    ,pchar(a1)				//Operation: PChar
    ,pchar(AssociatedFile)		//FileName: PChar
    ,''						//Parameters: PChar
    ,''						//Directory: PChar
    ,SW_SHOWNORMAL		//ShowCmd: Integer
    );
//  GetLastErrorString(0);		//ucdialog
end;

procedure WinShellPrint(const AssociatedFile:string);
begin
  WinShellExecute('print',AssociatedFile);
end;

procedure WinShellOpen(const AssociatedFile:string);
begin
  WinShellExecute('open',AssociatedFile);
end;

{-----------------------------------------------------------------}
end.

MAPI and MS Exchange

Keith Anderson <keith@PURESCIENCE.COM>

Use the following to login: 
  MapiLogon(application.handle,nil,nil,mapi_use_default,0,@mapihandle)
Then use the following to send your message: 
  MapiSendMail(mapihandle, 0,MapiMessage,0, 0);
Make sure the SUBJECT, RECIP and NOTTEXT fields are complete in the MapiMessage structure or the message won't be sent.

Also make sure Exchange is running using the GetWindowHandle API function, and if it's not, use ShellExecute (or whatever) to launch it first.

Constucting Object Variables

From: richardp@calweb.com (Coyote)

In the past few days there have been more than a few questions on this group indicating a lack of understanding about object instantiation. I'm guessing that these have been beginners, but in one case the questioner was taking a class on Delphi. I'd hope that an instructor would at least *try* to explain the subject.

Anyway, for all of you having pointer errors, exceptions, and GPFs, take a quick look at this.

When you declare a variable of some classtype such as... 

var 
   MyVar: TMyClass;
....all you've asked the compiler to do is set up enough space to hold a pointer to an instance of your class on the heap. You haven't allocated memory for that class, just allocated memory for the pointer. I'd like to say that the compiler always presets this pointer to $FFFFFFFF, but that may not be accurate. Anyway, suffice it to say that it does *not* point to a valid memory location, and does *not* contain your class' information.

Delphi handles all the messiness of memory allocation and disposal for you, but you do have to do a little bit of work. When you use one of Delphi's classes, or derive one of your own, you must instantiate the object. What that means is this: you must allocate the memory for it and set the pointer to that block of memory. In some languages that would be ugly; in Delphi it's as easy as...

MyVar := TMyClass.Create;
It's that easy because the Create constructor method of the class TMyClass is a class method--it operates on the class, not on the individual object. When you call the constructor, Delphi allocates memory, and returns a pointer value. Take a look: doesn't it look like a function call? Well, if you weren't sure what it was returning, now you know. The call to TMyClass.Create returns a pointer to an object of type TMyClass.

In the end, all you really need to remember is this...

  1. Declare an object variable of some type.
  2. Instantiate that object with a call to the class constructor method.
  3. Use the object as normal.
  4. Free the object.
==begin useless code block

procedure Example;
var
   MyObj: TMyClass;   // a class that you've created
   MyList: TList;     // a native class
begin
   MyObj := TMyClass.Create;  
// now MyObj is instantiated--it means something
   MyList := TList.Create;    
// same for MyList
....
do some stuff here
....
   MyList.Free;
// MyList's resources are cleared from the heap
   MyObj.Free;
// same for MyObj
end;

Example of variable number of parameters

From: hallvard@falcon.no (Hallvard Vassbotn)

program VarPar;

{ A simple program to demonstrate use of type-safe variable number of
  parameters in Delphi.

  Written Mars 1995 by Hallvard Vassbotn
  hallvard@falcon.no
}

uses WinCrt, SysUtils;

{ These are predefined in System:
const
    vtInteger  = 0;
    vtBoolean  = 1;
    vtChar     = 2;
    vtExtended = 3;
    vtString   = 4;
    vtPointer  = 5;
    vtPChar    = 6;
    vtObject   = 7;
    vtClass    = 8;

  type
    TVarRec = record
      case Integer of
        vtInteger:  (VInteger: Longint; VType: Byte);
        vtBoolean:  (VBoolean: Boolean);
        vtChar:     (VChar: Char);
        vtExtended: (VExtended: PExtended);
        vtString:   (VString: PString);
        vtPointer:  (VPointer: Pointer);
        vtPChar:    (VPChar: PChar);
        vtObject:   (VObject: TObject);
        vtClass:    (VClass: TClass);
    end;
}

const
  TypeNames : array [vtInteger..vtClass] of PChar  =
   ('Integer', 'Boolean', 'Char', 'Extended', 'String',
    'Pointer', 'PChar', 'Object', 'Class');

{
According to the on-line docs (search for TVarRec), array of const
parameters are treated like array of TVarRec by the compiler.
This example will work just as well if you change the declaration of
TestMultiPar to:

  procedure TestMultiPar(const Args: array of TVarRec);

This would make the implementation of the routine cleaner (no absolute
variable declaration), but the interface would be less understandable
to the user of the routine.

The compiler looks at the parameters and builds the array directly on the
stack. For each item in the array it also sets the VType field to one
of the pre-defined constants vtXXXX. The actual value is always sent as
four bytes of information. For the Boolean and Char types, only the first
byte contains useful information.

So, go ahead, now you can write all those neat routines with variable
number of parameters - and still keep the type safety!
}

function PtrToHex(P: pointer): string;
begin
  Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4);
end;

procedure TestMultiPar(const Args: array of const);
var
  ArgsTyped : array [0..$fff0 div sizeof(TVarRec)] of TVarRec absolute Args;
  i         : integer;
begin
  for i := Low(Args) to High(Args) do
    with ArgsTyped[i] do
    begin
      Write('Args[', i, '] : ', TypeNames[VType], ' = ');
      case VType of
        vtInteger:  writeln(VInteger);
        vtBoolean:  writeln(VBoolean);
        vtChar:     writeln(VChar);
        vtExtended: writeln(VExtended^:0:4);
        vtString:   writeln(VString^);
        vtPointer:  writeln(PtrToHex(VPointer));
        vtPChar:    writeln(VPChar);
        vtObject:   writeln(PtrToHex(Pointer(VObject)));
        vtClass:    writeln(PtrToHex(Pointer(VClass)));
      end;
    end;
end;

var
  MyObj : TObject;
begin
  Writeln('Test of type-safe variable number of parameters in Delphi:');
  MyObj := TObject.Create;
  TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Hello, world!', true, 'X',
                @ShortDayNames, TObject, MyObj]);
  MyObj.Free;

  { To verify that the type-safety is used in the supplied formatting routines,
    try this: }
  writeln(Format('%d', ['hi']));
  { The supplied parameter is not of the type expected. The '%d' format string
    signals that the parameter should be an integer value, but instead we
    send a string. At run-time this will generate a exception, and if you
    have enabled IDE-trapping of exceptions, Delphi will show you the offending
    line. Using c-type sprintf funtions like this will result in undefined
    behaviour (read: system crash, GP or whatever) }
end.

My new TWrapGrid component: Allows word wrap in TStringGrid.

From: delarosa@ix.netcom.com (Luis de la Rosa)

I have finally created a custom component, TWrapGrid that allows you to use a TStringGrid, but also wrap the text in a cell. This is the beta version, so I encourage you to experiment with it, try it out, and send me comments on what you think of it. When you use it, remember to se the RowHeights (or DefaultRowHeight) large enough so that when it wraps, it shows up in the cell.

To install, copy the following text and paste it into a Unit. Save it under the name 'Wrapgrid.PAS'. Then follow the directions I put in the header of the component.

I'm also looking for feedback on this component, so please try it and tell me what you think. Here is the code! 

{  This is a custom component for Delphi.
   It is wraps text in a TStringGrid, thus the name TWrapGrid.
   It was created by Luis J. de la Rosa.
   E-mail: delarosa@ix.netcom.com
   Everyone is free to use it, distribute it, and enhance it.

   To use:  Go to the 'Options' - 'Install Components' menu selection in Delphi.
            Select 'Add'.
            Browse for this file, which will be named 'Wrapgrid.PAS'.
            Select 'OK'.
            You have now added this to the Samples part of your component
               palette.
            After that, you can use it just like a TStringGrid.

   Please send any questions or comments to delarosa@ix.netcom.com
   Enjoy!

   A few additional programming notes:
   I have overridden the Create and DrawCell methods.  Everything else should
   behave just like a TStringGrid.
   The Create sets the DefaultDrawing to False, so you don't need to.

   Also, I am using the pure block emulation style of programming, making my
   code easier to read.
}
   
unit Wrapgrid;

interface

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

type
  TWrapGrid = class(TStringGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
    { This DrawCell procedure wraps text in the grid cell }
    procedure DrawCell(ACol, ARow : Longint; ARect : TRect;
      AState : TGridDrawState); override;
  public
    { Public declarations }
    { The Create procedure is overriden to use the DrawCell procedure by
         default }
    constructor Create(AOwner : TComponent); override;
  published
    { Published declarations }
  end;

procedure Register;

implementation

constructor TWrapGrid.Create(AOwner : TComponent);
begin
   { Create a TStringGrid }
   inherited Create(AOwner);

   { Make the drawing use our DrawCell procedure by default }
   DefaultDrawing := FALSE;
end;

{ This DrawCell procedure wraps text in the grid cell }
procedure TWrapGrid.DrawCell(ACol, ARow : Longint; ARect : TRect;
   AState : TGridDrawState);
var
   Sentence,                  { What is left in the cell to output }
   CurWord : String;          { The word we are currently outputting }
   SpacePos,                  { The position of the first space }
   CurX,                      { The x position of the 'cursor' }
   CurY : Integer;            { The y position of the 'cursor' }
   EndOfSentence : Boolean;   { Whether or not we are done outputting the cell }
begin
   { Initialize the font to be the control's font }
   Canvas.Font := Font;

   with Canvas do begin
      { If this is a fixed cell, then use the fixed color }
      if gdFixed in AState then begin
         Pen.Color   := FixedColor;
         Brush.Color := FixedColor;
      end
      { else, use the normal color }
      else begin
         Pen.Color   := Color;
         Brush.Color := Color;
      end;

      { Prepaint cell in cell color }
      Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
   end;

   { Start the drawing in the upper left corner of the cell }
   CurX := ARect.Left;
   CurY := ARect.Top;

   { Here we get the contents of the cell }
   Sentence := Cells[ACol, ARow];

   { for each word in the cell }
   EndOfSentence := FALSE;
   while (not EndOfSentence) do begin
      { to get the next word, we search for a space }
      SpacePos := Pos(' ', Sentence);
      if SpacePos > 0 then begin
         { get the current word plus the space }
         CurWord := Copy(Sentence, 0, SpacePos);

         { get the rest of the sentence }
         Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
      end
      else begin
         { this is the last word in the sentence }
         EndOfSentence := TRUE;
         CurWord := Sentence;
      end;

      with Canvas do begin
         { if the text goes outside the boundary of the cell }
         if (TextWidth(CurWord) + CurX) > ARect.Right then begin
            { wrap to the next line }
            CurY := CurY + TextHeight(CurWord);
            CurX := ARect.Left;
         end;

         { write out the word }
         TextOut(CurX, CurY, CurWord);
         { increment the x position of the cursor }
         CurX := CurX + TextWidth(CurWord);
      end;
   end;
end;

procedure Register;
begin
   { You can change Samples to whichever part of the Component Palette you want
     to install this component to }
   RegisterComponents('Samples', [TWrapGrid]);
end;

end.

Resizing panels?

From: dionkk@ix.netcom.com (Dion Kurczek)

Here's the source code for a resizable panel. Give the panel an align property of alClient, throw some controls on it, and watch them resize at run time when you resize the form. There is some code that prohibits resizing during design time, but this can be taken out. This may not be perfect, because I threw it together in a few minutes, but it's worked for me so far.

unit Elastic;

interface

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

type
  TElasticPanel = class( TPanel )
  private
     FHorz, FVert: boolean;
     nOldWidth, nOldHeight: integer;
     bResized: boolean;
  protected
     procedure WMSize( var message: TWMSize ); message WM_SIZE;
  public
     nCount: integer;
     constructor Create( AOwner: TComponent ); override;
  published
     property ElasticHorizontal: boolean read FHorz write FHorz default 
TRUE;
     property ElasticVertical: boolean read FVert write FVert default 
TRUE;
  end;

procedure Register;

implementation

constructor TElasticPanel.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  FHorz := TRUE;
  FVert := TRUE;
  nOldWidth := Width;
  nOldHeight := Height;
  bResized := FALSE;
end;

procedure TElasticPanel.WMSize( var message: TWMSize );
var
  bResize: boolean;
  xRatio: real;
  i: integer;
  ctl: TWinControl;
begin
  Inc( nCount );
  if Align = alNone then
     bResize := TRUE
  else
     bResize := bResized;
  if not ( csDesigning in ComponentState ) and bResize then
     begin
        if FHorz then
           begin
              xRatio := Width / nOldWidth;
              for i := 0 to ControlCount - 1 do
                 begin
                    ctl := TWinControl( Controls[i] );
                    ctl.Left := Round( ctl.Left * xRatio );
                    ctl.Width := Round( ctl.Width * xRatio );
                 end;
           end;
        if FVert then
           begin
              xRatio := Height / nOldHeight;
              for i := 0 to ControlCount - 1 do
                 begin
                    ctl := TWinControl( Controls[i] );
                    ctl.Top := Round( ctl.Top * xRatio );
                    ctl.Height := Round( ctl.Height * xRatio );
                 end;
           end;
     end
  else
     begin
        nOldWidth := Width;
        nOldHeight := Height;
     end;
  bResized := TRUE;
  nOldWidth := Width;
  nOldHeight := Height;
end;

procedure Register;
begin
  RegisterComponents('Additional', [TElasticPanel]);
end;

end.
Please email me and tell me if you liked this page.

This page has been created with