传真(Fax)编程

开发平台：
Delphi

SENDFAX0.PAS：源码内容
							{**********************************************************}
{*                     SENDFAX0.PAS                       *}
{*   Copyright (c) TurboPower Software Company 1996-98    *}
{*                  All rights reserved                   *}
{**********************************************************}
unit Sendfax0;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, OoMisc, AdFax, AdFStat, AdPort, ExtCtrls,
  SendFax1, AdTapi, AdExcept, ComCtrls, Buttons,FileCtrl;
const
  Receive=0;
  Send=1;
type
  PAddEntry = ^TAddEntry;
  TAddEntry = record
    FaxName     : String;      //接收者姓名
    CoverName   : String;      //
    PhoneNumber : String;       //传真号码
    NextEntry   : PAddEntry;    //下个号码
  end;
  TsfMain = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Label7: TLabel;
    SendFax: TButton;
    sfAdd: TButton;
    sfExit: TButton;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    sfFaxClass: TRadioGroup;
    sfModemInit: TEdit;
    sfHeader: TEdit;
    sfStationID: TEdit;
    sfDialPrefix: TEdit;
    sfDialAttempts: TEdit;
    sfRetryWait: TEdit;
    EnhText: TCheckBox;
    HdrFontBtn: TButton;
    CvrFontBtn: TButton;
    sfModify: TButton;
    sfDelete: TButton;
    sfFaxListBox: TListBox;
    sfSelectComPort: TButton;
    ApdComPort1: TApdComPort;
    ApdFaxStatus1: TApdFaxStatus;
    ApdSendFax1: TApdSendFax;
    ApdFaxLog1: TApdFaxLog;
    ApdTapiDevice1: TApdTapiDevice;
    FontDialog1: TFontDialog;
    Panel2: TPanel;
    Label8: TLabel;
    Label9: TLabel;
    rfFaxClass: TRadioGroup;
    rfNameStyle: TRadioGroup;
    rfDirectory: TEdit;
    rfModemInit: TEdit;
    Panel3: TPanel;
    Label10: TLabel;
    rfReceiveList: TListBox;
    rfReceiveFaxes: TButton;
    rfExit: TButton;
    rfSelectPort: TButton;
    ApdReceiveFax1: TApdReceiveFax;
    BitBtn1: TBitBtn;
    procedure SendFaxClick(Sender: TObject);
    procedure sfAppendAddList(FName, CName, PNumber : String);
    procedure sfGetAddListEntry(var FName, CName, PNumber : String);
    procedure sfAddPrim;
    procedure sfAddClick(Sender: TObject);
    procedure sfAddFromCmdLine;
    procedure ApdSendFax1FaxNext(CP: TObject; var ANumber, AFileName,
      ACoverName: TPassString);
    procedure ApdSendFax1FaxFinish(CP: TObject; ErrorCode: Integer);
    procedure sfExitClick(Sender: TObject);
    procedure sfModifyClick(Sender: TObject);
    procedure sfDeleteClick(Sender: TObject);
    procedure ApdSendFax1FaxLog(CP: TObject; LogCode: TFaxLogCode);
    procedure sfFaxClassClick(Sender: TObject);
    procedure sfDialAttemptsChange(Sender: TObject);
    procedure sfRetryWaitChange(Sender: TObject);
    procedure sfStationIDChange(Sender: TObject);
    procedure sfDialPrefixChange(Sender: TObject);
    procedure sfModemInitChange(Sender: TObject);
    procedure sfHeaderChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure sfSelectComPortClick(Sender: TObject);
    procedure ApdTapiDevice1TapiPortOpen(Sender: TObject);
    procedure ApdTapiDevice1TapiPortClose(Sender: TObject);
    procedure HdrFontBtnClick(Sender: TObject);
    procedure CvrFontBtnClick(Sender: TObject);
    procedure rfSelectPortClick(Sender: TObject);
    procedure rfReceiveFaxesClick(Sender: TObject);
    procedure rfExitClick(Sender: TObject);
    procedure rfFaxClassClick(Sender: TObject);
    procedure rfDirectoryChange(Sender: TObject);
    procedure rfModemInitChange(Sender: TObject);
    procedure rfNameStyleClick(Sender: TObject);
    procedure PageControl1Change(Sender: TObject);
    procedure ApdReceiveFax1FaxError(CP: TObject; ErrorCode: Integer);
    procedure ApdReceiveFax1FaxFinish(CP: TObject; ErrorCode: Integer);
    procedure ApdReceiveFax1FaxLog(CP: TObject; LogCode: TFaxLogCode);
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
    FaxList     : TStringList;
    FaxIndex    : Word;
    InProgress  : Boolean;
    Current:integer;
    AddsInProgress    : Boolean;
    AddsPending       : Word;
    AddList           : PAddEntry;
    ProcessedCmdLine  : Boolean;
  public
    { Public declarations }
    constructor Create(AComponent : TComponent); override;
    destructor Destroy; override;
    procedure sfAddFromPrinterDriver(var Message: TMessage);
      message APW_PRINTDRIVERJOBCREATED;
  end;
