fax.pas

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

    OpenFaxChannel;
    ChangeStatus(fsModemSetup);
    SendString(CommandPrefix + FModemInitStr + CommandSuffix);
    Sleep(Wait1Second);
    FlushBuffers;
    CheckModemClass;
    SendCommand(SetClassCmd);
    SendCommand(SetIDCmd + '"' + FFaxIdentification + '"');
    if FFaxMode = fmNormal then
        SendCommand(SetNormalModeCmd)
    else
        SendCommand(SetFineModeCmd);
    ChangeStatus(fsDialling);
    DialNumber;
    ChangeStatus(fsWaitingForConnect);
    GetRemoteStationID;
    GetNegotiationParameters;
    WaitForResponse(OKRsp);
end;

{ Toggle XON/XOFF flow control on/off. }

procedure TFax.ToggleFlowControl;
var
    DCB: TDCB;
begin
    if not GetCommState(ComFile, DCB) then
        RaiseException('GetCommState call failed');
    DCB.Flags := DCB.Flags xor $100;
    if not SetCommState(ComFile, DCB) then
        RaiseException('SetCommState call failed');
end;

{ Wait for an XON or DC2 character }

procedure TFax.WaitForStart;
var
    Ch: Char;
    RetryCount: Integer;
    BytesRead: DWORD;
    S: String;
begin
    RetryCount := 0;
    Repeat
        RetryCount := RetryCount + 1;
        Application.ProcessMessages;
        Sleep(Wait1Second);
        if not ReadFile (ComFile, Ch, 1, BytesRead, Nil) then
            RaiseException('Error while waiting for fax start');
        if Assigned(FOnCommReceive) and (BytesRead > 0) then
        begin
            S := Ch;
            FOnCommReceive(Self, S);
        end;
    Until (Ch in [XON, DC2]) or (RetryCount >= CommandResponseTries);
    if not (Ch in [XON, DC2]) then
        RaiseException('Timeout waiting for fax start');
end;

{ Begin bit operations - reset necessary variables. }

procedure TFax.BitBegin;
begin
    BitCount := 0;
    FillMemory(@BitBuffer, BitBufferBytes, 0);
end;

{ Add a code to the bit buffer. n 'Bits' of 'Code' are shift in from the LSB with
  existing data being shifted left towards the MSB. }

procedure TFax.BitAdd(Code: DWord; Bits: Integer);
var
    StartByte, StartBit, BitsToMove: Integer;
begin
    if (BitCount + Bits) > BitBufferBits then
        RaiseException('Group 3 encoding buffer is full');
    while Bits > 0 do
    begin
        StartByte := BitCount shr 3;//得到加入编码的起始字节
        StartBit := BitCount and 7; //得到起始字节的起始位置
        if Bits > (8 - StartBit) then 
        //如果编码要加入的位数大于起始字节剩余的位数，就先将这个字节填充完毕
            BitsToMove := (8 - StartBit)
        else
        //否则就填充全部的字节
            BitsToMove := Bits;
        BitBuffer[StartByte] := BitBuffer[StartByte] shl BitsToMove
            or Code shr (Bits - BitsToMove) and (1 shl BitsToMove - 1);
        BitCount := BitCount + BitsToMove;
        Bits := Bits - BitsToMove;
    end;
end;

{ Send a run length to the bit buffer. 'Black' is true for black and
  false for white. }

procedure TFax.EncodeRun(Black: boolean; RunLength: Integer);
var
    ColourCode: Integer;
begin
    if Black then ColourCode := 1 else ColourCode := 0;
    if RunLength >= 64 then with MakeupCodes[ColourCode, RunLength shr 6] do
        BitAdd(Code shr (16 - Bits), Bits);
    with TerminatingCodes[ColourCode, RunLength mod 64] do
        BitAdd(Code shr (16 - Bits), Bits);
end;

{ Returns byte with bit order reversed. }

