论坛广场 › Visual Basic › [讨论]如何做一个邮件发送程序?

马大哈 发表于 2005-7-14 23:09:11

[讨论]如何做一个邮件发送程序?

<P>要求:</P>
<P>一,不能用现成的接口,如MAPI等.</P>
<P>二,可以由用户填写SMTP服务器.</P>
<P>我已经做了一个,近期会传上来.我是使用的Winsock控件实现的,使用ESMTP协议.</P>
<P>关键点:ESMTP协议,BASE64编码约定</P>

jessezappy 发表于 2010-10-21 09:45:04

2001年的时候做过一个，可以发送附件的，Base64对附件进行编码发送，因为后来用了一段时间就没用了，源代码等我找找，拿来交流下。

jessezappy 发表于 2011-8-10 11:41:44

去年老马搬家，硬是找不到论坛入口了，还好今天闲的无聊，搜索我自己的ID号又找到老马的紫水晶了；因此顺便发下我2001年做的那个Email发送程序，这个程序是可以附件编码后发送的。Private Sub Command1_Click()
Dim TIM As Long
Dim FnfileNas As Integer, TmpStr As String, successOut As Boolean
Dim nFno1 As Integer, nFno2 As Integer, ErrinfoStr As String
Dim reSendNum As Integer
On Error GoTo Errcode
reSendNum = 0
Command1.Enabled = False
Call SendFJ

If Makefile <> "" Then
    '--------出错，记录日志
    GoTo ErrClear
End If

If Trim(Text1.Text) = "" Then
    MainErr = MainErr & "Text1 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text2.Text) = "" Then
    MainErr = MainErr & "Text2 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text3.Text) = "" Then
    MainErr = MainErr & "Text3 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text4.Text) = "" Then
    MainErr = MainErr & "Text4 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text5.Text) = "" Then
    MainErr = MainErr & "Text5 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text6.Text) = "" Then
    MainErr = MainErr & "Text6 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
If Trim(Text7.Text) = "" Then
    MainErr = MainErr & "Text7 is Empty Info." & vbCrLf
    GoTo ErrClear
End If
st:
reSendNum = reSendNum + 1
If reSendNum > 3 Then
    MainErr = MainErr & "已重试3次，仍无法正常发送邮件。怀疑是网络故障！" & vbCrLf
    GoTo ErrClear
End If
ErrinfoStr = ""
Text8.Text = ""
TIM = Timer
Winsock1.Close
'-----------连接服务器
Winsock1.Connect Text7.Text, 25
DETDATAS = ""
'-----------
Do Until InStr(DETDATAS, "220")
    If Timer - TIM > 30 Then GoTo st
    DoEvents
Loop
DETDATAS = ""
'----------------HELLO
TIM = Timer
Winsock1.SendData "EHLO " & Text1.Text & vbCrLf
Do Until InStr(DETDATAS, "250")
    If Timer - TIM > 30 Then GoTo st
    If InStr(DETDATAS, "550") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
   
    DoEvents
Loop
DETDATAS = ""
'-----------------AUTH 登录---------
TIM = Timer
Winsock1.SendData "AUTH LOGIN" & vbCrLf
Do Until InStr(DETDATAS, "334")
    If Timer - TIM > 30 Then GoTo st
    DoEvents
Loop
'-------------------'发送名字
TIM = Timer
DETDATAS = ""
Winsock1.SendData Base64En(Text1.Text) & vbCrLf
Do Until InStr(DETDATAS, "334")
    If Timer - TIM > 30 Then GoTo st
    DoEvents
Loop
'-------------------发送密码
TIM = Timer
DETDATAS = ""
Winsock1.SendData Base64En(Text2.Text) & vbCrLf
Do Until InStr(DETDATAS, "235")
    If Timer - TIM > 30 Then GoTo st
    If InStr(DETDATAS, "535") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    If InStr(DETDATAS, "502") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    DoEvents
Loop
'-----------------发信--
'-地址---------------
TIM = Timer
DETDATAS = ""
Winsock1.SendData "MAIL From: <" & Text6.Text & ">" & vbCrLf
Do Until InStr(DETDATAS, "250")
    If Timer - TIM > 30 Then GoTo st
    If InStr(DETDATAS, "550") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    If InStr(DETDATAS, "501") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    DoEvents
Loop
'---------
DETDATAS = ""
TIM = Timer
Winsock1.SendData "RCPT TO: <" & Text3.Text & ">" & vbCrLf
Do Until InStr(DETDATAS, "250")
    If Timer - TIM > 30 Then GoTo st
    If InStr(DETDATAS, "501") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    DoEvents
Loop
DETDATAS = ""
'-----------------------正文------------------
TIM = Timer
Winsock1.SendData "DATA" & vbCrLf
Do Until InStr(DETDATAS, "354")
    If Timer - TIM > 30 Then GoTo st
    If InStr(DETDATAS, "501") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    DoEvents
