[Back to DATATYPE SWAG index]  [Back to Main SWAG index]  [Original]

{
From: rgdawson@aol.com (RGDawson)

>Does anyone know how I can make a procedure accept as many or as little
>parameters as a I want. For example, in writeln, you can use no parameters
>or a lot of parameters with the same call. Could I do the same thing for
>something that writes to a com port without assigning a file to the port?

The best way is to write a device driver.  Here is an example of a device
driver that lets write and writeln send strings to a global PChar
variable.  This is very handy for formatting and concatenating strings and
number variables of all types.  To use simply include this unit and do
something like

  WriteLn(PD, 'X=', X:5:2, 'The lazy fox...', S);

The global variable PDStr now contains the formatted output of writeln.
}

UNIT PCharDev;

{$K+}

INTERFACE

uses
  WinTypes, WinProcs, WinDOS, Strings;

const
  MaxPDStrSize = 255;
var
  PDStr: array[0..MaxPDStrSize] of Char;
  PD: Text;

procedure AssignPCharDev(var F: Text);

IMPLEMENTATION

procedure WriteBuffer(Buffer: PChar; Count: Word);
var
  i: integer;
begin
  i := 0;
  while (Count > 0) AND (i <= MaxPDStrSize - 1) do begin
    if Buffer^ in [#9, #32..#255] then begin
      PDStr[i] := Buffer^;
      Inc(i);
    end;
    {$IFOPT R+}
    if i > (MaxPDStrSize - 1) then
      MessageBox(0, 'Max string size exceeded in PChar Device.  String Truncated.',
                    'PCharDev Error', mb_OK + mb_IconExclamation);
    {$ENDIF}
    Inc(Buffer);
    Dec(Count);
  end;
  PDStr[i] := #0;
end;

function PCharDevClose(var F: TTextRec): integer; far;
begin
  PCharDevClose := 0;
end;

function PCharDevOut(var F: TTextRec): integer; far;
begin
  if F.BufPos <> 0 then begin
    WriteBuffer(PChar(F.BufPtr), F.BufPos);
    F.BufPos := 0;
  end;
  PCharDevOut := 0;
end;

function PCharDevOpen(var F: TTextRec): integer; far;
begin
  {.$IFOPT R+}
  if F.Mode <> fmOutput then
    MessageBox(0, 'PCharDev mode must be fmOutput only.','Error',mb_OK);
  {.$ENDIF}
  F.Mode := fmOutput;
  F.InOutFunc := @PCharDevOut;
  F.FlushFunc := @PCharDevOut;
  F.CloseFunc := @PCharDevClose;
  PCharDevOpen := 0;
end;

procedure AssignPCharDev(var F: Text);
begin
  with TTextRec(F) do begin
    handle := $FFFF;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @PCharDevOpen;
    Name[0] := #0;
  end;
end;

BEGIN
  AssignPCharDev(PD);
  Rewrite(PD);
END.

[Back to DATATYPE SWAG index]  [Back to Main SWAG index]  [Original]