fax.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

Unit Fax;

{$R-}

interface

uses Classes, Graphics, SysUtils, Windows, Dialogs, Forms;

type

{ Define Group 3 run codes. First array index is 0 for white and 1 for black. }

	TRunCode = record
		Code: Word;
		Bits: Byte;
	end;
    TErrorCode = record
        Code: Word;
        Msg: String;
    end;
	TTerminatingCodes = array[0..1,0..63] of TRunCode;
    TMakeupCodes = array[0..1,1..40] of TrunCode;

const
    { Following are terminating run codes for length < 64 }

	TerminatingCodes: TTerminatingCodes =
    (((Code:$3500;Bits: 8),(Code:$1C00;Bits: 6),(Code:$7000;Bits: 4),(Code:$8000;Bits: 4),
    (Code:$B000;Bits: 4),(Code:$C000;Bits: 4),(Code:$E000;Bits: 4),(Code:$F000;Bits: 4),
    (Code:$9800;Bits: 5),(Code:$A000;Bits: 5),(Code:$3800;Bits: 5),(Code:$4000;Bits: 5),
    (Code:$2000;Bits: 6),(Code:$0C00;Bits: 6),(Code:$D000;Bits: 6),(Code:$D400;Bits: 6),
    (Code:$A800;Bits: 6),(Code:$AC00;Bits: 6),(Code:$4E00;Bits: 7),(Code:$1800;Bits: 7),
    (Code:$1000;Bits: 7),(Code:$2E00;Bits: 7),(Code:$0600;Bits: 7),(Code:$0800;Bits: 7),
    (Code:$5000;Bits: 7),(Code:$5600;Bits: 7),(Code:$2600;Bits: 7),(Code:$4800;Bits: 7),
    (Code:$3000;Bits: 7),(Code:$0200;Bits: 8),(Code:$0300;Bits: 8),(Code:$1A00;Bits: 8),
    (Code:$1B00;Bits: 8),(Code:$1200;Bits: 8),(Code:$1300;Bits: 8),(Code:$1400;Bits: 8),
    (Code:$1500;Bits: 8),(Code:$1600;Bits: 8),(Code:$1700;Bits: 8),(Code:$2800;Bits: 8),
    (Code:$2900;Bits: 8),(Code:$2A00;Bits: 8),(Code:$2B00;Bits: 8),(Code:$2C00;Bits: 8),
    (Code:$2D00;Bits: 8),(Code:$0400;Bits: 8),(Code:$0500;Bits: 8),(Code:$0A00;Bits: 8),
    (Code:$0B00;Bits: 8),(Code:$5200;Bits: 8),(Code:$5300;Bits: 8),(Code:$5400;Bits: 8),
    (Code:$5500;Bits: 8),(Code:$2400;Bits: 8),(Code:$2500;Bits: 8),(Code:$5800;Bits: 8),
    (Code:$5900;Bits: 8),(Code:$5A00;Bits: 8),(Code:$5B00;Bits: 8),(Code:$4A00;Bits: 8),
    (Code:$4B00;Bits: 8),(Code:$3200;Bits: 8),(Code:$3300;Bits: 8),(Code:$3400;Bits: 8)),
    ((Code:$0DC0;Bits:10),(Code:$4000;Bits: 3),(Code:$C000;Bits: 2),(Code:$8000;Bits: 2),
    (Code:$6000;Bits: 3),(Code:$3000;Bits: 4),(Code:$2000;Bits: 4),(Code:$1800;Bits: 5),
    (Code:$1400;Bits: 6),(Code:$1000;Bits: 6),(Code:$0800;Bits: 7),(Code:$0A00;Bits: 7),
    (Code:$0E00;Bits: 7),(Code:$0400;Bits: 8),(Code:$0700;Bits: 8),(Code:$0C00;Bits: 9),
    (Code:$05C0;Bits:10),(Code:$0600;Bits:10),(Code:$0200;Bits:10),(Code:$0CE0;Bits:11),
    (Code:$0D00;Bits:11),(Code:$0D80;Bits:11),(Code:$06E0;Bits:11),(Code:$0500;Bits:11),
    (Code:$02E0;Bits:11),(Code:$0300;Bits:11),(Code:$0CA0;Bits:12),(Code:$0CB0;Bits:12),
    (Code:$0CC0;Bits:12),(Code:$0CD0;Bits:12),(Code:$0680;Bits:12),(Code:$0690;Bits:12),
    (Code:$06A0;Bits:12),(Code:$06B0;Bits:12),(Code:$0D20;Bits:12),(Code:$0D30;Bits:12),
    (Code:$0D40;Bits:12),(Code:$0D50;Bits:12),(Code:$0D60;Bits:12),(Code:$06D0;Bits:12),
    (Code:$0D70;Bits:12),(Code:$06C0;Bits:12),(Code:$0DA0;Bits:12),(Code:$0DB0;Bits:12),
    (Code:$0540;Bits:12),(Code:$0550;Bits:12),(Code:$0560;Bits:12),(Code:$0570;Bits:12),
    (Code:$0640;Bits:12),(Code:$0650;Bits:12),(Code:$0520;Bits:12),(Code:$0530;Bits:12),
    (Code:$0240;Bits:12),(Code:$0370;Bits:12),(Code:$0380;Bits:12),(Code:$0270;Bits:12),
    (Code:$0280;Bits:12),(Code:$0580;Bits:12),(Code:$0590;Bits:12),(Code:$02B0;Bits:12),
    (Code:$02C0;Bits:12),(Code:$05A0;Bits:12),(Code:$0660;Bits:12),(Code:$0670;Bits:12)));

    { Following are makeup run codes for lengths >= 64 }

	MakeupCodes: TMakeupCodes =
    (((Code:$D800;Bits: 5),(Code:$9000;Bits: 5),(Code:$5C00;Bits: 6),(Code:$6E00;Bits: 7),
    (Code:$3600;Bits: 8),(Code:$3700;Bits: 8),(Code:$6400;Bits: 8),(Code:$6500;Bits: 8),
    (Code:$6800;Bits: 8),(Code:$6700;Bits: 8),(Code:$6600;Bits: 9),(Code:$6680;Bits: 9),
    (Code:$6900;Bits: 9),(Code:$6980;Bits: 9),(Code:$6A00;Bits: 9),(Code:$6A80;Bits: 9),
    (Code:$6B00;Bits: 9),(Code:$6B80;Bits: 9),(Code:$6C00;Bits: 9),(Code:$6C80;Bits: 9),
    (Code:$6D00;Bits: 9),(Code:$6D80;Bits: 9),(Code:$4C00;Bits: 9),(Code:$4C80;Bits: 9),
    (Code:$4D00;Bits: 9),(Code:$6000;Bits: 6),(Code:$4D80;Bits: 9),(Code:$0100;Bits:11),
    (Code:$0180;Bits:11),(Code:$01A0;Bits:11),(Code:$0120;Bits:12),(Code:$0130;Bits:12),
    (Code:$0140;Bits:12),(Code:$0150;Bits:12),(Code:$0160;Bits:12),(Code:$0170;Bits:12),
    (Code:$01C0;Bits:12),(Code:$01D0;Bits:12),(Code:$01E0;Bits:12),(Code:$01F0;Bits:12)),
    ((Code:$03C0;Bits:10),(Code:$0C80;Bits:12),(Code:$0C90;Bits:12),(Code:$05B0;Bits:12),
    (Code:$0330;Bits:12),(Code:$0340;Bits:12),(Code:$0350;Bits:12),(Code:$0360;Bits:13),
    (Code:$0368;Bits:13),(Code:$0250;Bits:13),(Code:$0258;Bits:13),(Code:$0260;Bits:13),
    (Code:$0268;Bits:13),(Code:$0390;Bits:13),(Code:$0398;Bits:13),(Code:$03A0;Bits:13),
    (Code:$03A8;Bits:13),(Code:$03B0;Bits:13),(Code:$03B8;Bits:13),(Code:$0290;Bits:13),
    (Code:$0298;Bits:13),(Code:$02A0;Bits:13),(Code:$02A8;Bits:13),(Code:$02D0;Bits:13),
    (Code:$02D8;Bits:13),(Code:$0320;Bits:13),(Code:$0328;Bits:13),(Code:$0100;Bits:11),
    (Code:$0180;Bits:11),(Code:$01A0;Bits:11),(Code:$0120;Bits:12),(Code:$0130;Bits:12),
    (Code:$0140;Bits:12),(Code:$0150;Bits:12),(Code:$0160;Bits:12),(Code:$0170;Bits:12),
    (Code:$01C0;Bits:12),(Code:$01D0;Bits:12),(Code:$01E0;Bits:12),(Code:$01F0;Bits:12)));

    { Following are the status codes reported by the +FHNG hangup response. }

    HangupCodes: array[0..39] of TErrorCode =
    ((Code:0;  Msg: 'Normal and proper end of connection'),
    (Code:1;   Msg: 'Ring Detect without successful handshake'),
    (Code:2;   Msg: 'Call aborted, from +FK or AN'),
    (Code:3;   Msg: 'No Loop Current'),
    (Code:10;  Msg: 'Unspecified Phase A error'),
    (Code:11;  Msg: 'No Answer (T.30 T1 timeout)'),
    (Code:20;  Msg: 'Unspecified Transmit Phase B error'),
    (Code:21;  Msg: 'Remote cannot receive or send'),
    (Code:22;  Msg: 'COMREC error in transmit Phase B'),
    (Code:23;  Msg: 'COMREC invalid command received'),
    (Code:24;  Msg: 'RSPEC error'),
    (Code:25;  Msg: 'DCS sent three times without response'),
    (Code:26;  Msg: 'DIS/DTC received 3 times; DCS not recognized'),
    (Code:27;  Msg: 'Failure to train at 2400 bps or +FMINSP value'),
    (Code:28;  Msg: 'RSPREC invalid response received'),
    (Code:40;  Msg: 'Unspecified Transmit Phase C error'),
    (Code:43;  Msg: 'DTE to DCE data underflow'),
    (Code:50;  Msg: 'Unspecified Transmit Phase D error'),
    (Code:51;  Msg: 'RSPREC error'),
    (Code:52;  Msg: 'No response to MPS repeated 3 times'),
    (Code:53;  Msg: 'Invalid response to MPS'),
    (Code:54;  Msg: 'No response to EOP repeated 3 times'),
    (Code:55;  Msg: 'Invalid response to EOM'),
    (Code:56;  Msg: 'No response to EOM repeated 3 times'),
    (Code:57;  Msg: 'Invalid response to EOM'),
    (Code:58;  Msg: 'Unable to continue after PIN or PIP'),
    (Code:70;  Msg: 'Unspecified Receive Phase B error'),
    (Code:71;  Msg: 'RSPREC error'),
    (Code:72;  Msg: 'COMREC error'),
    (Code:73;  Msg: 'T.30 T2 timeout, expected page not received'),
    (Code:74;  Msg: 'T.30 T1 timeout after EOM received'),
    (Code:90;  Msg: 'Unspecified Receive Phase C error'),
    (Code:91;  Msg: 'Missing EOL after 5 seconds'),
    (Code:92;  Msg: 'Unused code'),
    (Code:93;  Msg: 'DCE to DTE buffer overflow'),
    (Code:94;  Msg: 'Bad CRC or frame (ECM or BFT modes)'),
    (Code:100; Msg: 'Unspecified Receive Phase D errors'),
    (Code:101; Msg: 'RSPREC invalid response received'),
    (Code:102; Msg: 'COMREC invalid response received'),
    (Code:103; Msg: 'Unable to continue after PIN or PIP'));

    { Following are the transmission speeds in the session parameters. }

    ModemRates: array[0..5] of Integer =
        (2400, 4800, 7200, 9600, 12000, 14400);

    { Following is array of min line scan speeds in msec from session prameters.
      First index is 0 for Normal, 1 for Fine. }

    MinScanSpeeds: array[0..1, 0..7] of Integer =
    ((0, 5, 10, 10, 20, 20, 40, 40),
     (0, 5, 5,  10, 10, 20, 20, 40));

    NUL = #0;                       { <NUL> character }
    ETX = #3;                       { <ETX> character }
    LF = #10;                       { <LF> character }
    CR = #13;                       { <CR> character }
    DLE = #16;                      { <DLE> character }
    XON = #17;                      { <XON> character }
    DC2 = #18;                      { <DC2> character }
    XOFF = #19;                     { <XOFF> character }

    PageWidthPixels = 1728;         { Fax page width in pixels }
    A4Length = 297;                 { Length in mm of A4 paper }
    NormalResLinesMM = 3.85;        { Lines per mm in low resoluation mode }
    FineResLinesMM = 7.7;           { Lines per mm in fine resolution mode }

    TxBufferSize = 2048;            { Serial transmit buffer size }
    RxBufferSize = 2048;            { Serial receive buffer size }
    BitBufferBytes = 2048;          { Size of bit buffer in bytes }
    BitBufferBits = BitBufferBytes * 8; { Size of bit buffer in bits }

    CommandPrefix = 'AT';           { Modem command prefix }
    CommandSuffix = CR;             { Modem command suffix }
    DefaultModemInit = '&FE1Q0V1S0=0';    { Default modem initialiation string }
    DefaultModemReset = 'Z';        { Default modem reset string }
    EstablishClassCmd = '+FCLASS=?';  { Query modem what classes are available }
    SetClassCmd = '+FCLASS=2';      { Setup for class 2 operation }
    SetNormalModeCmd = '+FDCC=0';   { Setup for normal resolution }
    SetFineModeCmd = '+FDCC=1';     { Setup for normal resolution }
    SetIDCmd = '+FLID=';            { Set fax idenfication }
    DialToneCmd = 'DT';             { Command to tone dial }
    DialPulseCmd = 'DP';            { Command to pulse dial }
    DialTimeoutSeconds = 45;        { Time to wait for connection }
    AnswerRsp = '+FCON';            { Response for successful connect }
    StationIdRsp = '+FCSI:';        { Indicates ID of remote fax }
    NegotiationSessionRsp = '+FDIS:';{ Indicates negotiates session parameters }
    CurrentSessionRsp = '+FDCS:';   { Indicates current session parameters }
    ConnectRsp = 'CONNECT';         { Connect response }
    PostPageRsp = '+FPTS:';         { Indicates status of send page }
    HangupRsp = '+FHNG:';           { Modem hangup response }
    OKRsp = 'OK';                   { Command OK response }
    BeginPageCmd = '+FDT';          { Command to begin page }
    MorePagesCmd = '+FET=0';        { Indicate another page to follow }
    NoMorePagesCmd = '+FET=2';      { Indicate no more pages to send }
    CommandEchoWait = 200;          { Msec to wait while waiting for cmd echo }
    CommandEchoTries = 10;          { Number of loops while waiting for echo }
    CommandResponseWait = 250;      { Msec to wait for status responses }
    Wait1Second = 1000;             { 1 second delay }
    CommandResponseTries = 240;     { Numbers of loops while waiting }
    DataWriteTimeout = 10000;       { Wait max 10 secs when sending T.4 data }
    PageRetries = 3;                { Number of times to attempt page transmit }

