home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Runimage / DELPHI20 / DEMOS / INTERNET / SIMPMAIL / MAIN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-10  |  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.   ISP;
  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 SMTP1DocInput(Sender: TObject; const DocInput: Variant);
  60.     procedure SMTP1Error(Sender: TObject; Number: Smallint;
  61.       var Description: string; Scode: Integer; const Source,
  62.       HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
  63.     procedure FormResize(Sender: TObject);
  64.     procedure ClearBtnClick(Sender: TObject);
  65.     procedure SMTP1Verify(Sender: TObject);
  66.     procedure SendBtnClick(Sender: TObject);
  67.     procedure POP1ProtocolStateChanged(Sender: TObject;
  68.       ProtocolState: Smallint);
  69.     procedure POP1Error(Sender: TObject; Number: Smallint;
  70.       var Description: string; Scode: Integer; const Source,
  71.       HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
  72.     procedure SMTPConnectBtnClick(Sender: TObject);
  73.     procedure POPConnectBtnClick(Sender: TObject);
  74.     procedure eSMTPServerChange(Sender: TObject);
  75.     procedure ePOPServerChange(Sender: TObject);
  76.     procedure cbSendFileClick(Sender: TObject);
  77.     procedure POP1DocOutput(Sender: TObject; const DocOutput: Variant);
  78.     procedure udCurMessageClick(Sender: TObject; Button: TUDBtnType);
  79.     procedure POP1RefreshMessageCount(Sender: TObject; Number: Integer);
  80.   private
  81.     RecvVerified,
  82.     SMTPError,
  83.     POPError: Boolean;
  84.     FMessageCount: Integer;
  85.     procedure SendFile(Filename: string);
  86.     procedure SendMessage;
  87.     procedure CreateHeaders;
  88.   end;
  89.  
  90. var
  91.   MainForm: TMainForm;
  92.  
  93. implementation
  94.  
  95. {$R *.DFM}
  96.  
  97. uses OLEAuto;
  98.  
  99. const 
  100.   icDocBegin = 1;
  101.   icDocHeaders = 2;
  102.   icDocData = 3;
  103.   icDocEnd = 5;
  104.  
  105. {When calling a component method which maps onto an OLE call, NoParam substitutes 
  106. for an optional parameter. As an alternative to calling the component method, you 
  107. may access the component's OLEObject directly - 
  108. i.e., Component.OLEObject.MethodName(,Foo,,Bar)}
  109. function NoParam: Variant;
  110. begin
  111.   TVarData(Result).VType := varError;
  112.   TVarData(Result).VError := DISP_E_PARAMNOTFOUND;
  113. end;
  114.  
  115. procedure TMainForm.FormCreate(Sender: TObject);
  116. begin
  117.   SMTPError := False;
  118.   POPError := False;
  119.   FMessageCount := 0;
  120. end;
  121.  
  122. procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
  123. begin
  124.   if POP1.State = prcConnected then POP1.Quit;
  125.   if SMTP1.State = prcConnected then SMTP1.Quit;
  126. end;
  127.  
  128. procedure TMainForm.FormResize(Sender: TObject);
  129. begin
  130.   SendBtn.Left := ClientWidth - SendBtn.Width - 10;
  131.   ClearBtn.Left := ClientWidth - ClearBtn.Width - 10;
  132.   cbSendFile.Left := ClientWidth - cbSendFile.Width - 10;
  133.   eTo.Width := SendBtn.Left - eTo.Left - 10;
  134.   eCC.Width := SendBtn.Left - eCC.Left - 10;
  135.   eSubject.Width := SendBtn.Left - eSubject.Left - 10;
  136. end;
  137.  
  138. procedure TMainForm.ClearBtnClick(Sender: TObject);
  139. begin
  140.   eTo.Text := '';
  141.   eCC.Text := '';
  142.   eSubject.Text := '';
  143.   OpenDialog.Filename := '';
  144.   reMessageText.Lines.Clear;
  145. end;
  146.  
  147. procedure TMainForm.eSMTPServerChange(Sender: TObject);
  148. begin
  149.   SMTPConnectBtn.Enabled := (eSMTPServer.Text <> '') and (eHomeAddr.Text <> '');
  150. end;
  151.  
  152. procedure TMainForm.ePOPServerChange(Sender: TObject);
  153. begin
  154.   POPConnectBtn.Enabled := (ePOPServer.Text <> '') and (eUsername.Text <> '')
  155.     and (ePassword.Text <> '');
  156. end;
  157.  
  158. procedure TMainForm.cbSendFileClick(Sender: TObject);
  159. begin
  160.   if cbSendFile.Checked then
  161.   begin
  162.     if OpenDialog.Execute then
  163.       cbSendFile.Caption := cbSendFile.Caption + ': '+OpenDialog.Filename
  164.     else
  165.       cbSendFile.Checked := False;
  166.   end else 
  167.     cbSendFile.Caption := '&Attach Text File';
  168. end;
  169.  
  170. {Clear and repopulate MIME headers, using the component's DocInput property. A 
  171. separate DocInput OLE object could also be used. See RFC1521/1522 for complete
  172. information on MIME types.}
  173. procedure TMainForm.CreateHeaders;
  174. begin
  175.   with SMTP1 do
  176.   begin
  177.     DocInput.Headers.Clear;
  178.     DocInput.Headers.Add('To', eTo.Text);
  179.     DocInput.Headers.Add('From', eHomeAddr.Text);
  180.     DocInput.Headers.Add('CC', eCC.Text);
  181.     DocInput.Headers.Add('Subject', eSubject.Text);
  182.     DocInput.Headers.Add('Message-Id', Format('%s_%s_%s', [Application.Title,
  183.       DateTimeToStr(Now), eHomeAddr.Text]));
  184.     DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');
  185.   end; 
  186. end;
  187.  
  188. {Send a simple mail message}
  189. procedure TMainForm.SendMessage;
  190. begin
  191.   CreateHeaders;
  192.   with SMTP1 do
  193.     SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
  194. end;
  195.  
  196. {Send a disk file. Leave SendDoc's InputData parameter blank and 
  197. specify a filename for InputFile to send the contents of a disk file. You can
  198. use the DocInput event and GetData methods to do custom encoding (Base64, UUEncode, etc.) }
  199. procedure TMainForm.SendFile(Filename: string);
  200. begin
  201.   CreateHeaders;
  202.   with SMTP1 do
  203.   begin
  204.     DocInput.Filename := FileName;
  205.     SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
  206.   end;
  207. end;
  208.  
  209. {Set global flag indicating recipients are addressable (this only ensures that the
  210. address is in the correct format, not that it exists and is deliverable), then
  211. send the text part of the message}
  212. procedure TMainForm.SMTP1Verify(Sender: TObject);
  213. begin
  214.   SendMessage;
  215.   RecvVerified := True;
  216. end;
  217.  
  218. {Verify addressees, send text message in the Verify event, and if an attachment is 
  219. specified, send it}
  220. procedure TMainForm.SendBtnClick(Sender: TObject);
  221. var
  222.   Addressees: string;
  223. begin
  224.   if SMTP1.State = prcConnected then 
  225.   begin
  226.     RecvVerified := False;
  227.     SMTPError := False;
  228.     Addressees := eTo.Text;
  229.   
  230.     if eCC.Text <> '' then
  231.       Addressees := Addressees + ', '+ eCC.Text;
  232.     SMTP1.Verify(Addressees);
  233.  
  234.     {wait for completion of Verify-Text message send}
  235.     while SMTP1.Busy do 
  236.       Application.ProcessMessages;
  237.     
  238.     {Check global flag indicating addresses are in the correct format - if true,
  239.     the text part of the message has been sent}
  240.     if not RecvVerified then
  241.     begin
  242.       MessageDlg('Incorrect address format', mtError, [mbOK], 0);
  243.       Exit;
  244.     end
  245.     else 
  246.       if cbSendFile.Checked then 
  247.         SendFile(OpenDialog.Filename);
  248.   end
  249.   else 
  250.     MessageDlg('Not connected to SMTP server', mtError, [mbOK], 0);
  251. end;
  252.  
  253. {SMTP component will call this event every time its connection state changes}
  254. procedure TMainForm.SMTP1StateChanged(Sender: TObject; State: Smallint);
  255. begin
  256.   case State of
  257.     prcConnecting:
  258.       ConnectStatus.SimpleText := 'Connecting to SMTP server: '+SMTP1.RemoteHost+'...';
  259.     prcResolvingHost:
  260.       ConnectStatus.SimpleText := 'Resolving Host';
  261.     prcHostResolved:
  262.       ConnectStatus.SimpleText := 'Host Resolved';
  263.     prcConnected:
  264.       begin
  265.         ConnectStatus.SimpleText := 'Connected to SMTP server: '+SMTP1.RemoteHost;
  266.         SMTPConnectBtn.Caption := 'Disconnect';
  267.       end;
  268.     prcDisconnecting:
  269.       ConnectStatus.SimpleText := 'Disconnecting from SMTP server: '+SMTP1.RemoteHost+'...';
  270.     prcDisconnected:
  271.       begin
  272.         ConnectStatus.SimpleText := 'Disconnected from SMTP server: '+SMTP1.RemoteHost;
  273.         SMTPConnectBtn.Caption := 'Connect';
  274.       end;
  275.    end;   
  276.    eSMTPServer.Enabled := not (State = prcConnected);
  277.    eHomeAddr.Enabled := not (State = prcConnected);
  278. end;
  279.  
  280. {The DocInput event is called each time the DocInput state changes during a mail transfer. 
  281. DocInput holds all the information about the current transfer, including the headers, the 
  282. number of bytes transferred, and the message data itself. Although not shown in this example,
  283. you may call DocInput's SetData method if DocInput.State = icDocData to encode the data before
  284. each block is sent.}
  285. procedure TMainForm.SMTP1DocInput(Sender: TObject;
  286.   const DocInput: Variant);
  287. begin
  288.   case DocInput.State of
  289.     icDocBegin:
  290.       SMTPStatus.SimpleText := 'Initiating document transfer';
  291.     icDocHeaders:
  292.       SMTPStatus.SimpleText := 'Sending headers';
  293.     icDocData:
  294.       if DocInput.BytesTotal > 0 then
  295.         SMTPStatus.SimpleText := Format('Sending data: %d of %d bytes (%d%%)',
  296.           [Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal), 
  297.            Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])
  298.       else 
  299.         SMTPStatus.SimpleText := 'Sending...';
  300.     icDocEnd:
  301.       if SMTPError then 
  302.         SMTPStatus.SimpleText := 'Transfer aborted'
  303.       else 
  304.         SMTPStatus.SimpleText := Format('Mail sent to %s (%d bytes data)', [eTo.Text,
  305.           Trunc(DocInput.BytesTransferred)]);
  306.   end;
  307.   SMTPStatus.Update;
  308. end;
  309.  
  310. {The Error event is called whenever an error occurs in the background processing. In
  311. addition to providing an error code and brief description, you can also access the SMTP
  312. component's Errors property (of type icErrors, an OLE object) to get more detailed
  313. information}
  314. procedure TMainForm.SMTP1Error(Sender: TObject; Number: Smallint;
  315.   var Description: string; Scode: Integer; const Source, HelpFile: string;
  316.   HelpContext: Integer; var CancelDisplay: Wordbool);
  317. var
  318.   I: Integer;  
  319.   ErrorStr: string;
  320. begin
  321.   SMTPError := True;
  322.   CancelDisplay := True;
  323.   {Get extended error information}
  324.   for I := 1 to SMTP1.Errors.Count do
  325.     ErrorStr := Format(#13'(%s)', [SMTP1.Errors.Item(I).Description]);
  326.   {Display error code, short and long error description}
  327.   MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);
  328. end;
  329.  
  330. {Unlike POP, SMTP does not require a user account on the host machine, so no user
  331. authorization is necessary}
  332. procedure TMainForm.SMTPConnectBtnClick(Sender: TObject);
  333. begin
  334.   if SMTP1.State = prcConnected then 
  335.     SMTP1.Quit
  336.   else 
  337.   if SMTP1.State = prcDisconnected then
  338.     begin
  339.       SMTP1.RemoteHost := eSMTPServer.Text;  
  340.       SMTPError := False; 
  341.       SMTP1.Connect(NoParam, NoParam); 
  342.    end;
  343. end;
  344.  
  345. {Unlike SMTP, users must be authorized on the POP server. The component defines 
  346. a special protocol state, popAuthorization, when it requests authorization. If 
  347. authorization is successful, the protocol state changes to popTransaction and 
  348. POP commands can be issued. Note that server connection is independent of the 
  349. authorization state.}
  350. procedure TMainForm.POP1ProtocolStateChanged(Sender: TObject;
  351.   ProtocolState: Smallint);
  352. begin
  353.   case ProtocolState of
  354.     popAuthorization:
  355.       POP1.Authenticate(POP1.UserID, POP1.Password);
  356.     popTransaction:
  357.       ConnectStatus.SimpleText := Format('User %s authorized on server %s', [eUsername.Text,
  358.         ePOPServer.Text]);
  359.   end;
  360. end;
  361.  
  362. {This event is called every time the connection status of the POP server changes}
  363. procedure TMainForm.POP1StateChanged(Sender: TObject; State: Smallint);
  364. begin
  365.   case State of
  366.     prcConnecting:
  367.       ConnectStatus.SimpleText := 'Connecting to POP server: '+POP1.RemoteHost+'...';
  368.     prcResolvingHost:
  369.       ConnectStatus.SimpleText := 'Resolving Host';
  370.     prcHostResolved:
  371.       ConnectStatus.SimpleText := 'Host Resolved';
  372.     prcConnected:
  373.       begin
  374.         ConnectStatus.SimpleText := 'Connected to POP server: '+POP1.RemoteHost;
  375.         POPConnectBtn.Caption := 'Disconnect';
  376.       end;        
  377.     prcDisconnecting:                 
  378.       ConnectStatus.SimpleText := 'Disconnecting from POP server: '+POP1.RemoteHost+'...';
  379.     prcDisconnected:
  380.       begin
  381.         ConnectStatus.SimpleText := 'Disconnected from POP server: '+POP1.RemoteHost;
  382.         POPConnectBtn.Caption := 'Connect';
  383.       end;
  384.    end;   
  385.    ePOPServer.Enabled := not (State = prcConnected);
  386.    eUsername.Enabled := not (State = prcConnected);
  387.    ePassword.Enabled := not (State = prcConnected);
  388. end;
  389.  
  390. {The Error event is called whenever an error occurs in the background processing. In
  391. addition to providing an error code and brief description, you can also access the POP
  392. component's Errors property (of type icErrors, an OLE object) to get more detailed
  393. information}
  394. procedure TMainForm.POP1Error(Sender: TObject; Number: Smallint;
  395.   var Description: string; Scode: Integer; const Source, HelpFile: string;
  396.   HelpContext: Integer; var CancelDisplay: Wordbool);
  397.   var
  398.   I: Integer;  
  399.   ErrorStr: string;
  400. begin
  401.   POPError := True;
  402.   CancelDisplay := True;
  403.   if POP1.ProtocolState = popAuthorization then
  404.     ConnectStatus.SimpleText := 'Authorization error';
  405.   {Get extended error information}
  406.   for I := 1 to POP1.Errors.Count do
  407.     ErrorStr := Format(#13'(%s)', [POP1.Errors.Item(I).Description]);
  408.   {Display error code, short and long error description}  
  409.   MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);
  410. end;
  411.  
  412. {POP requires a valid user account on the host machine}
  413. procedure TMainForm.POPConnectBtnClick(Sender: TObject);
  414. begin
  415.   if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction)
  416.   and not POP1.Busy then 
  417.   begin
  418.     mReadMessage.Lines.Clear;
  419.     POP1.Quit;
  420.   end
  421.   else 
  422.     if POP1.State = prcDisconnected then
  423.     begin
  424.       POP1.RemoteHost := ePOPServer.Text;
  425.       POP1.UserID := eUserName.Text;
  426.       POP1.Password := ePassword.Text;
  427.       POP1.Connect(NoParam, NoParam);
  428.     end;
  429. end;
  430.  
  431. {The DocOutput event is the just like the DocInput event in 'reverse'. It is called each time
  432. the component's DocOutput state changes during retrieval of mail from the server. When the
  433. state = icDocData, you can call DocOutput.GetData to decode each data block based on the MIME 
  434. content type specified in the headers.}
  435. procedure TMainForm.POP1DocOutput(Sender: TObject;
  436.   const DocOutput: Variant);
  437. var
  438.   Buffer: Variant;
  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.         DocOutput.GetData(Buffer);
  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.