var
  sfMain: TsfMain;
implementation
{$R *.DFM}
function LimitS(const S : String; Len : Word) : String;
//减小显示的长度
begin
  if Length(S) > Len then
    Result := Copy(S, 1, Len) + '...'
  else
    Result := S;
end;
constructor TsfMain.Create(AComponent : TComponent);
  {-Create the form}
begin
  inherited Create(AComponent);
  FaxList     := TStringList.Create;
  InProgress  := False;
  AddList     := nil;
  AddsPending := 0;
  AddsInProgress := False;
  ProcessedCmdLine := False;
   rfDirectory.Text := ApdReceiveFax1.DestinationDir;
  rfModemInit.Text := ApdReceiveFax1.ModemInit;
end;
destructor TsfMain.Destroy;
begin
  FaxList.Free;
  inherited Destroy;
end;
procedure TsfMain.FormShow(Sender: TObject);
  {-Handle any command line arguments}
begin
  if not ProcessedCmdLine then begin
    sfAddFromCmdLine;
    ProcessedCmdLine := True;
    if sfHeader.Text = 'Fax sent by $I using APro    $D $T' then
      sfHeader.Text := 'Fax sent by $I using APro ' + ApdComPort1.Version + '   $D $T';
  end;
end;
procedure TsfMain.SendFaxClick(Sender: TObject);
//发送传真
begin
  if not InProgress then begin
    InProgress := True;
    //获得用户
    FaxIndex := 0;
    ApdSendFax1.FaxClass := TFaxClass(sfFaxClass.ItemIndex+1);
    try
      //尝试次数
      ApdSendFax1.DialAttempts := StrToInt(sfDialAttempts.Text);
      //等待时间
      ApdSendFax1.DialRetryWait := StrToInt(sfRetryWait.Text);
    except
    end;
    ApdSendFax1.EnhTextEnabled := EnhText.Checked;
    ApdSendFax1.StationID := sfStationID.Text;
    ApdSendFax1.DialPrefix := sfDialPrefix.Text;
    ApdSendFax1.ModemInit := sfModemInit.Text;    //初始化Modem
    ApdSendFax1.HeaderLine := sfHeader.Text;     //传真头
    if (ApdComPort1.TapiMode = tmOn) or
       ((ApdComPort1.TapiMode = tmAuto) and
        (ApdTapiDevice1.SelectedDevice <> '')) then begin
        //Tapi设置，打开端口
      ApdTapiDevice1.ConfigAndOpen;
    end else begin
      //打开端口开始发送
      try
        ApdComPort1.Open := True;
      except
        InProgress := False;
        raise;
      end;
      ApdSendFax1.StartTransmit;
    end;
  end else
    MessageBeep(0);
end;
procedure TsfMain.sfAppendAddList(FName, CName, PNumber : String);
//新添一个到发送列表中
var
  NewEntry : PAddEntry;
begin
  if AddList = nil then begin
    //清空记录
    GetMem(AddList, sizeof(TAddEntry));
    NewEntry := AddList;
  end else begin
    //末尾指针
    NewEntry := AddList;
    while NewEntry^.NextEntry <> nil do
      NewEntry := NewEntry^.NextEntry;
      //分配内存
    GetMem(NewEntry^.NextEntry, sizeof(TAddEntry));
    NewEntry := NewEntry^.NextEntry;   //指针移动
  end;
  //清空记录
  FillChar(NewEntry^, SizeOf(TAddEntry), 0);
  with NewEntry^ do begin //
    FaxName := FName;
    CoverName := CName;
    PhoneNumber := PNumber;
    NextEntry := nil;
  end;
  inc(AddsPending);
end;
procedure TsfMain.sfGetAddListEntry(var FName, CName, PNumber : String);
//
var
  TempEntry : PAddEntry;
begin
  if AddList = nil then
    exit;
  TempEntry := AddList;
  AddList := AddList^.NextEntry;
  with TempEntry^ do begin
    FName := FaxName;
    CName := CoverName;
    PNumber := PhoneNumber;
  end;
  FreeMem(TempEntry, SizeOf(TAddEntry));
  dec(AddsPending);