type
    EFaxError = class(Exception);
    TCommReceiveEvent = procedure(Sender: TObject; var s: String) of object;
    TCommTransmitEvent = procedure(Sender: TObject; var s: String) of object;
    TStatusChangeEvent = procedure(Sender: TObject) of object;

    TDialType = (dtTone, dtPulse);
    TFaxDevice = (fdCOM1, fdCOM2, fdCOM3, fdCOM4);
    TFaxStatus = (fsIdle, fsDeviceOpen, fsModemSetup, fsDialling,
        fsWaitingForConnect, fsWaitingForPage, fsSendingPage, fsAborted,
        fsError);
    TFaxMode = (fmNormal, fmFine);
    TFlowControl = (fcNone, fcCTS, fcDSR, fcXOFF);

    TFax = class(TComponent)
        private

{ Variables globally used by class }

            ComFile: THandle;
            BitCount: Integer;
            BitBuffer: array[0..BitBufferBytes] of Byte;
            MinTransmitSize: Integer;

{ Variables to hold properties }

            FCurSessionParameters: String;
            FDialType: TDialType;
            FFaxDevice: TFaxDevice;
            FFaxIdentification: String;
            FFaxMode: TFaxMode;
            FFlowControl: TFlowControl;
            FNegotiationParameters: String;
            FModemInitStr: String;
            FModemResetStr: String;
            FPageNumber: Integer;
            FPhoneNo: string;
            FRemoteStationID: String;
            FScaleFactorX: integer;
            FScaleFactorY: integer;
            FStatus: TFaxStatus;

            FOnCommReceive: TCommReceiveEvent;
            FOnCommTransmit: TCommTransmitEvent;
            FOnStatusChange: TStatusChangeEvent;

