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

马大哈

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

jessezappy

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

jessezappy

去年老马搬家，硬是找不到论坛入口了，还好今天闲的无聊，搜索我自己的ID号又找到老马的紫水晶了；因此顺便发下我2001年做的那个Email发送程序，这个程序是可以附件编码后发送的。

1. Private Sub Command1_Click()
   
2. Dim TIM As Long
   
3. Dim FnfileNas As Integer, TmpStr As String, successOut As Boolean
   
4. Dim nFno1 As Integer, nFno2 As Integer, ErrinfoStr As String
   
5. Dim reSendNum As Integer
   
6. On Error GoTo Errcode
   
7. reSendNum = 0
   
8. Command1.Enabled = False
   
9. Call SendFJ
   
10. 
    
11. If Makefile <> "" Then
    
12.     '--------出错，记录日志
    
13.     GoTo ErrClear
    
14. End If
    
15. 
    
16. If Trim(Text1.Text) = "" Then
    
17.     MainErr = MainErr & "Text1 is Empty Info." & vbCrLf
    
18.     GoTo ErrClear
    
19. End If
    
20. If Trim(Text2.Text) = "" Then
    
21.     MainErr = MainErr & "Text2 is Empty Info." & vbCrLf
    
22.     GoTo ErrClear
    
23. End If
    
24. If Trim(Text3.Text) = "" Then
    
25.     MainErr = MainErr & "Text3 is Empty Info." & vbCrLf
    
26.     GoTo ErrClear
    
27. End If
    
28. If Trim(Text4.Text) = "" Then
    
29.     MainErr = MainErr & "Text4 is Empty Info." & vbCrLf
    
30.     GoTo ErrClear
    
31. End If
    
32. If Trim(Text5.Text) = "" Then
    
33.     MainErr = MainErr & "Text5 is Empty Info." & vbCrLf
    
34.     GoTo ErrClear
    
35. End If
    
36. If Trim(Text6.Text) = "" Then
    
37.     MainErr = MainErr & "Text6 is Empty Info." & vbCrLf
    
38.     GoTo ErrClear
    
39. End If
    
40. If Trim(Text7.Text) = "" Then
    
41.     MainErr = MainErr & "Text7 is Empty Info." & vbCrLf
    
42.     GoTo ErrClear
    
43. End If
    
44. st:
    
45. reSendNum = reSendNum + 1
    
46. If reSendNum > 3 Then
    
47.     MainErr = MainErr & "已重试3次，仍无法正常发送邮件。怀疑是网络故障！" & vbCrLf
    
48.     GoTo ErrClear
    
49. End If
    
50. ErrinfoStr = ""
    
51. Text8.Text = ""
    
52. TIM = Timer
    
53. Winsock1.Close
    
54. '-----------连接服务器
    
55. Winsock1.Connect Text7.Text, 25
    
56. DETDATAS = ""
    
57. '-----------
    
58. Do Until InStr(DETDATAS, "220")
    
59.     If Timer - TIM > 30 Then GoTo st
    
60.     DoEvents
    
61. Loop
    
62. DETDATAS = ""
    
63. '----------------HELLO
    
64. TIM = Timer
    
65. Winsock1.SendData "EHLO " & Text1.Text & vbCrLf
    
66. Do Until InStr(DETDATAS, "250")
    
67.     If Timer - TIM > 30 Then GoTo st
    
68.     If InStr(DETDATAS, "550") Then
    
69.         ErrinfoStr = ErrinfoStr & DETDATAS
    
70.         GoTo closeWS
    
71.     End If
    
72.    
    
73.     DoEvents
    
74. Loop
    
75. DETDATAS = ""
    
76. '-----------------AUTH 登录---------
    
77. TIM = Timer
    
78. Winsock1.SendData "AUTH LOGIN" & vbCrLf
    
79. Do Until InStr(DETDATAS, "334")
    
80.     If Timer - TIM > 30 Then GoTo st
    
81.     DoEvents
    
82. Loop
    
83. '-------------------'发送名字
    
84. TIM = Timer
    