end;
procedure TsfMain.sfAddPrim;
 //显示添加的对话框
var
  S : String;
  FName, CName, PNumber : String;
begin
   AddsInProgress := True;
   sfFaxList.flAction.Caption := '添加';
  while AddsPending > 0 do begin
    //显示
    with sfFaxList do begin
      sfGetAddListEntry(FName, CName, PNumber);
      FaxName := FName;
      CoverName := CName;
      PhoneNumber := PNumber;
    end;
    //如果要添加的不为空即添加
    if (sfFaxList.ShowModal = mrOK) and
       (sfFaxList.PhoneNumber <> '') and
       (sfFaxList.FaxName <> '') then begin
      //显示在列表中
      S := sfFaxList.PhoneNumber + '^' + sfFaxList.FaxName;
      if sfFaxList.CoverName <> '' then
        S := S + '^' + sfFaxList.CoverName;
      FaxList.Add(S);
      //
      S := Format('%-20S %-20S %-20S',
                  [LimitS(sfFaxList.PhoneNumber, 20),
                   LimitS(sfFaxList.FaxName, 20),
                   LimitS(sfFaxList.CoverName, 20)]);
      sfFaxListBox.Items.Add(S);
    end;
  end;
  AddsInProgress := False;
end;
procedure TsfMain.sfAddClick(Sender: TObject);
//添加要发送的文件
begin
  sfAppendAddList('', '', '');
  sfAddPrim;
end;
procedure TsfMain.sfAddFromPrinterDriver(var Message: TMessage);
// 通过打印驱动程序添加请求信息
var
  JobID  : Word;
  KeyBuf : array[0..8] of Char;
  zFName : array[0..255] of Char;
begin
  //
  {The message received from the printer driver has a job identifier
   in the wParam field.  This job identifier points to an entry in the
   SendFax.Ini file which the printer driver has added.  As SendFax
   handles each message, it should delete that job entry from the Ini
   file and queue the job for display in the Add dialog.}
  with Message do begin
    JobID := wParam;
    StrCopy(KeyBuf, 'Job');
    KeyBuf[3] := Chr(Lo(JobID));
    KeyBuf[4] := #0;
    GetPrivateProfileString('FaxJobs', KeyBuf, '', zFName, sizeof(zFName),
                            'SENDFAX.INI');
   WritePrivateProfileString('FaxJobs', KeyBuf, nil, 'SENDFAX.INI');
  end;
  sfAppendAddList(StrPas(zFName), '', '');
  if not AddsInProgress then
    sfAddPrim;
end;
procedure TsfMain.sfAddFromCmdLine;
//从命令行中发送请求信息
begin
  if uppercase(ParamStr(1)) = '/F' then begin
    sfAppendAddList(ParamStr(2), '', '');
    if not AddsInProgress then
      sfAddPrim;
  end;
end;
procedure TsfMain.ApdSendFax1FaxNext(CP: TObject;
                                     var ANumber, AFileName,
                                     ACoverName: TPassString);
//下一个要发的传真文件
var
  S : String;
  CaretPos : Byte;
begin
  if FaxList.Count = 0 then Exit;
  try
    S := FaxList[FaxIndex];
    CaretPos := Pos('^', S);
    ANumber := Copy(S, 1, CaretPos-1);
    S := Copy(S, CaretPos+1, 255);
    CaretPos := Pos('^', S);
    if CaretPos = 0 then begin
      AFileName := S;
      ACoverName := '';
    end else begin
      AFileName := Copy(S, 1, CaretPos-1);
      ACoverName := Copy(S, CaretPos+1, 255);
    end;
    Inc(FaxIndex);
  except
    ANumber := '';
    AFileName := '';
    ACoverName := '';
  end;
end;
procedure TsfMain.ApdSendFax1FaxFinish(CP: TObject; ErrorCode: Integer);
//显示结束信息
begin
  ShowMessage('结束: ' + ErrorMsg(ErrorCode));
  if ApdComPort1.TapiMode = tmOn then
    if ApdTapiDevice1.CancelCall then
       //立刻取消呼叫,清标志
      InProgress := False
    else
      //等待执行OnTapiPortClose进行端口关闭
  else begin
      //未使用TAPI，直接关闭端口
    ApdComPort1.Open := False;
    InProgress := False;
  end;
end;
procedure TsfMain.sfExitClick(Sender: TObject);
//退出应用程序
var
  TempEntry : PAddEntry;
begin
  while AddList <> nil do begin
    TempEntry := AddList;
    AddList := AddList^.NextEntry;
    FreeMem(TempEntry, SizeOf(TAddEntry));
  end;
  Close;
