VB SMTP用户验证发送mail

转自 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发出了。

VB SMTP用户验证发送mail的更多相关文章

SSRS1：配置SMTP Server发送mail
为了使用SSRS发送mail,必须为Reporting service配置SMTP Server. 1,在Reporting Service Configuration Manager中配置Email ...
java 发送 mail 纯文本发送和html格式发送
一:需要引入mail maven jar包  <dependency> <groupId>javax.mail</groupId> ...
使用SpringBoot发送mail邮件
1.前言发送邮件应该是网站的必备拓展功能之一,注册验证,忘记密码或者是给用户发送营销信息.正常我们会用JavaMail相关api来写发送邮件的相关代码,但现在springboot提供了一套更简易使用 ...
SMTP用户枚举原理简介及相关工具
前言 SMTP是安全测试中比较常见的服务类型,其不安全的配置(未禁用某些命令)会导致用户枚举的问题,这主要是通过SMTP命令进行的.本文将介绍SMTP用户枚举原理以及相关工具. SMTP SMTP命令 ...
简单的邮件发送mail.jar
public class MailSender { final static Logger logger = Logger.getLogger(MailSender.class); /** * 发送简 ...
ASP.NET MVC5+EF6+EasyUI 后台管理系统（65）-MVC WebApi 用户验证 (1)
系列目录前言: WebAPI主要开放数据给手机APP,其他需要得知数据的系统,或者软件应用,所以移动端与系统的数据源往往是相通的. Web 用户的身份验证,及页面操作权限验证是B/S系统的基础功能, ...
[Firefly引擎][学习笔记一][已完结]带用户验证的聊天室
原地址:http://bbs.9miao.com/thread-44571-1-1.html 前言:早在群里看到大鸡蛋分享他们团队的Firefly引擎,但一直没有时间去仔细看看,恰好最近需要开发一个棋 ...
Tornado（cookie、XSRF、用户验证）
--------------------Cookie操作-------------------- 1.设置Cookie 1.set_cookie(name,value,domain=Non ...
python_tornado_session用户验证
什么是session? -- Django中带有session,tornado中自己写 -- 逻辑整理用户请求过来,验证通过,随机生成一个字符串当作value返回给浏览器, 在服务器中用户信息与随机 ...

随机推荐

使用gdb调试c程序莫名退出定位 exit 函数
gdb 程序名称 b exit //设置exit函数断点 run //运行程序 bt //查看程序调用堆栈,定位到exit所在行
go实现冒泡排序和快速排序
项目结构冒泡排序算法,源文件bubblesort.go package bubblesort // 冒泡排序 func BubbleSort(values []int) { for i := 0; ...
FZU - 2109 Mountain Number 数位dp
Mountain Number One integer number x is called "Mountain Number" if: (1) x>0 and x is a ...
XXy
XXy codevs1003 帮我看看 #include<iostream> #include<cstdio> using namespace std; ],map[][],n ...
求10000以内n的阶乘（openjudge 2923）
求10000以内n的阶乘总时间限制: 5000ms 内存限制: 655360kB 描述求10000以内n的阶乘. 输入只有一行输入,整数n(0<=n<=10000). 输出一行 ...
关于APICloud使用心得（原创）
从最开始接触APICloud到现在已经有一段时间了.现在想说说自己对于APICloud开发移动端的想法,既有利又有弊. 以下都是我个人的观点. 先说优点吧: 1.APICloud平台文档.视频较多,很 ...
[Andoird]Andoird之Log
一.Log Android中的日志工具类是 Log(android.util.Log),这个类中提供了如下几个方法来供我们打印日志. Log.v() 这个方法用于打印那些最为琐碎的,意义最小的日志信息 ...
Codeforces 1159E（拓扑序、思路）
要点序列上各位置之间的关系常用连边的手段转化为图的问题. 经过一番举例探索不难发现当存在两条有向边交叉时是非法的. -1是模糊的,也就是填多少都可以,那为了尽量避免交叉我们贪心地让它后面那个连它就行 ...
Codeforces 140C（二分、构造）
要点可以贪心选数量最多的那三个构造二分的话里面的check我不太会.正解是既然当前答案为$k$个,那每个物品最多只会出现$k$次,多余的丢掉,剩下的总数如果大于等于$3k$则true. ...
GYM 101933K（二项式反演、排列组合）
方法一设$f_i$为最多使用$i$种颜色的涂色方案,$g_i$为恰好只使用$i$种颜色的涂色方案.可知此题答案为$g_k$. 根据排列组合的知识不难得到\(f_k = \sum_ ...

VB SMTP用户验证发送mail

VB SMTP用户验证发送mail的更多相关文章

随机推荐

热门专题