转自 http://www.jishuzh.com/program/vb-smtp%E7%94%A8%E6%88%B7%E9%AA%8C%E8%AF%81%E5%8F%91%E9%80%81mail.html

这几天技术宅在捣鼓怎么发送“垃圾邮件”,呵呵其实是想做一个群发邮件的小软件,希望通过vb来应用smtp进行发信息。怎耐自己功夫其实还不到家,折腾了好久也没有成功。倒是在这个过程中学习到了一些东西,也找到了一些比较不错的源码,有很多都是花费了九牛二虎之力才找到的,不能说不辛苦。今天的,技术宅给大家分享一份源码:VB SMTP用户验证发送mail。

这封源码技术宅因为后来实在弄到焦头烂额了,没有仔细研究,不过他的注释都是很清楚的,肯定有值得大家学习的地方。

Option Explicit
Private WithEvents Sock As MSWinsockLib.Winsock
Private StrCharset As String '语言编码
Private StrContentType As String '邮件编码
Private StrServerAddress As String 'SMTP服务器地址
Private StrMailServerUserName As String 'SMTP验证用户名
Private StrMailServerPassword As String 'SMTP验证密码
Private StrFrom As String '发信人地址
Private StrFromName As String '发信人姓名
Private StrSubject As String '邮件标题
Private StrBody As String '邮件内容
Private StrRecipient As String '收件人地址
Private LngPriority As Long '邮件级别
Private LngPort As Long 'SMTP服务器端口
Private ErrInt As Integer
Private ErrStr As String
'语言编码
Public Property Let Charset(ByVal Str As String)
StrCharset = Str
End Property
'邮件编码
Public Property Let ContentType(ByVal Str As String)
StrContentType = Str
End Property
'SMTP服务器地址
Public Property Let ServerAddress(ByVal Str As String)
StrServerAddress = Str
End Property
'SMTP服务器端口
Public Property Let Port(ByVal II As Long)
LngPort = II
End Property
'SMTP验证用户名
Public Property Let MailServerUserName(ByVal Str As String)
StrMailServerUserName = Base64(Trim(Str))
End Property
'SMTP验证密码
Public Property Let MailServerPassword(ByVal Str As String)
StrMailServerPassword = Base64(Str)
End Property
'发信人地址
Public Property Let From(ByVal Str As String)
StrFrom = Str
End Property
'发信人姓名
Public Property Let FromName(ByVal Str As String)
StrFromName = Str
End Property
'邮件标题
Public Property Let Subject(ByVal Str As String)
StrSubject = Str
End Property
'收件人地址,可以多个收件人
Public Sub AddRecipient(ByVal Str As String)
StrRecipient = Str
End Sub
'邮件内容
Public Property Let Body(ByVal Str As String)
StrBody = Str
End Property
'邮件级别
Public Property Let Priority(ByVal II As Long)
LngPriority = II
End Property
'应该在执行过可能产生错误的函数后及时调用此函数,获取最新的错误信息。
Public Property Get OnErr() As Integer
OnErr = ErrInt
End Property
Public Property Get Description() As String
Description = ErrStr
End Property
Private Sub Class_Initialize()
Set Sock = New MSWinsockLib.Winsock
End Sub
Private Sub Class_Terminate()
Sock.Close
Set Sock = Nothing
End Sub
Public Sub Send() '发送
If LngPort < 1 Then LngPort = 25
If LngPriority < 1 Or LngPriority > 5 Then LngPriority = 2
If StrCharset = "" Then StrCharset = "GB2312"
If StrC Then StrC
If Right(StrRecipient, 1) <> ";" Then StrRecipient = StrRecipient & ";"
Sock.Close '关闭连接
Sock.Connect StrServerAddress, LngPort '连接邮件服务器
End Sub
Private Sub Sock_DataArrival(ByVal bytesTotal As Long)
Dim StrServerResponse As String '服务器返回的信息
Dim StrResponseCode As String
Dim StrRe() As String
Dim II As Long
Const RandString As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_"
Dim GlobalStr As String
For II = 1 To 24
GlobalStr = GlobalStr & Mid(RandString, Int(Rnd * Len(RandString)) + 1, 1)
Next II '获取邮件服务器返回信息
Sock.GetData StrServerResponse
StrResponseCode = Left(StrServerResponse, 3) '登陆邮件服务器,SMTP验证
Sock.SendData "HELO " & Trim$(StrFrom) & vbCrLf
Sock.SendData "AUTH LOGIN" & vbCrLf
Sock.SendData (StrMailServerUserName) & vbCrLf
Sock.SendData (StrMailServerPassword) & vbCrLf StrRe = Split(StrRecipient, ";")
For II = 0 To UBound(StrRe) - 1 '发送到多个收件人
If StrResp Or _
StrResp Or _
StrResp Or _
StrResp Or _
StrResp Then
Sock.SendData "MAIL FROM:" & Trim$(StrFrom) & vbCrLf '寄件人
Sock.SendData "RCPT TO:" & Trim$(StrRe(II)) & vbCrLf '收件人
Sock.SendData "DATA" & vbCrLf
Sock.SendData "From: " & StrFromName & " <" & StrFrom & ">" & vbCrLf '寄件人
Sock.SendData "To: " & Mid(StrRe(II), 1, InStr(StrRe(II), "@") - 1) & " <" & StrRe(II) & ">" & vbCrLf '收件人
Sock.SendData "Subject:" & Chr(32) & StrSubject & vbCrLf '邮件主题
Sock.SendData "X-Mailer: SkyGz MAIL1.0" & vbCrLf '邮件发送者
Sock.SendData "X-Priority: " & CStr(LngPriority) & vbCrLf '邮件发送级别
Sock.SendData "MIME-Version: 1.0" & vbCrLf
Sock.SendData "Content-Type: multipart/alternative;" & vbCrLf & Chr(9) & "boundary=""----=_NextPart_" & GlobalStr & """" & vbCrLf & vbCrLf
Sock.SendData "This Is A Multi-Part Message In MIME Format." & vbCrLf & vbCrLf
Sock.SendData "------=_NextPart_" & GlobalStr & vbCrLf
Sock.SendData "Content-Type: " & StrContentType & "; charset=" & StrCharset & ";" & vbCrLf & vbCrLf '语言编码和邮件编码
Sock.SendData StrBody & vbCrLf & vbCrLf '邮件内容
Sock.SendData "------=_NextPart_" & GlobalStr & "--" & vbCrLf
Sock.SendData "." & vbCrLf
ErrInt = 3
ErrStr = "发送成功"
'Sock.Close
'Send = True
Else
ErrInt = 4
ErrStr = "发送失败"
'Sock.Close
'Send = False
End If
Next II
Sock.SendData "QUIT" & vbCrLf '退出邮件服务器
End Sub
Private Function Base64(ByVal Str As String) As String 'base6加密算法
Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim StrTempLine As String
Dim j As Integer
For j = 1 To (Len(Str) - Len(Str) Mod 3) Step 3
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j, 1)) 4) + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, ((Asc(Mid(Str, j, 1)) Mod 4) * 16 _
+ Asc(Mid(Str, j + 1, 1)) 16) + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, ((Asc(Mid(Str, j + 1, 1)) Mod 16) * 4 _
+ Asc(Mid(Str, j + 2, 1)) 64) + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j + 2, 1)) Mod 64) + 1, 1)
Next j
If Not (Len(Str) Mod 3) = 0 Then
If (Len(Str) Mod 3) = 2 Then
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j, 1)) 4) + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j, 1)) Mod 4) * 16 _
+ Asc(Mid(Str, j + 1, 1)) 16 + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j + 1, 1)) Mod 16) * 4 + 1, 1)
StrTempLine = StrTempLine & "="
ElseIf (Len(Str) Mod 3) = 1 Then
StrTempLine = StrTempLine + Mid(BASE64_TABLE, Asc(Mid(Str, j, 1)) 4 + 1, 1)
StrTempLine = StrTempLine + Mid(BASE64_TABLE, (Asc(Mid(Str, j, 1)) Mod 4) * 16 + 1, 1)
StrTempLine = StrTempLine & "=="
End If
End If
Base64 = StrTempLine
End Function

  

 
 
 
 

最后技术宅想说,就算做好了群发软件希望也只是测试,不要真正拿来干一些非法的事情哈。

三、 代码实现

Public Response As String, Reply As Integer, DateNow As String
Public Start As Single, Tmr As Single

'API-函数
'Private Declare Function ArrPtr Lib "msvbvm50.dll" _
' Alias "VarPtr" (Ptr() As Any) As Long '<-- VB5
'ArrPtr:取数组的地址

Private Declare Function ArrPtr Lib "msvbvm60.dll" _
Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6

'PokeLng:转换地址内容

Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Addr As Long, Source As Long, _
Optional ByVal Bytes As Long = 4)

'Base64:

Private Base64EncodeByte(0 To 63) As Byte
Private Base64EncodeWord(0 To 63) As Integer
Const Base64EmptyByte As Byte = 61 
Const Base64EmptyWord As Integer = 61

Public Sub Base64Init()
 '建立Base64码数组

 Const Chars64 As String _
  = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
  & "abcdefghijklmnopqrstuvwxyz" _
  & "0123456789+/"
 Static i As Long
 Dim Code As Integer

 If i Then Exit Sub

 For i = 0 To 63
  Code = Asc(Mid$(Chars64, i + 1, 1))
  Base64EncodeByte(i) = Code
  Base64EncodeWord(i) = Code
 Next i
End Sub

Public Static Function Base64EncodeString(ByRef Text As String) As String
'Base64码转换函数
 Dim Chars() As Integer
 Dim SavePtr As Long
 Dim SADescrPtr As Long
 Dim DataPtr As Long
 Dim CountPtr As Long
 Dim TextLen As Long
 Dim i As Long
 Dim Chars64() As Integer
 Dim SavePtr64 As Long
 Dim SADescrPtr64 As Long
 Dim DataPtr64 As Long
 Dim CountPtr64 As Long
 Dim TextLen64 As Long
 Dim j As Long
 Dim b1 As Integer
 Dim b2 As Integer
 Dim b3 As Integer

 j = 0

 TextLen = Len(Text)
 If TextLen = 0 Then Exit Function 
 '输入字符串校验
 TextLen64 = ((TextLen + 2) \ 3) * 4 
 '字符串转换为Base64码后的长度
 Base64EncodeString = Space$(TextLen64)

 If SavePtr = 0 Then
  ReDim Chars(1 To 1)
  SavePtr = VarPtr(Chars(1))
  'SavePtr=*Chars(1)
  PokeLng VarPtr(SADescrPtr), ByVal ArrPtr(Chars)
  '*SADescrPtr=*Chars
  DataPtr = SADescrPtr + 12
  CountPtr = SADescrPtr + 16

  ReDim Chars64(0 To 0)
  SavePtr64 = VarPtr(Chars64(0))
  'SavePtr64=*Chars64(0)
  PokeLng VarPtr(SADescrPtr64), ByVal ArrPtr(Chars64)
  '*SADescrPtr64=*Chars64
  DataPtr64 = SADescrPtr64 + 12
  CountPtr64 = SADescrPtr64 + 16
 End If

 PokeLng DataPtr, StrPtr(Text)
 'DataPtr=*Text
 PokeLng CountPtr, TextLen
 'CountPtr=TextLen
 PokeLng DataPtr64, StrPtr(Base64EncodeString)
 'DataPtr64=*Base64EncodeString
 PokeLng CountPtr64, TextLen64
 'CountPtr64=Textlen64

 Base64Init

 '输入字符串转换为Base64码
 For i = 1 To TextLen - 2 Step 3
  b1 = Chars(i)
  b2 = Chars(i + 1)
  b3 = Chars(i + 2)

  'Base64-Bytes:
  Chars64(j) = Base64EncodeWord(b1 \ &H4)
  Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
  Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4 + b3 \ &H40)
  Chars64(j + 3) = Base64EncodeWord(b3 And &H3F)

  j = j + 4
 Next i

 '继续将未转换完的输入字符串转换为Base64码
 Select Case TextLen - i
  Case 0 '2 Bytes
   b1 = Chars(i)
   Chars64(j) = Base64EncodeWord(b1 \ &H4)
   Chars64(j + 1) = Base64EncodeByte((b1 And &H3) * &H10)
   Chars64(j + 2) = Base64EmptyWord
   Chars64(j + 3) = Base64EmptyWord
  Case 1 '1 Byte
   b1 = Chars(i)
   b2 = Chars(i + 1)

   Chars64(j) = Base64EncodeWord(b1 \ &H4)
   Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
   Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4)
   Chars64(j + 3) = Base64EmptyWord
 End Select

 '返回转换成Base64码的字符串
 PokeLng DataPtr64, SavePtr64
 PokeLng CountPtr64, 1
 PokeLng DataPtr, SavePtr
 PokeLng CountPtr, 1
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, EmialPassword As String, _
 EmialUsername As String, NeedCheck As Integer)

 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

 Winsock1.LocalPort = 0 '用端口0来动态的建立连接
 If Winsock1.State = sckClosed Then '检查winsock的状态是否为关
  '发件人地址
  first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf

  '收件人地址
  Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf

  '时间
  Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
      Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") _
      & "" & " -0600" + vbCrLf

  '发件人
  Fourth = "From:" + Chr(32) + FromName + vbCrLf

  '收件人
  Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf

  '主题
  Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf

  '正文
  Seventh = EmailBodyOfMessage + vbCrLf
  Ninth = "X-Mailer: lj v 2.x" + vbCrLf
  Eighth = Fourth + Third + Ninth + Fifth + Sixth

  Winsock1.Protocol = sckTCPProtocol ' 设置协议为TCP
  Winsock1.RemoteHost = MailServerName ' SMTP地址
  Winsock1.RemotePort = 25 ' SMTP端口
  Winsock1.Connect ' 开始连接
  WaitFor ("220")
  StatusTxt.Caption = "Connecting...."
  StatusTxt.Refresh
  Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
  WaitFor ("250")
  StatusTxt.Caption = "Connected"
  StatusTxt.Refresh

  If NeedCheck = 1 Then
   '进行校验LOGIN
   Winsock1.SendData ("AUTH LOGIN" + vbCrLf)
   StatusTxt.Caption = "LOGIN ESMTP"
   StatusTxt.Refresh
   WaitFor ("334")
   '输入用户名
   Winsock1.SendData (Base64EncodeString(EmialUsername) + vbCrLf) 
   StatusTxt.Caption = "username"
   StatusTxt.Refresh
   WaitFor ("334")
   '输入用户口令
   Winsock1.SendData (Base64EncodeString(EmialPassword) + vbCrLf) 
   StatusTxt.Caption = "password"
   StatusTxt.Refresh
   WaitFor ("235")
  End If

  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)
 '检查是否收到SMTP服务器的返回代码
 Start = Timer
 While Len(Response) = 0
  Tmr = Timer - Start
  DoEvents
  If Tmr > 50 Then
   MsgBox "SMTP service error, timed out while waiting for response" _
      , 64, MsgTitle
   Exit Sub
  End If
 Wend

 While Left(Response, 3) <> ResponseCode
  Tmr = Timer - Start
  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 = "" ' Response清空
End Sub

Private Sub Command1_Click()
 SendEmail txtEmailServer.Text, txtFromName.Text, _
 txtFromEmailAddress.Text, txtToEmailAddress.Text, _
 txtToEmailAddress.Text, txtEmailSubject.Text, _
 txtEmailBodyOfMessage.Text, txtFromEmialPassword.Text, _
 txtFromEmialUsername.Text, EmailNeedCheck.Value
 StatusTxt.Caption = "Mail Sent"
 StatusTxt.Refresh
 Beep
 Close
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
 ' 接收SMTP服务器的信息
 Winsock1.GetData Response
End Sub

  在运行本程序前请先上网,根据实际值填写文本框后点击发送邮件按钮,至此一封具有安全认证服务功能的Email发出了。

05-21 07:18