{ General private functions and procedures }

            procedure ChangeStatus(NewStatus: TFaxStatus);
            procedure RaiseException(Msg: String);
            function GetDeviceName(FaxDevice: TFaxDevice): String;
            procedure OpenFaxChannel;
            procedure SendString(s: String);
            procedure FlushBuffers;
            procedure CheckHangup(Response: String);
            function ReceiveString: String;
            procedure SendCommand(s: String);
            function StripNonPrintable(s: String): String;
            function ReceiveResponse(Retries, WaitTime: integer): String;
            function FindResult(ModemResponse, SearchString: String): Boolean;
            procedure CheckModemClass;
            procedure DialNumber;
            function WaitForResponse(s: String): String;
            procedure GetRemoteStationID;
            function ParseNumeric(s: String; n: Integer): String;
            procedure GetNegotiationParameters;
            procedure GetCurSessionParameters;
            procedure CheckDelphiRunning;
            procedure InitiateConnection;
            procedure ToggleFlowControl;
            procedure WaitForStart;
            procedure BitBegin;
            procedure BitAdd(Code: DWord; Bits: Integer);
            function ByteReverse(b: Byte): Byte;
            procedure BitReverse;
            procedure BitSend;
            procedure EncodeRun(Black: boolean; RunLength: Integer);
            procedure SendLine(Canvas: TCanvas; Rect: TRect; LineNo: Integer);
            procedure SendClass2Page(Canvas: TCanvas; Rect: TRect);
            procedure SendClass2(Canvas: TCanvas; Rect: TRect; MorePages: Boolean);