function TFax.ByteReverse(b: Byte): Byte;
begin
    ByteReverse := (b and 1) shl 7
            + (b and 2) shl 5
            + (b and 4) shl 3
            + (b and 8) shl 1
            + (b and 16) shr 1
            + (b and 32) shr 3
            + (b and 64) shr 5
            + (b and 128) shr 7;
end;

{ Bit order must be reversed because modems send LSB first. }

procedure TFax.BitReverse;
var
    i: integer;
begin
    for i := 0 to (BitCount shr 3) + 1 do
        BitBuffer[i] := ByteReverse(BitBuffer[i]);
end;

{ Send the bit buffer to the communications device and reset for next time.
  Before sending any occurrences of <DLE> (char 15) must be replaced by
  <DLE><DLE> to prevent modem entering command mode. }

procedure TFax.BitSend;
var
    BytesToWrite, i: Integer;
    BytesWritten: DWORD;
begin
    BitReverse;
    BytesToWrite := BitCount shr 3;
    if (BitCount mod 8) <> 0 then BytesToWrite := BytesToWrite + 1;
    i := BytesToWrite;
    while i > 0 do
    begin
        i := i - 1;
        if BitBuffer[i] = 16 then
        begin
            if BytesToWrite >= BitBufferBytes then
                RaiseException('Group 3 encoding buffer is full');
            MoveMemory(@BitBuffer[i + 1], @BitBuffer[i], BytesToWrite - i);
            BytesToWrite := BytesToWrite + 1;
        end;
    end;
    if not WriteFile (ComFile, BitBuffer, BytesToWrite, BytesWritten, Nil) then
        RaiseException('Error writing to communications port');
    BitBegin;
end;

{ Run length encode nominated line and send to modem. }

procedure TFax.SendLine(Canvas: TCanvas; Rect: TRect; LineNo: Integer);
var
    x, RunLength, PixelsSent : Integer;
    CurColour: Boolean;
begin
    LineNo := LineNo + Rect.Top;
    PixelsSent := 0;
    with Canvas do
    begin
{ If first pixel black we must send run of zero white pixels anyway. }
        if Pixels[0, LineNo] = clBlack then
            EncodeRun(False, 0);
        Runlength := 0;
        x := Rect.Left;
        CurColour := (Pixels[x, LineNo] = clBlack);
        while (x <= Rect.Right) and (PixelsSent < PageWidthPixels) do
        begin
            x := x + 1;
            if (CurColour = (Pixels[x, LineNo] = clBlack))
                    and (x <= PageWidthPixels) then
                RunLength := RunLength + 1
            else begin
                RunLength := RunLength * ScaleFactorX;
                if (PixelsSent + RunLength) > PageWidthPixels then
                    RunLength := PageWidthPixels - PixelsSent;
                PixelsSent := PixelsSent + RunLength;
                EncodeRun(CurColour, RunLength);
                CurColour := (Pixels[x, LineNo] = clBlack);
                RunLength := 1;
            end;
        end;
    end;
    if PixelsSent < PageWidthPixels then
        EncodeRun(False, PageWidthPixels - PixelsSent);
    for x := 1 to MinTransmitSize - (BitCount shr 3) do BitAdd(0, 8);
    BitAdd(0, 8);
    BitAdd(1, 12);  { Send EOL after each line }
    BitSend;
    ReceiveString;
end;

{ Send page to the fax. Returns True if there are more pages to send. }

procedure TFax.SendClass2Page(Canvas: TCanvas; Rect: TRect);
var
    y, i: Integer;
begin
    BitBegin;
    BitAdd(1, 12);  { Send EOL before start of data }
    y := Rect.Top;
    while (y < Rect.Bottom) do
    begin
        for i := 1 to FScaleFactorY do SendLine(Canvas, Rect, y);
        y := y + 1;
        Application.ProcessMessages;
        if FStatus = fsAborted then Exit;
    end;
    for y:= 1 to 6 do BitAdd(1, 12);  { 6 EOLs indicate end of page }
    BitSend;
