VB6要如何发信 - 编程论坛

#2

风吹过b2018-06-11 13:50

1、有一个VB6发信的控件，没用过。
2、这个是使用网络通讯，你完全可以使用 WINSOCK 自己写一个。
只使用 SMTP 协议就可以完成发信。

#3

wube2018-06-11 14:17

CSDN查到这组代码~但是无法运作~
不知道Response是什麼東西老卡在這~
MsgTitle不知道是什麼東西~

程序代码：

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编辑过]

#4

wube2018-06-11 14:21

Winsock只写过FTP传档案~没试过用来传邮件~

我觉得还是说一下~我是在XP上用VB6开发的Send Mail~
但是是要在Windows2012 R2上运作的~

[此贴子已经被作者于2018-6-11 14:23编辑过]

#5

wube2018-06-11 14:24

https://bbs.

代码出处~

#6

wube2018-06-11 14:31

结果成功了~之前收不到信的原因是~我同时开启两种网卡~一张公司内部的~一张苹果的~
结果苹果的一切掉~信就进来了~不过还得试试2012行不行~因为成功的不是用贴上的这个~

是用另一个元件Windows内建的CDO.Message~
CDOSYS.dll要去References这个DLL~再写代码~

#7

wube2018-06-14 03:58

以下是引用wube在2018-6-11 14:31:42的发言：

结果成功了~之前收不到信的原因是~我同时开启两种网卡~一张公司内部的~一张苹果的~
结果苹果的一切掉~信就进来了~不过还得试试2012行不行~因为成功的不是用贴上的这个~

是用另一个元件Windows内建的CDO.Message~
CDOSYS.dll要去References这个DLL~再写代码~

经过确认此元件只要是Windows OS都能用，所有版本此DLL可供使用，当然也包含Server版OS〜
泛用性比.Net还更广泛，且不需要装任何编译器或SDK或修补档，即可直接使用〜

[此贴子已经被作者于2018-6-14 04:00编辑过]

#8

wufuzhang2018-06-14 09:04

推荐一个控件jMail.dll，使用方法简单，功能齐全，
也是SMTP协议发送邮件，设置好服务器，很容易发送邮件。

#9

古1232018-06-19 09:27

找到一个临时邮箱不知道可不可以用

程序代码：

'方    法：工程 - 引用-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
'=========================================================调用方法

#10

wube2018-06-19 11:25

我是用CDOSYS.DLL代码很短对Exchange Server

程序代码：

    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

引用自 :
http://www.

透过 Gmail SMTP 发信也行

[此贴子已经被作者于2018-6-19 11:28编辑过]