85. DETDATAS = ""
    
86. Winsock1.SendData Base64En(Text1.Text) & vbCrLf
    
87. Do Until InStr(DETDATAS, "334")
    
88.     If Timer - TIM > 30 Then GoTo st
    
89.     DoEvents
    
90. Loop
    
91. '-------------------发送密码
    
92. TIM = Timer
    
93. DETDATAS = ""
    
94. Winsock1.SendData Base64En(Text2.Text) & vbCrLf
    
95. Do Until InStr(DETDATAS, "235")
    
96.     If Timer - TIM > 30 Then GoTo st
    
97.     If InStr(DETDATAS, "535") Then
    
98.         ErrinfoStr = ErrinfoStr & DETDATAS
    
99.         GoTo closeWS
    
100.     End If
     
101.     If InStr(DETDATAS, "502") Then
     
102.         ErrinfoStr = ErrinfoStr & DETDATAS
     
103.         GoTo closeWS
     
104.     End If
     
105.     DoEvents
     
106. Loop
     
107. '-----------------发信--
     
108. '-地址---------------
     
109. TIM = Timer
     
110. DETDATAS = ""
     
111. Winsock1.SendData "MAIL From: <" & Text6.Text & ">" & vbCrLf
     
112. Do Until InStr(DETDATAS, "250")
     
113.     If Timer - TIM > 30 Then GoTo st
     
114.     If InStr(DETDATAS, "550") Then
     
115.         ErrinfoStr = ErrinfoStr & DETDATAS
     
116.         GoTo closeWS
     
117.     End If
     
118.     If InStr(DETDATAS, "501") Then
     
119.         ErrinfoStr = ErrinfoStr & DETDATAS
     
120.         GoTo closeWS
     
121.     End If
     
122.     DoEvents
     
123. Loop
     
124. '---------
     
125. DETDATAS = ""
     
126. TIM = Timer
     
127. Winsock1.SendData "RCPT TO: <" & Text3.Text & ">" & vbCrLf
     
128. Do Until InStr(DETDATAS, "250")
     
129.     If Timer - TIM > 30 Then GoTo st
     
130.     If InStr(DETDATAS, "501") Then
     
131.         ErrinfoStr = ErrinfoStr & DETDATAS
     
132.         GoTo closeWS
     
133.     End If
     
134.     DoEvents
     
135. Loop
     
136. DETDATAS = ""
     
137. '-----------------------正文------------------
     
138. TIM = Timer
     
139. Winsock1.SendData "DATA  " & vbCrLf
     
140. Do Until InStr(DETDATAS, "354")
     
141.     If Timer - TIM > 30 Then GoTo st
     
142.     If InStr(DETDATAS, "501") Then
     
143.         ErrinfoStr = ErrinfoStr & DETDATAS
     
144.         GoTo closeWS
     
145.     End If
     
146.     DoEvents
     
147. Loop
     
148. '-----------------邮件内容
     
149. TIM = Timer
     
150. DETDATAS = ""
     
151. 
     
152.     'Winsock1.SendData "From: " & Text6.Text & vbCrLf
     
153.     'Winsock1.SendData "To: " & Text3.Text & vbCrLf
     
154. 'Winsock1.SendData " " & vbLf
     
155.     'Winsock1.SendData "Subject: " & Text4.Text & vbCrLf
     
156. 'Winsock1.SendData " " & vbCrLf
     
157.     'Winsock1.SendData Text5.Text & vbCrLf
     
158. 'Winsock1.SendData "SDADSAFSADF" & vbLf
     
159. 'Winsock1.SendData vbLf
     
160.     'Pause 1
     
161.     'Winsock1.SendData "." & vbCrLf
     
162.     '---------------------------------=======以文件形式发送邮件 将制作好的邮件源文件发送出去。emailtest.txt
     
163.     FnfileNas = FreeFile
     
164.     Open App.Path + "" + "email.bin" For Input As #FnfileNas
     
165.     Do While Not EOF(FnfileNas)
     
166.         Line Input #FnfileNas, TmpStr
     
