请问vb如何发送需验证的邮件,不用MApi,像使用163那种,最好有源代码,我随时在看如有合适的,马上给分结贴。
解决方案 »
- API串口通讯,readfile的诡异问题。求解释。
- 如何在WORD文档中锁定书签,急!急!急!急!急!急!
- [VB]中关于datagrid控件
- 问题,请高手帮忙
- 我只有10分了,请大家帮忙:怎么在vb的activex dll中使用全局变量?
- 请问大家,运用全局Hook来实现程序的热键功能,跟调用API中的GetAsyncKeyState函数来实现程序热键功能,那一个比较好呢?速度那一个更快
- 半透明窗体,子窗体可以做成半透明窗体吗?如何做?
- 突然发现我得了7分的专家分,可见CSDN的专家分烂到什么程度!
- vb6.0用Mschart控件的问题,请求大家的帮助
- 最小化后不见了!
- 关于VB 的一个程序问题 非常急 谢谢大家了
- MS Visual Studio 2008是.NET技术吗?
另外请参考这个例子:http://topic.csdn.net/t/20020621/12/820573.html
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 = 61Public 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 SubPublic 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 FunctionSub 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 SubSub 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 SubPrivate 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 SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
' 接收SMTP服务器的信息
Winsock1.GetData Response
End Sub
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or
'you can only send 1 e-mail per 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"
' Get who's sending E-Mail address
first = "MAIL FROM:" + " <" + FromEmailAddress + ">" + vbCrLf
' Get who mail is going to
Second = "RCPT TO:" + " <" + ToEmailAddress + ">" + vbCrLf
' Date when being sent
Third = "Date:" + Chr(32) + DateNow + vbCrLf
' Who's Sending
Fourth = "From:" + Chr(32) + FromName + vbCrLf
' Who it going to
Fifth = "To:" + Chr(32) + ToName + vbCrLf
' Subject of E-Mail
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf
' E-mail message body
Seventh = EmailBodyOfMessage + vbCrLf
' What program sent the e-mail, customize this
Ninth = "My Email Sender,Ver 1.00" + vbCrLf
' Combine for proper SMTP sending
Eighth = Fourth + Third + Ninth + Fifth + Sixth
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")
StatusTxt.Caption = "Connecting...."
StatusTxt.Refresh
Winsock1.SendData ("HELO " & Trim(txtEmailServer.Text) + vbCrLf)
WaitFor ("250")
StatusTxt.Caption = "Connected"
StatusTxt.Refresh
Winsock1.SendData ("AUTH LOGIN" + vbCrLf)
WaitFor ("334")
StatusTxt.Caption = "Sending AUTH LOGIN"
StatusTxt.Refresh
Winsock1.SendData (Base64_Encode(Trim(txtFromEmailAddress.Text)) + vbCrLf)
WaitFor ("334")
StatusTxt.Caption = "Sending Username"
StatusTxt.Refresh
Winsock1.SendData (Base64_Encode("你的密码") + vbCrLf)
WaitFor ("235")
StatusTxt.Caption = "Sending Password"
StatusTxt.Refresh
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 SubSub WaitFor(ResponseCode As String) Start = Timer ' Time event so won't get stuck in loop While Len(Response) = 0
Tmr = Timer - Start
DoEvents ' Let System keep checking for incoming response **IMPORTANT**
If Tmr > 10 Then ' Time in seconds to wait
MsgBox "SMTP service error, timed out while waiting for response", 64
Exit Sub
End If
Wend While Left(Response, 3) <> ResponseCode
Tmr = Timer - Start
DoEvents
If Tmr > 10 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64
Exit Sub
End If
Wend
Response = "" ' Sent response code to blank **IMPORTANT**
End SubPrivate Function Base64_Encode(strSource) As String 'base6加密算法
Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim strTempLine As String
Dim j As Integer
For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
+ Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
+ Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
Next j
If Not (Len(strSource) Mod 3) = 0 Then
If (Len(strSource) Mod 3) = 2 Then
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
+ Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
strTempLine = strTempLine & "="
ElseIf (Len(strSource) Mod 3) = 1 Then
strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
strTempLine = strTempLine & "=="
End If
End If
Base64_Encode = strTempLine
End Function
但哪是的确是VB6代码啊!