end;
procedure TsfMain.sfModifyClick(Sender: TObject);
//修改已加入的发送列表
var
  SaveIndex : Integer;
  CPos : Word;
  S : String;
begin
  if InProgress then begin
    MessageBeep(0);
    Exit;
  end;
  if sfFaxListBox.ItemIndex = -1 then
    Exit;
   sfFaxList.flAction.Caption := '修改';
  //从FaxList中获取列表
  SaveIndex := sfFaxListBox.ItemIndex;
  S := FaxList[SaveIndex];
  CPos := Pos('^', S);
  sfFaxList.PhoneNumber := Copy(S, 1, CPos-1);
  S := Copy(S, CPos+1, 255);
  CPos := Pos('^', S);
  if CPos = 0 then
    sfFaxList.FaxName := S
  else begin
    sfFaxList.FaxName := Copy(S, 1, CPos-1);
    sfFaxList.CoverName := Copy(S, CPos+1, 255);
  end;
  //显示对话框
  if sfFaxList.ShowModal = mrOK then begin
   //修改列表
     S := sfFaxList.PhoneNumber + '^' + sfFaxList.FaxName;
    if sfFaxList.CoverName <> '' then
      S := S + '^' + sfFaxList.CoverName;
    FaxList.Strings[SaveIndex] := S;
   //
    S := Format('%-20S %-20S %-20S',
                [LimitS(sfFaxList.PhoneNumber, 20),
                 LimitS(sfFaxList.FaxName, 20),
                 LimitS(sfFaxList.CoverName, 20)]);
    sfFaxListBox.Items[SaveIndex] := S;
  end;
end;
procedure TsfMain.sfDeleteClick(Sender: TObject);
//删除要发送的传真文件
var
  Index : Word;
begin
  if InProgress then begin
    MessageBeep(0);
    Exit;
  end;
  if sfFaxListBox.ItemIndex <> -1 then begin
    Index := sfFaxListBox.ItemIndex;
    sfFaxListBox.Items.Delete(Index);
    FaxList.Delete(Index);
  end;
end;
procedure TsfMain.ApdSendFax1FaxLog(CP: TObject; LogCode: TFaxLogCode);
//产生日志
begin
  if LogCode = lfaxTransmitOK then begin
    Dec(FaxIndex);
    sfFaxListBox.Items.Delete(FaxIndex);
    FaxList.Delete(FaxIndex);
  end;
end;
procedure TsfMain.sfFaxClassClick(Sender: TObject);
//用另一种类型
//传真类型，这要看FaxMode的类型，看支持哪一类,
//通常应用程序应该用最高的支持fcClass2_0
//fcClass2.fcClass1
begin
  ApdSendFax1.FaxClass := TFaxClass(sfFaxClass.ItemIndex+1);
end;
procedure TsfMain.sfDialAttemptsChange(Sender: TObject);
//最多的尝试连接次数
begin
  try
    ApdSendFax1.DialAttempts := StrToInt(sfDialAttempts.Text);
  except
  end;
end;
procedure TsfMain.sfRetryWaitChange(Sender: TObject);
//最大的等待时间
begin
  try
    ApdSendFax1.DialRetryWait := StrToInt(sfRetryWait.Text);
  except
  end;
end;
procedure TsfMain.sfStationIDChange(Sender: TObject);
//设置新工作站ID
begin
  ApdSendFax1.StationID := sfStationID.Text;
end;
procedure TsfMain.sfDialPrefixChange(Sender: TObject);
//设置新的拨号前缀
begin
  ApdSendFax1.DialPrefix := sfDialPrefix.Text;
end;
procedure TsfMain.sfModemInitChange(Sender: TObject);
//设置新的Modem初始化字符串
begin
  ApdSendFax1.ModemInit := sfModemInit.Text;
end;
procedure TsfMain.sfHeaderChange(Sender: TObject);
//设置新的传真文件头
begin
  ApdSendFax1.HeaderLine := sfHeader.Text;
end;
procedure TsfMain.sfSelectComPortClick(Sender: TObject);
//选择设备
begin
  ApdTapiDevice1.SelectDevice;
end;
procedure TsfMain.ApdTapiDevice1TapiPortOpen(Sender: TObject);
begin
  //利用TAPI设置并打开端口，开始传真会话
  if Current=0 then
   ApdSendFax1.StartTransmit
  else
   ApdReceiveFax1.StartReceive;
end;
procedure TsfMain.ApdTapiDevice1TapiPortClose(Sender: TObject);
begin
  InProgress := False;
