我想在程序中加如这样一个功能:把用户输入的一段文字自动发送到我的一个邮箱中。当然最要不借助任何其他的软件。多谢。
解决方案 »
- vb 事务求助 大分相赠
- 从新来一贴.关于鼠标的.昨天发的帖子没说清楚
- 来CSDN整整一个年头了,散分啦 ,最近找工作,希望能找到,谢谢各位来噌分哦,也谈谈感受
- 如何截取其它程序用MSCOMM控件接收到的内容
- 各位大哥有没有操作过Excel
- 请问,“.gen”结尾,method="GET"的网页怎么提交啊?用intl提交不了啊
- 公安塘沽分局专项治理“香港六合彩”等赌博活动
- 请问使用CommonDialog控件如何保存文件,现在只能选已存在的文件覆盖.
- 有的时候看到网页上精美的 Flash 动画想收藏到自己的硬盘上来,却苦于无从下手。如果你也遇到过有这个问题那就试试这个软件吧:GetFlash
- 有哪位可以把所有的GDI函数抄下来?就是在函数声明中有 Lib "gdi32"的。谢谢。
- 关于textbox
- 怎样在发送的HTML邮件中附带图片呢,图片不是作为附件,而是直接显示
KMAIL很好用
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
实现邮件收发功能