home *** CD-ROM | disk | FTP | other *** search
/ Delphi 5 for Professionals / DELPHI5.iso / Info / Extras / NetManage / Demos / Simpmail / main.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-03-17  |  16.5 KB  |  497 lines
  1. unit Main;
  2.  
  3. interface
  4.  
  5. uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
  6.   StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, OleCtrls, 
  7.   ISP3;
  8.  
  9. type
  10.  
  11.   TMainForm = class(TForm)
  12.     OpenDialog: TOpenDialog;
  13.     SMTP1: TSMTP;
  14.     POP1: TPOP;
  15.     PageControl1: TPageControl;
  16.     SendPage: TTabSheet;
  17.     RecvPage: TTabSheet;
  18.     ConPage: TTabSheet;
  19.     Panel1: TPanel;
  20.     Label1: TLabel;
  21.     Label3: TLabel;
  22.     Label2: TLabel;
  23.     eTo: TEdit;
  24.     eCC: TEdit;
  25.     eSubject: TEdit;
  26.     SendBtn: TButton;
  27.     ClearBtn: TButton;
  28.     reMessageText: TRichEdit;
  29.     SMTPStatus: TStatusBar;
  30.     Panel3: TPanel;
  31.     mReadMessage: TMemo;
  32.     POPStatus: TStatusBar;
  33.     cbSendFile: TCheckBox;
  34.     GroupBox1: TGroupBox;
  35.     ePOPServer: TEdit;
  36.     Label6: TLabel;
  37.     Label5: TLabel;
  38.     eUserName: TEdit;
  39.     ePassword: TEdit;
  40.     Label4: TLabel;
  41.     GroupBox2: TGroupBox;
  42.     Label7: TLabel;
  43.     eSMTPServer: TEdit;
  44.     SMTPConnectBtn: TButton;
  45.     POPConnectBtn: TButton;
  46.     eHomeAddr: TEdit;
  47.     Label8: TLabel;
  48.     Panel2: TPanel;
  49.     Label9: TLabel;
  50.     lMessageCount: TLabel;
  51.     Label10: TLabel;
  52.     eCurMessage: TEdit;
  53.     udCurMessage: TUpDown;
  54.     ConnectStatus: TStatusBar;
  55.     procedure FormCreate(Sender: TObject);
  56.     procedure POP1StateChanged(Sender: TObject; State: Smallint);
  57.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  58.     procedure SMTP1StateChanged(Sender: TObject; State: Smallint);
  59.     procedure FormResize(Sender: TObject);
  60.     procedure ClearBtnClick(Sender: TObject);
  61.     procedure SMTP1Verify(Sender: TObject);
  62.     procedure SendBtnClick(Sender: TObject);
  63.     procedure POP1ProtocolStateChanged(Sender: TObject;
  64.       ProtocolState: Smallint);
  65.     procedure SMTPConnectBtnClick(Sender: TObject);
  66.     procedure POPConnectBtnClick(Sender: TObject);
  67.     procedure eSMTPServerChange(Sender: TObject);
  68.     procedure ePOPServerChange(Sender: TObject);
  69.     procedure cbSendFileClick(Sender: TObject);
  70.     procedure udCurMessageClick(Sender: TObject; Button: TUDBtnType);
  71.     procedure POP1RefreshMessageCount(Sender: TObject; Number: Integer);
  72.     procedure POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);
  73.     procedure POP1Error(Sender: TObject; Number: Smallint;
  74.       var Description: WideString; Scode: Integer; const Source,
  75.       HelpFile: WideString; HelpContext: Integer;
  76.       var CancelDisplay: WordBool);
  77.     procedure SMTP1DocInput(Sender: TObject; const DocInput: DocInput);
  78.     procedure SMTP1Error(Sender: TObject; Number: Smallint;
  79.       var Description: WideString; Scode: Integer; const Source,
  80.       HelpFile: WideString; HelpContext: Integer;
  81.       var CancelDisplay: WordBool);
  82.   private
  83.     RecvVerified,
  84.     SMTPError,
  85.     POPError: Boolean;
  86.     FMessageCount: Integer;
  87.     procedure SendFile(Filename: string);
  88.     procedure SendMessage;
  89.     procedure CreateHeaders;
  90.   end;
  91.  
  92. var
  93.   MainForm: TMainForm;
  94.  
  95. implementation
  96.  
  97. {$R *.DFM}
  98.  
  99.  
  100. const 
  101.   icDocBegin = 1;
  102.   icDocHeaders = 2;
  103.   icDocData = 3;
  104.   icDocEnd = 5;
  105.  
  106. {When calling a component method which maps onto an OLE call, NoParam substitutes 
  107. for an optional parameter. As an alternative to calling the component method, you 
  108. may access the component's OLEObject directly - 
  109. i.e., Component.OLEObject.MethodName(,Foo,,Bar)}
  110. function NoParam: Variant;
  111. begin
  112.   TVarData(Result).VType := varError;
  113.   TVarData(Result).VError := DISP_E_PARAMNOTFOUND;
  114. end;
  115.  
  116. procedure TMainForm.FormCreate(Sender: TObject);
  117. begin
  118.   SMTPError := False;
  119.   POPError := False;
  120.   FMessageCount := 0;
  121. end;
  122.  
  123. procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
  124. begin
  125.   if POP1.State = prcConnected then POP1.Quit;
  126.   if SMTP1.State = prcConnected then SMTP1.Quit;
  127. end;
  128.  
  129. procedure TMainForm.FormResize(Sender: TObject);
  130. begin
  131.   SendBtn.Left := ClientWidth - SendBtn.Width - 10;
  132.   ClearBtn.Left := ClientWidth - ClearBtn.Width - 10;
  133.   cbSendFile.Left := ClientWidth - cbSendFile.Width - 10;
  134.   eTo.Width := SendBtn.Left - eTo.Left - 10;
  135.   eCC.Width := SendBtn.Left - eCC.Left - 10;
  136.   eSubject.Width := SendBtn.Left - eSubject.Left - 10;
  137. end;
  138.  
  139. procedure TMainForm.ClearBtnClick(Sender: TObject);
  140. begin
  141.   eTo.Text := '';
  142.   eCC.Text := '';
  143.   eSubject.Text := '';
  144.   OpenDialog.Filename := '';
  145.   reMessageText.Lines.Clear;
  146. end;
  147.  
  148. procedure TMainForm.eSMTPServerChange(Sender: TObject);
  149. begin
  150.   SMTPConnectBtn.Enabled := (eSMTPServer.Text <> '') and (eHomeAddr.Text <> '');
  151. end;
  152.  
  153. procedure TMainForm.ePOPServerChange(Sender: TObject);
  154. begin
  155.   POPConnectBtn.Enabled := (ePOPServer.Text <> '') and (eUsername.Text <> '')
  156.     and (ePassword.Text <> '');
  157. end;
  158.  
  159. procedure TMainForm.cbSendFileClick(Sender: TObject);
  160. begin
  161.   if cbSendFile.Checked then
  162.   begin
  163.     if OpenDialog.Execute then
  164.       cbSendFile.Caption := cbSendFile.Caption + ': '+OpenDialog.Filename
  165.     else
  166.       cbSendFile.Checked := False;
  167.   end else 
  168.     cbSendFile.Caption := '&Attach Text File';
  169. end;
  170.  
  171. {Clear and repopulate MIME headers, using the component's DocInput property. A 
  172. separate DocInput OLE object could also be used. See RFC1521/1522 for complete
  173. information on MIME types.}
  174. procedure TMainForm.CreateHeaders;
  175. begin
  176.   with SMTP1 do
  177.   begin
  178.     DocInput.Headers.Clear;
  179.     DocInput.Headers.Add('To', eTo.Text);
  180.     DocInput.Headers.Add('From', eHomeAddr.Text);
  181.     DocInput.Headers.Add('CC', eCC.Text);
  182.     DocInput.Headers.Add('Subject', eSubject.Text);
  183.     DocInput.Headers.Add('Message-Id', Format('%s_%s_%s', [Application.Title,
  184.       DateTimeToStr(Now), eHomeAddr.Text]));
  185.     DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');
  186.   end; 
  187. end;
  188.  
  189. {Send a simple mail message}
  190. procedure TMainForm.SendMessage;
  191. begin
  192.   CreateHeaders;
  193.   with SMTP1 do
  194.     SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
  195. end;
  196.  
  197. {Send a disk file. Leave SendDoc's InputData parameter blank and 
  198. specify a filename for InputFile to send the contents of a disk file. You can
  199. use the DocInput event and GetData methods to do custom encoding (Base64, UUEncode, etc.) }
  200. procedure TMainForm.SendFile(Filename: string);
  201. begin
  202.   CreateHeaders;
  203.   with SMTP1 do
  204.   begin
  205.     DocInput.Filename := FileName;
  206.     SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
  207.   end;
  208. end;
  209.  
  210. {Set global flag indicating recipients are addressable (this only ensures that the
  211. address is in the correct format, not that it exists and is deliverable), then
  212. send the text part of the message}
  213. procedure TMainForm.SMTP1Verify(Sender: TObject);
  214. begin
  215.   SendMessage;
  216.   RecvVerified := True;
  217. end;
  218.  
  219. {Verify addressees, send text message in the Verify event, and if an attachment is 
  220. specified, send it}
  221. procedure TMainForm.SendBtnClick(Sender: TObject);
  222. var
  223.   Addressees: string;
  224. begin
  225.   if SMTP1.State = prcConnected then 
  226.   begin
  227.     RecvVerified := False;
  228.     SMTPError := False;
  229.     Addressees := eTo.Text;
  230.   
  231.     if eCC.Text <> '' then
  232.       Addressees := Addressees + ', '+ eCC.Text;
  233.     SMTP1.Verify(Addressees);
  234.  
  235.     {wait for completion of Verify-Text message send}
  236.     while SMTP1.Busy do 
  237.       Application.ProcessMessages;
  238.     
  239.     {Check global flag indicating addresses are in the correct format - if true,
  240.     the text part of the message has been sent}
  241.     if not RecvVerified then
  242.     begin
  243.       MessageDlg('Incorrect address format', mtError, [mbOK], 0);
  244.       Exit;
  245.     end
  246.     else 
  247.       if cbSendFile.Checked then 
  248.         SendFile(OpenDialog.Filename);
  249.   end
  250.   else 
  251.     MessageDlg('Not connected to SMTP server', mtError, [mbOK], 0);
  252. end;
  253.  
  254. {SMTP component will call this event every time its connection state changes}
  255. procedure TMainForm.SMTP1StateChanged(Sender: TObject; State: Smallint);
  256. begin
  257.   case State of
  258.     prcConnecting:
  259.       ConnectStatus.SimpleText := 'Connecting to SMTP server: '+SMTP1.RemoteHost+'...';
  260.     prcResolvingHost:
  261.       ConnectStatus.SimpleText := 'Resolving Host';
  262.     prcHostResolved:
  263.       ConnectStatus.SimpleText := 'Host Resolved';
  264.     prcConnected:
  265.       begin
  266.         ConnectStatus.SimpleText := 'Connected to SMTP server: '+SMTP1.RemoteHost;
  267.         SMTPConnectBtn.Caption := 'Disconnect';
  268.       end;
  269.     prcDisconnecting:
  270.       ConnectStatus.SimpleText := 'Disconnecting from SMTP server: '+SMTP1.RemoteHost+'...';
  271.     prcDisconnected:
  272.       begin
  273.         ConnectStatus.SimpleText := 'Disconnected from SMTP server: '+SMTP1.RemoteHost;
  274.         SMTPConnectBtn.Caption := 'Connect';
  275.       end;
  276.    end;   
  277.    eSMTPServer.Enabled := not (State = prcConnected);
  278.    eHomeAddr.Enabled := not (State = prcConnected);
  279. end;
  280.  
  281. {The DocInput event is called each time the DocInput state changes during a mail transfer. 
  282. DocInput holds all the information about the current transfer, including the headers, the 
  283. number of bytes transferred, and the message data itself. Although not shown in this example,
  284. you may call DocInput's SetData method if DocInput.State = icDocData to encode the data before
  285. each block is sent.}
  286. procedure TMainForm.SMTP1DocInput(Sender: TObject;
  287.   const DocInput: DocInput);
  288. begin
  289.   case DocInput.State of
  290.     icDocBegin:
  291.       SMTPStatus.SimpleText := 'Initiating document transfer';
  292.     icDocHeaders:
  293.       SMTPStatus.SimpleText := 'Sending headers';
  294.     icDocData:
  295.       if DocInput.BytesTotal > 0 then
  296.         SMTPStatus.SimpleText := Format('Sending data: %d of %d bytes (%d%%)',
  297.           [Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal), 
  298.            Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])
  299.       else 
  300.         SMTPStatus.SimpleText := 'Sending...';
  301.     icDocEnd:
  302.       if SMTPError then 
  303.         SMTPStatus.SimpleText := 'Transfer aborted'
  304.       else 
  305.         SMTPStatus.SimpleText := Format('Mail sent to %s (%d bytes data)', [eTo.Text,
  306.           Trunc(DocInput.BytesTransferred)]);
  307.   end;
  308.   SMTPStatus.Update;
  309. end;
  310.  
  311. {The Error event is called whenever an error occurs in the background processing. In
  312. addition to providing an error code and brief description, you can also access the SMTP
  313. component's Errors property (of type icErrors, an OLE object) to get more detailed
  314. information}
  315. procedure TMainForm.SMTP1Error(Sender: TObject; Number: Smallint;
  316.   var Description: WideString; Scode: Integer; const Source,
  317.   HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
  318. var
  319.   I: Integer;  
  320.   ErrorStr: string;
  321. begin
  322.   SMTPError := True;
  323.   CancelDisplay := True;
  324.   {Get extended error information}
  325.   for I := 1 to SMTP1.Errors.Count do
  326.     ErrorStr := Format(#13'(%s)', [SMTP1.Errors.Item(I).Description]);
  327.   {Display error code, short and long error description}
  328.   MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);
  329. end;
  330.   
  331. {Unlike POP, SMTP does not require a user account on the host machine, so no user
  332. authorization is necessary}
  333. procedure TMainForm.SMTPConnectBtnClick(Sender: TObject);
  334. begin
  335.   if SMTP1.State = prcConnected then 
  336.     SMTP1.Quit
  337.   else 
  338.   if SMTP1.State = prcDisconnected then
  339.     begin
  340.       SMTP1.RemoteHost := eSMTPServer.Text;  
  341.       SMTPError := False; 
  342.       SMTP1.Connect(NoParam, NoParam); 
  343.    end;
  344. end;
  345.  
  346. {Unlike SMTP, users must be authorized on the POP server. The component defines 
  347. a special protocol state, popAuthorization, when it requests authorization. If 
  348. authorization is successful, the protocol state changes to popTransaction and 
  349. POP commands can be issued. Note that server connection is independent of the 
  350. authorization state.}
  351. procedure TMainForm.POP1ProtocolStateChanged(Sender: TObject;
  352.   ProtocolState: Smallint);
  353. begin
  354.   case ProtocolState of
  355.     popAuthorization:
  356.       POP1.Authenticate(POP1.UserID, POP1.Password);
  357.     popTransaction:
  358.       ConnectStatus.SimpleText := Format('User %s authorized on server %s', [eUsername.Text,
  359.         ePOPServer.Text]);
  360.   end;
  361. end;
  362.  
  363. {This event is called every time the connection status of the POP server changes}
  364. procedure TMainForm.POP1StateChanged(Sender: TObject; State: Smallint);
  365. begin
  366.   case State of
  367.     prcConnecting:
  368.       ConnectStatus.SimpleText := 'Connecting to POP server: '+POP1.RemoteHost+'...';
  369.     prcResolvingHost:
  370.       ConnectStatus.SimpleText := 'Resolving Host';
  371.     prcHostResolved:
  372.       ConnectStatus.SimpleText := 'Host Resolved';
  373.     prcConnected:
  374.       begin
  375.         ConnectStatus.SimpleText := 'Connected to POP server: '+POP1.RemoteHost;
  376.         POPConnectBtn.Caption := 'Disconnect';
  377.       end;        
  378.     prcDisconnecting:                 
  379.       ConnectStatus.SimpleText := 'Disconnecting from POP server: '+POP1.RemoteHost+'...';
  380.     prcDisconnected:
  381.       begin
  382.         ConnectStatus.SimpleText := 'Disconnected from POP server: '+POP1.RemoteHost;
  383.         POPConnectBtn.Caption := 'Connect';
  384.       end;
  385.    end;   
  386.    ePOPServer.Enabled := not (State = prcConnected);
  387.    eUsername.Enabled := not (State = prcConnected);
  388.    ePassword.Enabled := not (State = prcConnected);
  389. end;
  390.  
  391. {The Error event is called whenever an error occurs in the background processing. In
  392. addition to providing an error code and brief description, you can also access the POP
  393. component's Errors property (of type icErrors, an OLE object) to get more detailed
  394. information}
  395. procedure TMainForm.POP1Error(Sender: TObject; Number: Smallint;
  396.   var Description: WideString; Scode: Integer; const Source,
  397.   HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
  398. var
  399.   I: Integer;  
  400.   ErrorStr: string;
  401. begin
  402.   POPError := True;
  403.   CancelDisplay := True;
  404.   if POP1.ProtocolState = popAuthorization then
  405.     ConnectStatus.SimpleText := 'Authorization error';
  406.   {Get extended error information}
  407.   for I := 1 to POP1.Errors.Count do
  408.     ErrorStr := Format(#13'(%s)', [POP1.Errors.Item(I).Description]);
  409.   {Display error code, short and long error description}  
  410.   MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);
  411. end;
  412.  
  413. {POP requires a valid user account on the host machine}
  414. procedure TMainForm.POPConnectBtnClick(Sender: TObject);
  415. begin
  416.   if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction)
  417.   and not POP1.Busy then 
  418.   begin
  419.     mReadMessage.Lines.Clear;
  420.     POP1.Quit;
  421.   end
  422.   else 
  423.     if POP1.State = prcDisconnected then
  424.     begin
  425.       POP1.RemoteHost := ePOPServer.Text;
  426.       POP1.UserID := eUserName.Text;
  427.       POP1.Password := ePassword.Text;
  428.       POP1.Connect(NoParam, NoParam);
  429.     end;
  430. end;
  431.  
  432. {The DocOutput event is the just like the DocInput event in 'reverse'. It is called each time
  433. the component's DocOutput state changes during retrieval of mail from the server. When the
  434. state = icDocData, you can call DocOutput.GetData to decode each data block based on the MIME 
  435. content type specified in the headers.}
  436. procedure TMainForm.POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);
  437. var
  438.   Buffer: WideString;
  439.   I: Integer;
  440. begin
  441.   case DocOutput.State of
  442.     icDocBegin:
  443.       POPStatus.SimpleText := 'Initiating document transfer';
  444.     icDocHeaders:
  445.       begin
  446.         POPStatus.SimpleText := 'Retrieving headers';
  447.         for I := 1 to DocOutput.Headers.Count do
  448.           mReadMessage.Lines.Add(DocOutput.Headers.Item(I).Name+': '+
  449.             DocOutput.Headers.Item(I).Value);
  450.       end;
  451.     icDocData:
  452.       begin
  453.         POPStatus.SimpleText := Format('Retrieving data - %d bytes',
  454.             [Trunc(DocOutput.BytesTransferred)]);
  455.         Buffer := DocOutput.DataString;
  456.         mReadMessage.Text := mReadMessage.Text + Buffer;
  457.       end;
  458.     icDocEnd:
  459.       if POPError then 
  460.         POPStatus.SimpleText := 'Transfer aborted'
  461.       else
  462.         POPStatus.SimpleText := Format('Retrieval complete (%d bytes data)',
  463.           [Trunc(DocOutput.BytesTransferred)]);
  464.   end;
  465.   POPStatus.Update;
  466. end;
  467.  
  468. {Retrieve message from the server}
  469. procedure TMainForm.udCurMessageClick(Sender: TObject; Button: TUDBtnType);
  470. begin
  471.   if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction) then
  472.   begin
  473.     POPError := False;
  474.     mReadMessage.Lines.Clear;
  475.     POP1.RetrieveMessage(udCurMessage.Position);
  476.   end;
  477. end;
  478.  
  479. {The RefreshMessageCount event is called whenever the RefreshMessageCount method is 
  480. called, and also when a connection to the POP server is first made}
  481. procedure TMainForm.POP1RefreshMessageCount(Sender: TObject;
  482.   Number: Integer);
  483. begin
  484.   FMessageCount := Number;
  485.   udCurMessage.Max := Number;
  486.   udCurMessage.Enabled := Number <> 0;
  487.   lMessageCount.Caption := IntToStr(Number);
  488.   if Number > 0 then
  489.   begin
  490.     udCurMessage.Min := 1;
  491.     udCurMessage.Position := 1;
  492.     POP1.RetrieveMessage(udCurMessage.Position);
  493.   end;
  494. end;
  495.  
  496. end.
  497.