167.         Winsock1.SendData TmpStr & vbCrLf
     
168.     Loop
     
169.     Close #FnfileNas
     
170. 
     
171. ''---------------------构造邮件内容，并发送
     
172. '    TmpStr = "Date:" & Format(Date, "ddd , YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & " +0800" & vbCrLf & _
     
173. '            "From: " & Chr(34) & "jesseza" & Chr(34) & " <" & Text6.Text & ">" & vbCrLf & _
     
174. '            "To: " & Chr(34) & "jesseza" & Chr(34) & " <" & Text6.Text & ">" & vbCrLf & _
     
175. '            "Subject: Gushan Water Monitoring Station " & Format(Date, "YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & vbCrLf & _
     
176. '            "X-mailer: Foxmail 6, 15, 201, 23 [cn]" & vbCrLf & _
     
177. '            "" & vbCrLf & _
     
178. '             Format(Date, "YYYY-MM-DD") & Format(Timer, " HH:mm:SS") & ", Internet is Connect OK." & vbCrLf & _
     
179. '            "" & vbCrLf & _
     
180. '             vbCrLf
     
181. '    TmpStr = TmpStr & vbCrLf
     
182. '    Winsock1.SendData TmpStr & vbCrLf
     
183. 
     
184. 
     
185. '‘－－－－－－－－
     
186. DETDATAS = ""
     
187. Winsock1.SendData vbCrLf & "." & vbCrLf  '发送完毕，发送结束符号。。
     
188. 
     
189. Do Until InStr(DETDATAS, "250")
     
190.     If Timer - TIM > 90 Then GoTo st
     
191.     If InStr(DETDATAS, "451") Then
     
192.         ErrinfoStr = ErrinfoStr & DETDATAS
     
193.         GoTo closeWS
     
194.     End If
     
195.     If InStr(DETDATAS, "502") Then
     
196.         ErrinfoStr = ErrinfoStr & DETDATAS
     
197.         GoTo closeWS
     
198.     End If
     
199.     DoEvents
     
200. Loop
     
201. Winsock1.SendData "QUIT " & vbCrLf
     
202. '-----------------关闭
     
203. successOut = True
     
204. GoTo ZCGB
     
205. closeWS:
     
206.     successOut = False
     
207. 
     
208. ZCGB:
     
209. Winsock1.Close
     
210. 
     
211. Command1.Enabled = True
     
212.    
     
213.    
     
214.     If successOut Then
     
215.         Text9.Text = "发信成功 ：） "
     
216.     Else
     
217.         Text9.Text = "发信失败！！！"
     
218.         GoTo ErrClear
     
219.     End If
     
220. Exit Sub
     
221. ErrClear: '-------记录出错日志。
     
222.     Close #FnfileNas
     
223.     Close #nFno1
     
224.     Winsock1.Close
     
225.     If FileLen(App.Path & "\Email.log") > 500000 Then
     
226.         nFno2 = FreeFile
     
227.         Open App.Path & "\Email.log" For Output As #nFno2
     
228.             Print #nFno2, Format(Now, "YYYY-MM-DD HH:mm:SS") & "，错误日志已超过500K，删除前面的。"
     
229.         Close #nFno2
     
230.     End If
     
231.     nFno1 = FreeFile
     
232.     Open App.Path & "\Email.log" For Append As #nFno1
     
233.         Print #nFno1, Format(Now, "YYYY-MM-DD HH:mm:SS")
     
234.         If MainErr <> "" Then
     
235.             Print #nFno1, MainErr
     
236.         End If
     
237.         If Makefile <> "" Then
     
238.             Print #nFno1, Makefile
     
239.         End If
     
240.         If ErrinfoStr <> "" Then
     
241.             Print #nFno1, ErrinfoStr
     
242.         End If
     
243.     Close #nFno1
     
244.     Command1.Enabled = True
     
245. Exit Sub
     
246. Errcode:
     
247.     Resume ErrClear
     
248. 
     
249. End Sub

复制代码

jessezappy

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

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

Tesla.Angela

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

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

nbboy

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