VB6要如何发信
电脑内并无安装OUTLOOK或其他邮件软体是否能单纯使用VB6去寄信件~邮件伺服器使用公司内部的~
在可以寄~但是在VB6不知道怎么写?
Option Explicit Dim Response As String Dim Reply As Integer Dim DateNow As String Dim first As String, Second As String, Third As String Dim Fourth As String, Fifth As String, Sixth As String, Ninth As String Dim Seventh As String, Eighth As String Dim Start As Single, Tmr As Single Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, _ ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String) Winsock1.LocalPort = 0 If Winsock1.State = sckClosed Then DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600" first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf Third = "Date:" + Chr(32) + DateNow + vbCrLf Fourth = "From:" + Chr(32) + FromName + vbCrLf Fifth = "To:" + Chr(32) + ToName + vbCrLf Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf Seventh = EmailBodyOfMessage + vbCrLf Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf Eighth = Fourth + Third + Ninth + Fifth + Sixth Winsock1.Protocol = sckTCPProtocol Winsock1.RemoteHost = MailServerName Winsock1.RemotePort = 25 Winsock1.Connect WaitFor ("220") StatusTxt.Caption = "Connecting...." StatusTxt.Refresh Winsock1.SendData ("HELO " + vbCrLf) WaitFor ("250") StatusTxt.Caption = "Connected" 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 Sub Sub WaitFor(ResponseCode As String) Dim MsgTitle As String Start = Timer While Len(Response) = 0 Tmr = Start - Timer 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 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 = "" ' Sent response code to blank **IMPORTANT** End Sub Private Sub cmdSend_Click() SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToName.Text, txtoEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text 'MsgBox ("Mail Sent") StatusTxt.Caption = "Mail Sent" StatusTxt.Refresh Beep Close End Sub Private Sub cmdExit_Click() End End Sub Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) Winsock1.GetData Response ' Check for incoming response *IMPORTANT* End Sub
[此贴子已经被作者于2018-6-11 14:18编辑过]
[此贴子已经被作者于2018-6-11 14:23编辑过]
[此贴子已经被作者于2018-6-14 04:00编辑过]
'方 法:工程 - 引用-Microsoft WinHTTP Services, version 5.1 Dim 临时邮箱_id As String '邮箱id Dim 临时邮箱_sid As String '页面id Dim 临时邮箱_yid As String '邮件id Public Function 临时邮箱_取邮箱() As String On Error GoTo 出错处理: Dim 临时邮箱_html As String Dim 临时邮箱_Cookie As String Dim WinHttp As WinHttp.WinHttpRequest Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1") WinHttp.Open "GET", "http://24mail.", True WinHttp.SetTimeouts 30000, 30000, 30000, 30000 WinHttp.SetRequestHeader "Host", "24mail." WinHttp.SetRequestHeader "Connection", "keep-alive" WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8" WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.89 Safari/537.36" WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8" WinHttp.Send WinHttp.WaitForResponse While WinHttp.Status <> 200 DoEvents Wend 临时邮箱_html = BytesToBstr(WinHttp.ResponseBody, "UTF-8") 临时邮箱_Cookie = WinHttp.GetAllResponseHeaders 临时邮箱_sid = Split(Split(临时邮箱_Cookie, "Set-Cookie: sid=")(1), Chr(13))(0) 临时邮箱_id = Split(Split(临时邮箱_html, "<input id=" & Chr(34) & "converts" & Chr(34) & " name=" & Chr(34) & "converts" & Chr(34) & " type=" & Chr(34) & "text" & Chr(34) & " value=" & Chr(34))(1), Chr(34))(0) 临时邮箱_取邮箱 = 临时邮箱_id Set WinHttp = Nothing Exit Function 出错处理: Select Case Err.Number Case -2147012894 Set WinHttp = Nothing 临时邮箱_取邮箱 = "临时邮箱_取邮箱_连接超时!" Case -2147012889 Set WinHttp = Nothing 临时邮箱_取邮箱 = "临时邮箱_取邮箱_网络连接不通!" Case Else Set WinHttp = Nothing 临时邮箱_取邮箱 = "临时邮箱_取邮箱_未知错误!" End Select End Function Public Function 临时邮箱_检测邮件() As String On Error GoTo 出错处理: Dim 临时邮箱_html As String Dim 临时邮箱_Cookie As String Dim ShuJu As String Dim WinHttp As WinHttp.WinHttpRequest Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1") ShuJu = "data=" & 临时邮箱_id & "&type=refresh&arg=" WinHttp.Open "POST", "http://24mail.", True WinHttp.SetTimeouts 30000, 30000, 30000, 30000 WinHttp.SetRequestHeader "Host", "24mail." WinHttp.SetRequestHeader "Connection", "keep-alive" WinHttp.SetRequestHeader "Content-Length", Len(ShuJu) WinHttp.SetRequestHeader "Accept", "*/*" WinHttp.SetRequestHeader "Origin", "http://24mail." WinHttp.SetRequestHeader "X-Requested-With", "XMLHttpRequest" WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.89 Safari/537.36" WinHttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8" WinHttp.SetRequestHeader "Referer", "http://24mail." WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8" WinHttp.SetRequestHeader "Cookie", "sid=" & 临时邮箱_sid & "; Hm_lvt_ef483ae9c0f4f800aefdf407e35a21b3=1428991007; Hm_lpvt_ef483ae9c0f4f800aefdf407e35a21b3=1428991007; bdshare_firstime=1428991007313; mail_ck=2" WinHttp.Send ShuJu '发送 WinHttp.WaitForResponse '异步发送 While WinHttp.Status <> 200 DoEvents Wend 临时邮箱_html = BytesToBstr(WinHttp.ResponseBody, "UTF-8") 临时邮箱_id = WinHttp.GetAllResponseHeaders If InStr(临时邮箱_html, Chr(34) & "MID" & Chr(34)) > 0 And InStr(临时邮箱_html, Chr(34) & "SIZE" & Chr(34)) > 0 Then '如果收到邮件 临时邮箱_yid = Split(Split(临时邮箱_html, Chr(34) & "MID" & Chr(34) & ":")(1), ",")(0) 临时邮箱_检测邮件 = "True" Else '如果没有收到邮件 临时邮箱_检测邮件 = "False" End If Set WinHttp = Nothing Exit Function 出错处理: Select Case Err.Number Case -2147012894 Set WinHttp = Nothing 临时邮箱_检测邮件 = "临时邮箱_检测邮件_连接超时!" Case -2147012889 Set WinHttp = Nothing 临时邮箱_检测邮件 = "临时邮箱_检测邮件_网络连接不通!" Case Else Set WinHttp = Nothing 临时邮箱_检测邮件 = "临时邮箱_检测邮件_未知错误!" End Select End Function Public Function 临时邮箱_读取邮件() As String On Error GoTo 出错处理: Dim 临时邮箱_html As String Dim 临时邮箱_Cookie As String Dim ShuJu As String Dim WinHttp As WinHttp.WinHttpRequest Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1") ShuJu = "data=" & 临时邮箱_id & "&type=mailinfo&arg=f%3D" & 临时邮箱_yid WinHttp.Open "POST", "http://24mail.", True WinHttp.SetTimeouts 30000, 30000, 30000, 30000 WinHttp.SetRequestHeader "Host", "24mail." WinHttp.SetRequestHeader "Connection", "keep-alive" WinHttp.SetRequestHeader "Content-Length", Len(ShuJu) WinHttp.SetRequestHeader "Accept", "*/*" WinHttp.SetRequestHeader "Origin", "http://24mail." WinHttp.SetRequestHeader "X-Requested-With", "XMLHttpRequest" WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.89 Safari/537.36" WinHttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8" WinHttp.SetRequestHeader "Referer", "http://24mail." WinHttp.SetRequestHeader "Accept-Language", "zh-CN,zh;q=0.8" WinHttp.SetRequestHeader "Cookie", "sid=" & 临时邮箱_sid & "; bdshare_firstime=1428991007313; Hm_lvt_ef483ae9c0f4f800aefdf407e35a21b3=1428991007; Hm_lpvt_ef483ae9c0f4f800aefdf407e35a21b3=1428992933; mail_ck=4" WinHttp.Send ShuJu '发送 WinHttp.WaitForResponse '异步发送 While WinHttp.Status <> 200 DoEvents Wend 临时邮箱_html = BytesToBstr(WinHttp.ResponseBody, "UTF-8") 临时邮箱_id = WinHttp.GetAllResponseHeaders 临时邮箱_读取邮件 = 临时邮箱_html Set WinHttp = Nothing Exit Function 出错处理: Select Case Err.Number Case -2147012894 Set WinHttp = Nothing 临时邮箱_读取邮件 = "临时邮箱_读取邮件_连接超时!" Case -2147012889 Set WinHttp = Nothing 临时邮箱_读取邮件 = "临时邮箱_读取邮件_网络连接不通!" Case Else Set WinHttp = Nothing 临时邮箱_读取邮件 = "临时邮箱_读取邮件_未知错误!" End Select End Function Public Function BytesToBstr(strBody, CodeBase) Dim ObjStream Set ObjStream = CreateObject("Adodb.Stream") With ObjStream .Type = 1 .Mode = 3 .Open .Write strBody .Position = 0 .Type = 2 .Charset = CodeBase BytesToBstr = .ReadText .Close End With Set ObjStream = Nothing End Function '========================================================= Private Sub Command1_Click() Text1.Text = 临时邮箱_取邮箱() & "@" End Sub Private Sub Command2_Click() Text2.Text = 临时邮箱_检测邮件() End Sub Private Sub Command3_Click() Text3.Text = 临时邮箱_读取邮件() End Sub '=========================================================调用方法
strYouEmail = "123@" '也能群组寄信 strCCEmail = "234@" sch = "http://schemas." Set cdoConfig = CreateObject("CDO.Configuration") With cdoConfig .Fields.Item(sch & "sendusing") = 2 '## (1) 使用 local SMTP, (2) 为外部 SMTP .Fields.Item(sch & "smtpserver") = MAILGATE '## 您的网址 .Fields.Item(sch & "smtpserverport") = 25 '## SMTP Server Port (预设即为 25) .Fields.Update End With Set cdoMessage = CreateObject("CDO.Message") With cdoMessage Set .Configuration = cdoConfig .From = "通知信 <" & strYouEmail & ">" .To = strYouEmail '## 收件者 .CC = strCCEmail '## 副本 ' .BCC = strYouEmail '## 密件副本 .Subject = "TD FTP TXT Path Error" ' .HTMLBody = "信件内容" '## HTML 网页格式信件 .TextBody = Temp '## 文字格式信件内容 ' .AddAttachment "C:\123.JPG" '## 附加档案 .Send End With Set cdoMessage = Nothing Set cdoConfig = Nothing
[此贴子已经被作者于2018-6-19 11:28编辑过]