Loop
'-----------------邮件内容
TIM = Timer
DETDATAS = ""

    'Winsock1.SendData "From: " & Text6.Text & vbCrLf
    'Winsock1.SendData "To: " & Text3.Text & vbCrLf
'Winsock1.SendData " " & vbLf
    'Winsock1.SendData "Subject: " & Text4.Text & vbCrLf
'Winsock1.SendData " " & vbCrLf
    'Winsock1.SendData Text5.Text & vbCrLf
'Winsock1.SendData "SDADSAFSADF" & vbLf
'Winsock1.SendData vbLf
    'Pause 1
    'Winsock1.SendData "." & vbCrLf
    '---------------------------------=======以文件形式发送邮件 将制作好的邮件源文件发送出去。emailtest.txt
    FnfileNas = FreeFile
    Open App.Path + "\" + "email.bin" For Input As #FnfileNas
    Do While Not EOF(FnfileNas)
      Line Input #FnfileNas, TmpStr
      Winsock1.SendData TmpStr & vbCrLf
    Loop
    Close #FnfileNas

''---------------------构造邮件内容，并发送
'    TmpStr = "Date:" & Format(Date, "ddd , YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & " +0800" & vbCrLf & _
'            "From: " & Chr(34) & "jesseza" & Chr(34) & " <" & Text6.Text & ">" & vbCrLf & _
'            "To: " & Chr(34) & "jesseza" & Chr(34) & " <" & Text6.Text & ">" & vbCrLf & _
'            "Subject: Gushan Water Monitoring Station " & Format(Date, "YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & vbCrLf & _
'            "X-mailer: Foxmail 6, 15, 201, 23 " & vbCrLf & _
'            "" & vbCrLf & _
'             Format(Date, "YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & ", Internet is Connect OK." & vbCrLf & _
'            "" & vbCrLf & _
'             vbCrLf
'    TmpStr = TmpStr & vbCrLf
'    Winsock1.SendData TmpStr & vbCrLf


'‘－－－－－－－－
DETDATAS = ""
Winsock1.SendData vbCrLf & "." & vbCrLf'发送完毕，发送结束符号。。

Do Until InStr(DETDATAS, "250")
    If Timer - TIM > 90 Then GoTo st
    If InStr(DETDATAS, "451") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    If InStr(DETDATAS, "502") Then
      ErrinfoStr = ErrinfoStr & DETDATAS
      GoTo closeWS
    End If
    DoEvents
Loop
Winsock1.SendData "QUIT " & vbCrLf
'-----------------关闭
successOut = True
GoTo ZCGB
closeWS:
    successOut = False

ZCGB:
Winsock1.Close

Command1.Enabled = True
   
   
    If successOut Then
      Text9.Text = "发信成功 ：） "
    Else
      Text9.Text = "发信失败！！！"
      GoTo ErrClear
    End If
Exit Sub
ErrClear: '-------记录出错日志。
    Close #FnfileNas
    Close #nFno1
    Winsock1.Close
    If FileLen(App.Path & "\Email.log") > 500000 Then
      nFno2 = FreeFile
      Open App.Path & "\Email.log" For Output As #nFno2
            Print #nFno2, Format(Now, "YYYY-MM-DD HH:mm:SS") & "，错误日志已超过500K，删除前面的。"
      Close #nFno2
    End If
    nFno1 = FreeFile
    Open App.Path & "\Email.log" For Append As #nFno1
      Print #nFno1, Format(Now, "YYYY-MM-DD HH:mm:SS")
      If MainErr <> "" Then
            Print #nFno1, MainErr
      End If
      If Makefile <> "" Then
            Print #nFno1, Makefile
      End If
      If ErrinfoStr <> "" Then
            Print #nFno1, ErrinfoStr
      End If
    Close #nFno1
    Command1.Enabled = True
Exit Sub
Errcode:
    Resume ErrClear

End Sub

jessezappy 发表于 2011-8-10 11:47:43

上面的代码只是发送邮件的主过程，相信已经能说明问题了，如果需要我再发邮件包构造的那块代码出来，因为是2001年写的程序，今年正好要用到，所以翻出来改了一下，自动定时发送邮件，Winsock返回信息的检索还是用了原来比较弱智的方式，懒得改了，反正可以正常运行。

自己定义收发SMTP信息等等的都加上了，因为这个程序是一运行就发送一份预订好格式的邮件出去，所以图片就抓了个编辑模式的凑个数。

Tesla.Angela 发表于 2011-8-10 16:24:18

jessezappy 发表于 2011-8-10 11:47 static/image/common/back.gif
上面的代码只是发送邮件的主过程，相信已经能说明问题了，如果需要我再发邮件包构造的那块代码出来，因为是 ...

给个源码压缩包啊。。。
不然不知道你的代码的含义。。。

nbboy 发表于 2011-8-10 19:04:06

嗯 。vb还好有 winsock控件，比较简便。
另外一种方法就是自己填写格式，然后ws2_32!send.....

查看完整版本: [讨论]如何做一个邮件发送程序?