Imports System
Imports System.Text
Imports System.IO
Imports System.Net
Imports System.Net.Sockets
Imports System.Collections
Namespace MailList.Data
Public Class ESmtpMail
#Region "内部变量"
'设定换行及回车
Private _enter As String = vbTab & vbCr
' 设定语言代码，默认设定为GB2312，如不需要可设置为""
Private _Charset As String = "GB2312"
' 发件人地址
Private _From As String
' 发件人姓名
Private _FromName As String = "aaa"
' 回复邮件地址
'public string ReplyTo="";
' 收件人姓名
Private _RecipientName As String = ""
' 收件人列表
Private _Recipient As New Hashtable
' 邮件服务器域名
Private _mailserver As String = ""
' 邮件服务器端口号
Private _mailserverport As Integer = 25
' SMTP认证时使用的用户名
Private _username As String = ""
' SMTP认证时使用的密码
Private _password As String = ""
' 是否需要SMTP验证
Private _ESmtp As Boolean = False
' 是否Html邮件
Private _Html As Boolean = False
' 邮件附件列表
Private _Attachments As System.Collections.ArrayList
' 邮件发送优先级，可设置为"High","Normal","Low"或"1","3","5"
Private _priority As String = "Normal"
' 邮件主题
Private _Subject As String = ""
' 邮件正文
Private _Body As String = ""
' 收件人数量
Private _RecipientNum As Integer = 0
' 最多收件人数量
Private _recipientmaxnum As Integer = 1
' 密件收件人数量
'private int RecipientBCCNum=0;
' 错误消息反馈
Private _errmsg As String
' TcpClient对象，用于连接服务器
Private _tc As TcpClient
' NetworkStream对象
Private _ns As NetworkStream
' SMTP错误代码哈希表
Private _ErrCodeHT As New Hashtable
' SMTP正确代码哈希表
Private _RightCodeHT As New Hashtable
' 服务器交互记录
Private _logs As String = ""
#End Region
'构造函数
Public Sub New()
_Attachments = New System.Collections.ArrayList
End Sub
'公共属性
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'邮件服务器域名和验证信息
'形如："user:pass@www.server.com:25"，也可省略次要信息。
'如"user:pass@www.server.com"或"www.server.com"
Public WriteOnly Property MailDomain() As String
Set(ByVal Value As String)
Dim maidomain As String = Value.Trim()
Dim tempint As Integer
If maidomain <> "" Then
tempint = maidomain.IndexOf("@")
If tempint <> -1 Then
Dim str As String = maidomain.Substring(0, tempint)
MailServerUserName = str.Substring(0, str.IndexOf(":"))
MailServerPassWord = str.Substring(str.IndexOf(":") + 1, str.Length - str.IndexOf(":") - 1)
maidomain = maidomain.Substring(tempint + 1, maidomain.Length - tempint - 1)
End If
tempint = maidomain.IndexOf(":")
If tempint <> -1 Then
_mailserver = maidomain.Substring(0, tempint)
_mailserverport = System.Convert.ToInt32(maidomain.Substring(tempint + 1, maidomain.Length - tempint - 1))
Else
_mailserver = maidomain
End If
End If
End Set
End Property
' 邮件服务器端口号
Public WriteOnly Property MailDomainPort() As Integer
Set(ByVal Value As Integer)
_mailserverport = Value
End Set
End Property
' SMTP认证时使用的用户名
Public WriteOnly Property MailServerUserName() As String
Set(ByVal Value As String)
If Value.Trim() <> "" Then
_username = Value.Trim()
_ESmtp = True
Else
_username = ""
_ESmtp = False
End If
End Set
End Property
' SMTP认证时使用的密码
Public WriteOnly Property MailServerPassWord() As String
Set(ByVal Value As String)
_password = Value
End Set
End Property
' 邮件发送优先级，可设置为"High","Normal","Low"或"1","3","5"
Public WriteOnly Property Priority() As String
Set(ByVal Value As String)
Select Case Value.ToLower()
Case "high"
_priority = "High"
Case "1"
_priority = "High"
Case "normal"
_priority = "Normal"
Case "3"
_priority = "Normal"
Case "low"
_priority = "Low"
Case "5"
_priority = "Low"
Case Else
_priority = "Normal"
End Select
End Set
End Property
' 错误消息反馈
Public ReadOnly Property ErrorMessage() As String
Get
Return _errmsg
End Get
End Property
' 服务器交互记录，如发现本组件不能使用的SMTP服务器，
'请将出错时的Logs发给我（lion-a@sohu.com），我将尽快查明原因。
Public ReadOnly Property Logs() As String
Get
Return _logs
End Get
End Property
' 最多收件人数量
Public WriteOnly Property RecipientMaxNum() As Integer
Set(ByVal Value As Integer)
_recipientmaxnum = Value
End Set
End Property
'邮件主题
Public WriteOnly Property MailSubject() As String
Set(ByVal Value As String)
_Subject = Value
End Set
End Property
'邮件正文
Public WriteOnly Property MailBody() As String
Set(ByVal Value As String)
_Body = Value
End Set
End Property
'是否HTML类型邮件
Public WriteOnly Property IsHTML() As Boolean
Set(ByVal Value As Boolean)
_Html = Value
End Set
End Property
'是否需要验证
Public WriteOnly Property ESmtp() As Boolean
Set(ByVal Value As Boolean)
_ESmtp = Value
End Set
End Property
'发件人地址
Public WriteOnly Property From() As String
Set(ByVal Value As String)
_From = Value
End Set
End Property
'发件人姓名
Public WriteOnly Property FromName() As String
Set(ByVal Value As String)
_FromName = Value
End Set
End Property
'公共方法
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' 添加邮件附件
' <param name="path">附件绝对路径</param>
Public Sub AddAttachment(ByVal path As String)
_Attachments.Add(path)
End Sub
' 添加一个收件人
' str参数为收件人地址
Public Overloads Function AddRecipient(ByVal str As String) As Boolean
str = str.Trim()
If str Is Nothing Or str = "" Or str.IndexOf("@") = -1 Then
Return True
End If
If _RecipientNum < _recipientmaxnum Then
_Recipient.Add(_RecipientNum, str)
_RecipientNum += 1
Return True
Else
_errmsg += "收件人过多"
Return False
End If
End Function
' 添加一组收件人（不超过recipientmaxnum个），参数为字符串数组
' 参数str是保存有收件人地址的字符串数组（不超过recipientmaxnum个）
Public Overloads Function AddRecipient(ByVal str() As String) As Boolean
Dim i As Integer
For i = 0 To str.Length - 1
If Not AddRecipient(str(i)) Then
Return False
End If
Next i
Return True
End Function
' 发送邮件方法，所有参数均通过属性设置。
Public Overloads Function Send() As Boolean
If _Recipient.Count = 0 Then
_errmsg = "收件人列表不能为空"
Return False
End If
If _mailserver.Trim() = "" Then
_errmsg = "必须指定SMTP服务器"
Return False
End If
Return SendEmail()
End Function
' 发送邮件方法
' <param name="smtpserver">smtp服务器信息，如"username:password@www.smtpserver.com:25"，也可去掉部分次要信息，如"
www.smtpserver.com"</param>
Public Overloads Function Send(ByVal smtpserver As String) As Boolean
MailDomain = smtpserver
Return Send()
End Function
' 发送邮件方法
' <param name="smtpserver">smtp服务器信息，如"username:password@www.smtpserver.com:25"，也可去掉部分次要信息，如"
www.smtpserver.com"</param>
' <param name="from">发件人mail地址</param>
' <param name="fromname">发件人姓名</param>
' <param name="to">收件人地址</param>
' <param name="toname">收件人姓名</param>
' <param name="html">是否HTML邮件</param>
' <param name="subject">邮件主题</param>
' <param name="body">邮件正文</param>
Public Overloads Function Send(ByVal smtpserver As String, ByVal from As String, _
ByVal fromname As String, ByVal [to] As String, ByVal toname As String, _
ByVal html As Boolean, ByVal subject As String, ByVal body As String) As Boolean
MailDomain = smtpserver
from = from
fromname = fromname
AddRecipient([to])
_RecipientName = toname
html = html
subject = subject
body = body
Return Send()
End Function
'私有方法
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' SMTP回应代码哈希表
Private Sub SMTPCodeAdd()
_ErrCodeHT.Add("500", "邮箱地址错误")
_ErrCodeHT.Add("501", "参数格式错误")
_ErrCodeHT.Add("502", "命令不可实现")
_ErrCodeHT.Add("503", "服务器需要SMTP验证")
_ErrCodeHT.Add("504", "命令参数不可实现")
_ErrCodeHT.Add("421", "服务未就绪，关闭传输信道")
_ErrCodeHT.Add("450", "要求的邮件操作未完成，邮箱不可用（例如，邮箱忙）")
_ErrCodeHT.Add("550", "要求的邮件操作未完成，邮箱不可用（例如，邮箱未找到，或不可访问）")
_ErrCodeHT.Add("451", "放弃要求的操作；处理过程中出错")
_ErrCodeHT.Add("551", "用户非本地，请尝试<forward-path>")
_ErrCodeHT.Add("452", "系统存储不足，要求的操作未执行")
_ErrCodeHT.Add("552", "过量的存储分配，要求的操作未执行")
_ErrCodeHT.Add("553", "邮箱名不可用，要求的操作未执行（例如邮箱格式错误）")
_ErrCodeHT.Add("432", "需要一个密码转换")
_ErrCodeHT.Add("534", "认证机制过于简单")
_ErrCodeHT.Add("538", "当前请求的认证机制需要加密")
_ErrCodeHT.Add("454", "临时认证失败")
_ErrCodeHT.Add("530", "需要认证")
_RightCodeHT.Add("220", "服务就绪")
_RightCodeHT.Add("250", "要求的邮件操作完成")
_RightCodeHT.Add("251", "用户非本地，将转发向<forward-path>")
_RightCodeHT.Add("354", "开始邮件输入，以<enter>.<enter>结束")
_RightCodeHT.Add("221", "服务关闭传输信道")
_RightCodeHT.Add("334", "服务器响应验证Base64字符串")
_RightCodeHT.Add("235", "验证成功")
End Sub
' 将字符串编码为Base64字符串
' <param name="estr">要编码的字符串</param>
Private Function Base64Encode(ByVal str As String) As String
Dim barray() As Byte
barray = Encoding.Default.GetBytes(str)
Return Convert.ToBase64String(barray)
End Function
' 将Base64字符串解码为普通字符串
' <param name="dstr">要解码的字符串</param>
Private Function Base64Decode(ByVal str As String) As String
Dim barray() As Byte
barray = Convert.FromBase64String(str)
Return Encoding.Default.GetString(barray)
End Function
' 得到上传附件的文件流
' <param name="FilePath">附件的绝对路径</param>
Private Function GetStream(ByVal FilePath As String) As String
'建立文件流对象
Dim FileStr As New System.IO.FileStream(FilePath, System.IO.FileMode.Open)
Dim by(System.Convert.ToInt32(FileStr.Length)) As Byte
FileStr.Read(by, 0, by.Length)
FileStr.Close()
Return System.Convert.ToBase64String(by)
End Function
' 发送SMTP命令
Private Function SendCommand(ByVal str As String) As Boolean
Dim WriteBuffer() As Byte
If str Is Nothing Or str.Trim() = "" Then
Return True
End If
_logs += str
WriteBuffer = Encoding.Default.GetBytes(str)
Try
_ns.Write(WriteBuffer, 0, WriteBuffer.Length)
Catch
End Try
Return True
End Function
' 接收SMTP服务器回应
Private Function RecvResponse() As String
Dim StreamSize As Integer
Dim ReturnValue As String = ""
Dim ReadBuffer(1024) As Byte
Try
StreamSize = _ns.Read(ReadBuffer, 0, ReadBuffer.Length)
Catch
End Try
If StreamSize = 0 Then
Return ReturnValue
Else
ReturnValue = Encoding.Default.GetString(ReadBuffer).Substring(0, StreamSize)
_logs += ReturnValue
Return ReturnValue
End If
End Function
' 与服务器交互，发送一条命令并接收回应。
' <param name="Command">一个要发送的命令</param>
' <param name="errstr">如果错误，要反馈的信息</param>
Private Overloads Function Dialog(ByVal str As String, ByVal errstr As String) As Boolean
If str Is Nothing Or str.Trim() = "" Then
Return True
End If
If SendCommand(str) Then
Dim RR As String = RecvResponse()
If RR = "false" Then
Return False
End If
Dim RRCode As String = RR.Substring(0, 3)
If Not (_RightCodeHT(RRCode) Is Nothing) Then
Return True
Else
If Not (_ErrCodeHT(RRCode) Is Nothing) Then
_errmsg += RRCode + _ErrCodeHT(RRCode).ToString()
_errmsg += _enter
Else
_errmsg += RR
End If
_errmsg += errstr
Return False
End If
Else
Return False
End If
End Function
' 与服务器交互，发送一组命令并接收回应。
Private Overloads Function Dialog(ByVal str() As String, ByVal errstr As String) As Boolean
Dim i As Integer
For i = 0 To str.Length - 1
If Not Dialog(str(i), "") Then
_errmsg += _enter
_errmsg += errstr
Return False
End If
Next i
Return True
End Function
Private Function SendEmail() As Boolean
'连接网络
Try
_tc = New TcpClient(_mailserver, _mailserverport)
Catch e As Exception
_errmsg = e.ToString()
Return False
End Try
_ns = _tc.GetStream()
SMTPCodeAdd()
'验证网络连接是否正确
If _RightCodeHT(RecvResponse().Substring(0, 3)) Is Nothing Then
_errmsg = "网络连接失败"
Return False
End If
Dim SendBuffer() As String
Dim SendBufferstr As String
'进行SMTP验证
If _ESmtp Then
SendBuffer = New [String](4) {}
SendBuffer(0) = "EHLO " + _mailserver + _enter
SendBuffer(1) = "AUTH LOGIN" + _enter
SendBuffer(2) = Base64Encode(_username) + _enter
SendBuffer(3) = Base64Encode(_password) + _enter
If Not Dialog(SendBuffer, "SMTP服务器验证失败，请核对用户名和密码。") Then
Return False
End If
Else
SendBufferstr = "HELO " + _mailserver + _enter
If Not Dialog(SendBufferstr, "") Then
Return False
End If
End If
'
SendBufferstr = "MAIL FROM:<" + _From + ">" + _enter
If Not Dialog(SendBufferstr, "发件人地址错误，或不能为空") Then
Return False
End If
'
SendBuffer = New String(_recipientmaxnum) {}
Dim i As Integer
For i = 0 To _Recipient.Count - 1
SendBuffer(i) = "RCPT TO:<" + _Recipient(i).ToString() + ">" + _enter
Next i
If Not Dialog(SendBuffer, "收件人地址有误") Then
Return False
End If
SendBufferstr = "DATA" + _enter
If Not Dialog(SendBufferstr, "") Then
Return False
End If
SendBufferstr = "From:" + _FromName + "<" + _From + ">" + _enter
SendBufferstr += "To:=?" + _Charset.ToUpper() + "?B?" + Base64Encode(_RecipientName) + "?=" + "<" + _Recipient(0) + ">" + _enter
SendBufferstr += "CC:"
Dim k As Integer
For k = 0 To _Recipient.Count - 1
SendBufferstr += _Recipient(i).ToString() + "<" + _Recipient(i).ToString() + ">,"
Next k
SendBufferstr += _enter
If _Charset = "" Then
SendBufferstr += "Subject:" + _Subject + _enter
Else
SendBufferstr += "Subject:" + "=?" + _Charset.ToUpper() + "?B?" + Base64Encode(_Subject) + "?=" + _enter
End If
SendBufferstr += "X-Priority:" + _priority + _enter
SendBufferstr += "X-MSMail-Priority:" + _priority + _enter
SendBufferstr += "Importance:" + _priority + _enter
SendBufferstr += "X-Mailer: Huolx.Pubclass" + _enter
SendBufferstr += "MIME-Version: 1.0" + _enter
SendBufferstr += "Content-Type: multipart/mixed;" + _enter '内容格式和分隔符
SendBufferstr += " boundary=""----=_NextPart_000_00D6_01C29593.AAB31770""" + _enter
SendBufferstr += "------=_NextPart_000_00D6_01C29593.AAB31770" + _enter
If _Html Then
SendBufferstr += "Content-Type: text/html;" + _enter
Else
SendBufferstr += "Content-Type: text/plain;" + _enter
End If
If _Charset = "" Then
SendBufferstr += " charset=""iso-8859-1""" + _enter
Else
SendBufferstr += " charset=""" + _Charset.ToLower() + """" + _enter
End If
'SendBufferstr += "Content-Transfer-Encoding: base64"+enter;
SendBufferstr += "Content-Transfer-Encoding: base64" + _enter + _enter
SendBufferstr += Base64Encode(_Body) + _enter
If _Attachments.Count <> 0 Then
Dim filepath As String
For Each filepath In _Attachments
SendBufferstr += "------=_NextPart_000_00D6_01C29593.AAB31770" + _enter
SendBufferstr += "Content-Type: application/octet-stream" + _enter
SendBufferstr += " name=""=?" + _Charset.ToUpper() + "?B?" + Base64Encode(filepath.Substring((filepath.LastIndexOf("\") + 1))) + "?=""" + _enter
SendBufferstr += "Content-Transfer-Encoding: base64" + _enter
SendBufferstr += "Content-Disposition: attachment;" + _enter
SendBufferstr += " filename=""=?" + _Charset.ToUpper() + "?B?" + Base64Encode(filepath.Substring((filepath.LastIndexOf("\") + 1))) + "?=""" + _enter + _enter
SendBufferstr += GetStream(filepath) + _enter + _enter
Next filepath
End If
SendBufferstr += "------=_NextPart_000_00D6_01C29593.AAB31770--" + _enter + _enter
SendBufferstr += _enter + "." + _enter
If Not Dialog(SendBufferstr, "错误信件信息") Then
Return False
End If
SendBufferstr = "QUIT" + _enter
If Not Dialog(SendBufferstr, "断开连接时错误") Then
Return False
End If
_ns.Close()
_tc.Close()
Return True
End Function
End Class
End Namespace