end;
procedure TsfMain.HdrFontBtnClick(Sender: TObject);
//设置字体
begin
  FontDialog1.Font.Assign(ApdSendFax1.EnhHeaderFont);
  if FontDialog1.Execute then
    ApdSendFax1.EnhHeaderFont.Assign(FontDialog1.Font);
end;
procedure TsfMain.CvrFontBtnClick(Sender: TObject);
begin
  FontDialog1.Font.Assign(ApdSendFax1.EnhFont);
  if FontDialog1.Execute then
    ApdSendFax1.EnhFont.Assign(FontDialog1.Font);
end;
procedure TsfMain.rfSelectPortClick(Sender: TObject);
begin
  ApdTapiDevice1.SelectDevice;
end;
procedure TsfMain.rfReceiveFaxesClick(Sender: TObject);
begin
if not InProgress then begin
    InProgress := True;
    ApdReceiveFax1.FaxClass := TFaxClass(rfFaxClass.ItemIndex+1);
    ApdReceiveFax1.DestinationDir := rfDirectory.Text;
    ApdReceiveFax1.ModemInit := rfModemInit.Text;
    if (ApdComPort1.TapiMode = tmOn) or
       ((ApdComPort1.TapiMode = tmAuto) and
        (ApdTapiDevice1.SelectedDevice <> '')) then begin
      {Tell TAPI to configure and open the port}
      ApdTapiDevice1.ConfigAndOpen;
    end else begin
      {Open the port and start receiving}
      ApdComPort1.Open := True;
      ApdReceiveFax1.StartReceive;
    end;
  end else
    MessageBeep(0);
end;
procedure TsfMain.rfExitClick(Sender: TObject);
begin
  Close;
end;
procedure TsfMain.rfFaxClassClick(Sender: TObject);
begin
 ApdReceiveFax1.FaxClass := TFaxClass(rfFaxClass.ItemIndex+1);
end;
procedure TsfMain.rfDirectoryChange(Sender: TObject);
begin
  ApdReceiveFax1.DestinationDir := rfDirectory.Text;
end;
procedure TsfMain.rfModemInitChange(Sender: TObject);
begin
  ApdReceiveFax1.ModemInit := rfModemInit.Text;
end;
procedure TsfMain.rfNameStyleClick(Sender: TObject);
begin
  ApdReceiveFax1.FaxNameMode := TFaxNameMode(rfNameStyle.ItemIndex+1);
end;
procedure TsfMain.PageControl1Change(Sender: TObject);
begin
 if PageControl1.ActivePageIndex=0 then
 begin
   Current:=0;
   ApdFaxStatus1.Fax:=ApdSendFax1;
   ApdFaxLog1.Fax:=ApdSendFax1;
 end
 else
 begin
   Current:=1;
   ApdFaxStatus1.Fax:=ApdReceiveFax1;
   ApdFaxLog1.Fax:=ApdReceiveFax1;
 end;
end;
procedure TsfMain.ApdReceiveFax1FaxError(CP: TObject; ErrorCode: Integer);
begin
 ShowMessage('Fax error: ' + ErrorMsg(ErrorCode));
end;
procedure TsfMain.ApdReceiveFax1FaxFinish(CP: TObject; ErrorCode: Integer);
begin
 if ApdComPort1.TapiMode = tmOn then
    if ApdTapiDevice1.CancelCall then
      {Call cancelled immediately, clear InProgress flag}
      InProgress := False
    else
      {CancelCall proceeding in background, waiting for OnTapiPortClose}
  else begin
    {Not using TAPI, just close the port and clear the InProgress flag}
    ApdComPort1.Open := False;
    InProgress := False;
  end;
end;
procedure TsfMain.ApdReceiveFax1FaxLog(CP: TObject; LogCode: TFaxLogCode);
var
  FSize : LongInt;
  F     : File;
  S     : String;
begin
  if LogCode = AdFax.lfaxReceiveOK then begin
    {Get the file size}
    AssignFile(F, ApdReceiveFax1.FaxFile);
    Reset(F, 1);
    FSize := FileSize(F);
    CloseFile(F);
    {Add an entry to the displayed list box of received files}
    S := Format('%-25S %-20S %-20S',
                [LimitS(ExtractFileName(ApdReceiveFax1.FaxFile), 20),
                 IntToStr(FSize),
                 DateTimeToStr(Now)]);
    rfReceiveList.Items.Add(S);
  end;
end;
procedure TsfMain.BitBtn1Click(Sender: TObject);
var
  Dir: string;
begin
  Dir := ExtractFilePath(Application.ExeName);
  if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt],0) then
    rfDirectory.text:= Dir;
end;
end.

						