Module1.bas
上传用户:hdzyqc
上传日期:2022-07-20
资源大小:5k
文件大小:5k
- Attribute VB_Name = "Module1"
-
- '***************************************************************'Windows API/Global Declarations for :SMTP: Simple Mail Testing P' rogram'***************************************************************None
-
-
-
- '***************************************************************' Name: SMTP: Simple Mail Testing Program' Description:Allows sending of e-mail (SMTP) directly from a VB ' app using Winsock, WITH OUT having to buy an expensive add on com' ponet' By: Brian Anderson''' Inputs:Requires: Server Address (Name or IP), Senders & Recipei' ent's Names, Sender & Recipient E-Mail address, Body of message'' Returns:Nothing really, does give status on sending operation''Assumes:Very straight forward. Makes sending mail from a VB prog' ram EASY!''Side Effects:NONE!''Code provided by Planet Source Code(tm) (http://www.PlanetSource' Code.com) 'as is', without warranties as to performance, fitness,' merchantability,and any other warranty (whether expressed or impl' ied).'***************************************************************Dim Response As String, Reply As Integer, DateNow As StringDim first As String, Second As String, Third As StringDim Fourth As String, Fifth As String, Sixth As String
- Dim Seventh As String, Eighth As String
- Dim Start As Single, Tmr As Single
- Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
- Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail per program start
- If Winsock1.State = sckClosed Then ' Check to see if socet is closed DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600" first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' Who it going to Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' What program sent the e-mail, customize this Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combine for proper SMTP sending Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
- Winsock1.RemoteHost = MailServerName ' Set the server address
- Winsock1.RemotePort = 25 ' Set the SMTP Port
- Winsock1.Connect ' Start connection
- WaitFor ("220")
- StatusTxt.Caption = "Connecting...."
- StatusTxt.Refresh
- Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
- WaitFor ("250")
- StatusTxt.Caption = "Connected"
- StatusTxt.Refresh
- Winsock1.SendData (First)
- StatusTxt.Caption = "Sending Message"
- StatusTxt.Refresh
- WaitFor ("250")
- Winsock1.SendData (Second)
- WaitFor ("250")
- Winsock1.SendData ("data" + vbCrLf)
- WaitFor ("354")
- Winsock1.SendData (Eighth + vbCrLf)
- Winsock1.SendData (Seventh + vbCrLf)
- Winsock1.SendData ("." + vbCrLf)
- WaitFor ("250")
- Winsock1.SendData ("quit" + vbCrLf)
- StatusTxt.Caption = "Disconnecting"
- StatusTxt.Refresh
- WaitFor ("221")
- Winsock1.Close
- Else
- MsgBox (Str(Winsock1.State))
- End If
- End Sub
- Sub WaitFor(ResponseCode As String)
- Start = Timer ' Time event so won't get stuck in loop
- While Len(Response) = 0
- Tmr = Start - Timer
- DoEvents ' Let System keep checking for incoming response **IMPORTANT**
- If Tmr > 50 Then ' Time in seconds to wait
- MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
- Exit Sub
- End If
- Wend
- While Left(Response, 3) <> ResponseCode
- DoEvents
- If Tmr > 50 Then
- MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
- Exit Sub
- End If
- Wend
- Response = "" ' Sent response code to blank **IMPORTANT** End Sub
- Private Sub Command1_Click()
- SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text 'MsgBox ("Mail Sent") StatusTxt.Caption = "Mail Sent" StatusTxt.Refresh Beep CloseEnd Sub
- Private Sub Command2_Click()
- End Sub
- Private Sub Form_Load()
- End Sub
- Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
- Winsock1.GetData Response ' Check for incoming response *IMPORTANT*
- End Sub