form1.frm

邮件发送类程序,需要smtp验证,欢迎大家测试.

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "不通过SMTP服务器发送邮件"
   ClientHeight    =   4770
   ClientLeft      =   3030
   ClientTop       =   2640
   ClientWidth     =   5370
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4770
   ScaleWidth      =   5370
   StartUpPosition =   2  '屏幕中心
   Begin MSWinsockLib.Winsock Winsock1 
      Left            =   -1285
      Top             =   4230
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.TextBox Text6 
      Height          =   270
      Left            =   1635
      TabIndex        =   11
      Top             =   937
      Width           =   3495
   End
   Begin VB.TextBox Text5 
      Height          =   270
      Left            =   1635
      TabIndex        =   9
      Top             =   577
      Width           =   3495
   End
   Begin VB.TextBox Text4 
      Height          =   270
      Left            =   1635
      TabIndex        =   7
      Top             =   217
      Width           =   3495
   End
   Begin Project1.MX MX1 
      Left            =   -1180
      Top             =   4545
      _ExtentX        =   714
      _ExtentY        =   450
   End
   Begin VB.TextBox Text3 
      Height          =   270
      Left            =   1635
      TabIndex        =   3
      Top             =   1297
      Width           =   3495
   End
   Begin VB.TextBox Text2 
      Height          =   1935
      Left            =   195
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   2085
      Width           =   4950
   End
   Begin VB.TextBox Text1 
      Height          =   270
      Left            =   1635
      TabIndex        =   1
      Top             =   1657
      Width           =   3495
   End
   Begin VB.CommandButton Command1 
      Caption         =   "发邮件"
      Height          =   375
      Left            =   3840
      TabIndex        =   0
      Top             =   4245
      Width           =   1335
   End
   Begin VB.Label Label3 
      BackColor       =   &H80000018&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "空闲"
      Height          =   255
      Left            =   210
      TabIndex        =   6
      Top             =   4320
      Width           =   3435
   End
   Begin VB.Label Label6 
      Caption         =   "接收者姓名:"
      Height          =   255
      Left            =   165
      TabIndex        =   12
      Top             =   945
      Width           =   1170
   End
   Begin VB.Label Label5 
      Caption         =   "发送者姓名:"
      Height          =   255
      Left            =   165
      TabIndex        =   10
      Top             =   585
      Width           =   1170
   End
   Begin VB.Label Label4 
      Caption         =   "发送者邮件地址:"
      Height          =   255
      Left            =   165
      TabIndex        =   8
      Top             =   225
      Width           =   1350
   End
   Begin VB.Label Label2 
      Caption         =   "信件标题:"
      Height          =   255
      Left            =   165
      TabIndex        =   5
      Top             =   1665
      Width           =   1140
   End
   Begin VB.Label Label1 
      Caption         =   "接收者邮件地址:"
      Height          =   255
      Left            =   165
      TabIndex        =   4
      Top             =   1305
      Width           =   1350
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim start As Single, Tmr As Single

Private Sub Command1_Click()
Dim sDNS As String
Dim sMailServer As String
Dim sDomain As String

sDomain = GetDomainFromAddr(Text3.Text)
If sDomain = "" Then
MsgBox "Please Enter a VALID address!", vbCritical, "Error"
Exit Sub
End If

MX1.Domain = sDomain
sMailServer = MX1.GetMX

If sMailServer = "" Then
MsgBox "Sorry could not locate the mail server for this address.", vbInformation, "Opps..."
Exit Sub
End If

If MX1.DNSCount = 0 Then
MsgBox "Could not Get Local DNS!", vbCritical, "Error"
Exit Sub
End If

sDNS = MX1.DNS(0)

'Error checking for this demo only
If sDNS = "" Then
MsgBox "Could not Retrive Local DNS Server!" & vbCrLf & "Please check your internet settings as EVERYONE has a DNS!", vbCritical, "Opps..."
Exit Sub
End If
'''''''''''''''''''''''''''''''''''

Label3.Caption = "服务器 = " & sMailServer
SendEmail sMailServer, Text5.Text, Text4.Text, Text6.Text, Text3.Text, Text1.Text, Text2.Text
MsgBox "Your mail has been sent.", vbInformation, "Send Mail"
Label3.Caption = "完成"
End Sub

Private Function GetMX(sServer As String, sDNS As String) As String
With wsMX
.RemoteHost = sDNS
.RemotePort = 53 'mx lookup port
.connect
End With
End Function

Public Function GetDomainFromAddr(sAddr As String) As String
Dim Ipos As Long
Ipos = InStr(1, sAddr, "@", vbBinaryCompare)
If Ipos > 0 Then
GetDomainFromAddr = Mid(sAddr, Ipos + 1, Len(sAddr))
Exit Function
End If
GetDomainFromAddr = ""
End Function

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 pre 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: Microsoft Outlook Express 2.10.1029 BETA" + 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")
    
    Label3.Caption = "正在连接...."
    Label3.Refresh
    
    Winsock1.SendData ("HELO mx2.microsoft.com" + vbCrLf)

    WaitFor ("250")

    Label3.Caption = "已连接"
    Label3.Refresh

    Winsock1.SendData (first)

    Label3.Caption = "正在发送"
    Label3.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)
    
    Label3.Caption = "断开连接"
    Label3.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 Form_Unload(Cancel As Integer)
Winsock1.Close
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Winsock1.GetData response ' Check for incoming response *IMPORTANT*
End Sub