{ Property editors / retrieval }

            function GetPageHeight: integer;
            function GetPageWidth: integer;

        public

{ Public procedures and functions }

            constructor Create(AOwner: TComponent); override;
            destructor Destroy; override;

            procedure Abort;
            procedure StartFax;
            procedure SendPage(Canvas: TCanvas; Rect: TRect; MorePages: Boolean);

{ Properties }

        published
            property CurSessionParameters: String read FCurSessionParameters stored False;
            property DialType: TDialType read FDialType write FDialType default dtTone;
            property FaxDevice: TFaxDevice read FFaxDevice write FFaxDevice default fdCOM1;
            property FaxIdentification: String read FFaxIdentification write FFaxIdentification;
            property FaxMode: TFaxMode read FFaxMode write FFaxMode;
            property FlowControl: TFlowControl read FFlowControl write FFlowControl default fcXOFF;
            property NegotiationParameters: String read FNegotiationParameters stored False;
            property ModemInitStr: String read FModemInitStr write FModemInitStr;
            property ModemResetStr: String read FModemResetStr write FModemResetStr;
            property PageHeight: Integer read GetPageHeight stored False;
            property PageNumber: Integer read FPageNumber stored False;
            property PageWidth: Integer read GetPageWidth stored False;
            property PhoneNo: String read FPhoneNo write FPhoneNo;
            property RemoteStationID: String read FRemoteStationID stored False;
            property ScaleFactorX: Integer read FScaleFactorX write FScaleFactorX default 3;
            property ScaleFactorY: Integer read FScaleFactorY write FScaleFactorY default 2;
            property Status: TFaxStatus read FStatus stored False;

            property OnCommReceive: TCommReceiveEvent read FOnCommReceive write FOnCommReceive;
            property OnCommTransmit: TCommTransmitEvent read FOnCommTransmit write FOnCommTransmit;
            property OnStatusChange: TStatusChangeEvent read FOnStatusChange write FOnStatusChange;
  end;

procedure Register;

implementation

var TargetWindow: HWND;

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

procedure TFax.ChangeStatus(NewStatus: TFaxStatus);
begin
    FStatus := NewStatus;
    if Assigned(FOnStatusChange) then FOnStatusChange(Self);
end;

procedure TFax.RaiseException(Msg: String);
begin
    ChangeStatus(fsError);
    if ComFile <> INVALID_HANDLE_VALUE then CloseHandle(ComFile);
    raise EFaxError.Create(Msg);
end;

{ Convert fax device type into Windows device name }

function TFax.GetDeviceName(FaxDevice: TFaxDevice): String;
begin
    case FaxDevice of
        fdCOM1: GetDeviceName := 'COM1:';
        fdCOM2: GetDeviceName := 'COM2:';
        fdCOM3: GetDeviceName := 'COM3:';
        fdCOM4: GetDeviceName := 'COM4:';
        else RaiseException('Invalid fax communications port');
    end;
end;

{ Open and setup fax channel (if not already open) }

procedure TFax.OpenFaxChannel;
var