end;

{ Perform all steps necessary to transmit a class 2 fax. }

procedure TFax.SendClass2(Canvas: TCanvas; Rect: TRect; MorePages: Boolean);
begin
    FlushBuffers;
    if FFlowCOntrol = fcXOFF then ToggleFlowControl;
    Sleep(Wait1Second);
    SendCommand(BeginPageCmd);
    if FPageNumber = 1 then GetCurSessionParameters;
    WaitForResponse(ConnectRsp);
    SendString(DC2);
    WaitForStart;
    if FFlowCOntrol = fcXOFF then ToggleFlowControl;
    SendClass2Page(Canvas, Rect);
    SendString(DLE + ETX);
    WaitForResponse(OKRsp);
    if MorePages then
        SendCommand(MorePagesCmd)
    else
        SendCommand(NoMorePagesCmd);
end;

{ Calulate height of a fax page in pixels. }

function TFax.GetPageHeight: integer;
begin
    if FFaxMode = fmNormal then
        GetPageHeight := Round(A4Length * NormalResLinesMM)
    else
        GetPageHeight := Round(A4Length * FineResLinesMM);
end;

{ Return width of a fax page in pixels. }

function TFax.GetPageWidth: integer;
begin
    GetPageWidth := PageWidthPixels;
end;

{ Perform initialization for this unit. }

constructor TFax.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    ComFile := INVALID_HANDLE_VALUE;
    FDialType := dtTone;
    FFaxDevice := fdCOM1;
    FFaxMode := fmFine;
    FFlowControl := fcXOFF;
    FModemInitStr := DefaultModemInit;
    FModemResetStr := DefaultModemReset;
    FScaleFactorX := 3;
    FScaleFactorY := 2;
    ChangeStatus(fsIdle);
end;

{ Perform cleanup for this unit. }

destructor TFax.Destroy;
begin
    if ComFile <> INVALID_HANDLE_VALUE then CloseHandle(ComFile);
    inherited Destroy;
end;

{ Abort the fax transmission. }

procedure TFax.Abort;
begin
    if ComFile <> INVALID_HANDLE_VALUE then
    begin
        SendCommand(FModemResetStr);
        CloseHandle(ComFile);
    end;
    ChangeStatus(fsAborted);
end;

{ Start fax transmission. }

procedure TFax.StartFax;
begin
    FPageNumber := 1;
    InitiateConnection;
	ChangeStatus(fsWaitingForPage);
end;

{ Send a page to the fax modem. Set 'MorePages' to true if there are more pages.
  Retries the page if it was returned as bad. }

procedure TFax.SendPage(Canvas: TCanvas; Rect: TRect; MorePages: Boolean);
var
    PageResponse: String;
    BadPage: Boolean;
    Tries, PageStatus: Integer;
begin
	if FStatus = fsWaitingForPage then
    begin
    	ChangeStatus(fsSendingPage);
        Tries := 1;
        repeat
        	SendClass2(Canvas, Rect, MorePages);
            try
                PageResponse := WaitForResponse(PostPageRsp);
                PageStatus := StrToIntDef(ParseNumeric(PageResponse, 1), 1);
            except
                PageStatus := 1;
            end;
            BadPage := ((PageStatus and 1) = 0);
            if BadPage then
            begin
                Tries := Tries + 1;
                if Tries > PageRetries then
                    RaiseException('Too many bad pages. Transmission aborted.');
            end;
        until not BadPage;
        if MorePages then begin
		    FPageNumber := FPageNumber + 1;
    		ChangeStatus(fsWaitingForPage);
    	end else begin
            WaitForResponse(HangupRsp);
            WaitForResponse(OKRsp);
            SendCommand(FModemResetStr);
    	    FlushBuffers;
	    	CloseHandle(ComFile);
    		ChangeStatus(fsIdle);
        end;
    end;
end;

end.