[VB6] การส่งเมล์ด้วย CDO (Collaboration Data Objects) พร้อมกับการแนบไฟล์

thongkorn

วันนี้แอดมินก็จะมาแนะนำวิธีในการส่งอีเมล์จากโค้ด Visual Basic 6.0 ด้วยการใช้ CDO (Collaboration Data Objects) ชื่อเต็มของไลบรารีที่เราจะใช้คือ Microsoft CDO for Windows 2000 Library ซึ่งเราต้องทำการ Add References เข้ามาก่อนด้วยล่ะครับ มีอีกคำที่อยากจะแนะนำให้รู้จักคือ SMTP หรือ Simple Mail Transfer Protocol มันคือ มาตรฐานบนอินเทอร์เน็ตสำหรับการรับส่ง Email หรือจะเรียกว่า Protocol ในการส่งเมล์ก็ว่าได้ ในโค้ดตัวอย่างนี้ที่รันทดสอบผ่านแอดมินใช้ SMTP ของ GMAIL และใช้ Port หมายเลข 465 รายละเอียดต่างๆก็คงต้องไปศึกษาหาความรู้เพิ่มเติมกันเองครับผม ...


Project --> References ... Microsoft CDO for Windows 200 Library ...


ฟังค์ชั่นในส่วนของการส่งเมล์ ... โดยจะรีเทิร์นค่า True หากส่งเมล์เสร็จสมบูรณ์, False คือไม่สำเร็จ

1. ' / --------------------------------------------------------------------------------
   
2. ' / Function to send mail.
   
3. Public Function SendMail() As Boolean
   
4. ' / --------------------------------------------------------------------------------
   
5.       
   
6.     '// Trap Error
   
7.     On Error GoTo ErrHandler
   
8.    
   
9.     Dim CdoMail As CDO.Message
   
10.     Set CdoMail = New CDO.Message
    
11.     With CdoMail
    
12.         .Configuration.Fields(cdoSMTPServer) = txtServer.Text
    
13.         .Configuration.Fields(cdoSMTPServerPort) = Val(txtPort.Text)
    
14.         .Configuration.Fields(cdoSMTPUseSSL) = chkSSL.Value
    
15.         .Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
    
16.         .Configuration.Fields(cdoSendUserName) = txtUsername.Text
    
17.         .Configuration.Fields(cdoSendPassword) = txtPassword.Text
    
18.         .Configuration.Fields(cdoSMTPConnectionTimeout) = 30
    
19.         .Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
    
20.         .Configuration.Fields.Update
    
21.         CdoMail.To = Trim$(txtToMail.Text)
    
22.         CdoMail.From = Trim$(txtFromMail.Text)
    
23.         CdoMail.Subject = Trim$(txtSubject.Text)
    
24.         CdoMail.TextBody = Trim$(txtMessage.Text)
    
25.     End With
    
26.     '// Attachment
    
27.     If Trim$(txtAttachFile.Text) <> vbNullString Then CdoMail.AddAttachment (txtAttachFile.Text)
    
28.     '// Sending mail.
    
29.     CdoMail.Send
    
30.     '// Clear memory
    
31.     Set CdoMail = Nothing
    
32.     '// Send Complete.
    
33.     SendMail = True
    
34.     Exit Function
    
35.          
    
36. ErrHandler:
    
37.     Msg = "Error Number: " & Err.Number & vbCrLf & Err.Description
    
38.     SendMail = False
    
39. End Function

คัดลอกไปที่คลิปบอร์ด

โค้ดในการส่งเมล์ด้วย VB6 แบบเต็ม ...

1. ' / --------------------------------------------------------------------------------
   
2. ' / Developer : Mr.Surapon Yodsanga (Thongkorn Tubtimkrob)
   
3. ' / eMail : thongkorn@hotmail.com
   
4. ' / URL: http://www.g2gnet.com (Khon Kaen - Thailand)
   
5. ' / Facebook: https://www.facebook.com/g2gnet (For Thailand)
   
6. ' / Facebook: https://www.facebook.com/commonindy (Worldwide)
   
7. ' / Purpose : Send mail using CDO with Visual Basic 6.0
   
8. ' / Microsoft Visual Basic 6.0 (SP6)
   
9. ' /
   
10. ' / This is open source code under @CopyLeft by Thongkorn Tubtimkrob.
    
11. ' / You can modify and/or distribute without to inform the developer.
    
12. ' / --------------------------------------------------------------------------------
    
13. 
    
14. '// References ... Microsoft CDO for Windows 2000 library.
    
15. 
    
16. Dim Msg As String
    
17. 
    
18. ' / --------------------------------------------------------------------------------
    
19. ' / Function to send mail.
    
20. Public Function SendMail() As Boolean
    
21. ' / --------------------------------------------------------------------------------
    
22.       
    
23.     '// Trap Error
    
24.     On Error GoTo ErrHandler
    
25.    
    
26.     Dim CdoMail As CDO.Message
    
27.     Set CdoMail = New CDO.Message
    
28.     With CdoMail
    
29.         .Configuration.Fields(cdoSMTPServer) = txtServer.Text
    
30.         .Configuration.Fields(cdoSMTPServerPort) = Val(txtPort.Text)
    
31.         .Configuration.Fields(cdoSMTPUseSSL) = chkSSL.Value
    
32.         .Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
    
33.         .Configuration.Fields(cdoSendUserName) = txtUsername.Text
    
34.         .Configuration.Fields(cdoSendPassword) = txtPassword.Text
    
35.         .Configuration.Fields(cdoSMTPConnectionTimeout) = 30
    
36.         .Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
    
37.         .Configuration.Fields.Update
    
38.         CdoMail.To = Trim$(txtToMail.Text)
    
39.         CdoMail.From = Trim$(txtFromMail.Text)
    
40.         CdoMail.Subject = Trim$(txtSubject.Text)
    
41.         CdoMail.TextBody = Trim$(txtMessage.Text)
    
42.     End With
    
43.     '// Attachment
    
44.     If Trim$(txtAttachFile.Text) <> vbNullString Then CdoMail.AddAttachment (txtAttachFile.Text)
    
45.     '// Sending mail.
    
46.     CdoMail.Send
    
47.     '// Clear memory
    
48.     Set CdoMail = Nothing
    
49.     '// Send Complete.
    
50.     SendMail = True
    
51.     Exit Function
    
52.          
    
53. ErrHandler:
    
54.     Msg = "Error Number: " & Err.Number & vbCrLf & Err.Description
    
55.     SendMail = False
    
56. End Function
    
57. 
    
58. ' / --------------------------------------------------------------------------------
    
59. Private Sub cmdSend_Click()
    
60.     Dim blnStatus As Boolean
    
61.     Dim Ctrl  As Control
    
62.     '// Validate data before to sending them exclude attachments.
    
63.     For Each Ctrl In Me.Controls
    
64.         If TypeOf Ctrl Is TextBox Then
    
65.             If Trim$(Ctrl.Text) = vbNullString And LCase$(Ctrl.Name) <> "txtattachfile" Then
    
66.                 lblStatus.Caption = "Error: You must to enter all the field, exclude attachments."
    
67.                 Exit Sub
    
68.             End If
    
69.         End If
    
70.     Next
    
71.    
    
72.     Frame1.Enabled = False
    
73.     Frame2.Enabled = False
    
74.     cmdSend.Enabled = False
    
75.     lblStatus.Caption = "Sending data ..."
    
76.     '// Sending Mail
    
77.     blnStatus = SendMail
    
78.     Frame1.Enabled = True
    
79.     Frame2.Enabled = True
    
80.     cmdSend.Enabled = True
    
81.     '// Sending Status.
    
82.     lblStatus.Caption = IIf(blnStatus = True, "Message sent successfully.", Msg)
    
83.    
    
84. End Sub
    
85. 
    
86. Private Sub chkSSL_KeyDown(KeyCode As Integer, Shift As Integer)
    
87.     If KeyCode = 13 Then
    
88.         Sendkeys "{TAB}"
    
89.     End If
    
90. End Sub
    
91. 
    
92. ' / --------------------------------------------------------------------------------
    
93. ' / Attatch File.
    
94. Private Sub cmdBrowseFile_Click()
    
95. ' / --------------------------------------------------------------------------------
    
96.     'On Error Resume Next
    
97. 
    
98.     '// Trap Error
    
99.     On Error GoTo ErrHandler
    
100.     With dlgOpenFile
     
101.         .DialogTitle = " Graphics File Format " '// Title Bar
     
102.         .Filter = "Picture or Image (*.jpg;*.gif;*.bmp;*.png)|*.jpg;*.gif;*.bmp;*.png"   '// Image types
     
103.         .InitDir = App.Path
     
104.         .CancelError = True
     
105.         .ShowOpen
     
106.         If .FileName <> "" Then txtAttachFile.Text = .FileName
     
107.     End With
     
108.    
     
109.     If txtAttachFile = "" Then Exit Sub
     
110. 
     
111. ExitProc:
     
112.     Exit Sub
     
113. 
     
114. ErrHandler:
     
115.     Select Case Err.Number
     
116.         Case 32755
     
117.             Err.Clear
     
118.             Resume ExitProc
     
119.         Case Else
     
120.             MsgBox Err.Number & vbCrLf & Err.Description
     
121.         End Select
     
122. End Sub
     
123. 
     
124. Private Sub Form_Load()
     
125.     '// SMTP Setting
     
126.     Me.txtServer.Text = "smtp.gmail.com"
     
127.     Me.txtUsername.Text = "youraccount@gmail.com"   '<-- CHANGE
     
128.     Me.txtPassword.Text = "password"    '<-- CHANGE
     
129.     Me.txtPort.Text = "465"
     
130.     '// Body
     
131.     Me.txtFromName.Text = "G2GNet"  '<-- CHANGE
     
132.     Me.txtFromMail.Text = "From@yourmail.com" '<-- CHANGE
     
133.     Me.txtToMail.Text = "To@someonemail.com" '<-- CHANGE
     
134.     Me.txtSubject.Text = "·´Êͺ¡ÒÃÊè§ÍÕàÁÅì " & Now()
     
135.     Me.txtMessage.Text = "This is a test Email from Visual Basic 6.0 on " & Now
     
136. End Sub
     
137. 
     
138. '/  Solve problem SendKeys not work in Windows 8+
     
139. Public Sub Sendkeys(Text As String, Optional Wait As Boolean = False)
     
140.     Dim WshShell As Object
     
141.     Set WshShell = CreateObject("Wscript.shell")
     
142.     WshShell.Sendkeys Text, Wait
     
143.     Set WshShell = Nothing
     
144. End Sub
     
145. 
     
146. Private Sub txtAttachFile_KeyPress(KeyAscii As Integer)
     
147.     If KeyAscii = 13 Then
     
148.         KeyAscii = 0
     
149.         Sendkeys "{TAB}"
     
150.     End If
     
151. End Sub
     
152. 
     
153. Private Sub txtFromMail_KeyPress(KeyAscii As Integer)
     
154.     If KeyAscii = 13 Then
     
155.         KeyAscii = 0
     
156.         Sendkeys "{TAB}"
     
157.     End If
     
158. End Sub
     
159. 
     
160. Private Sub txtFromName_KeyPress(KeyAscii As Integer)
     
161.     If KeyAscii = 13 Then
     
162.         KeyAscii = 0
     
163.         Sendkeys "{TAB}"
     
164.     End If
     
165. End Sub
     
166. 
     
167. Private Sub txtPassword_KeyPress(KeyAscii As Integer)
     
168.     If KeyAscii = 13 Then
     
169.         KeyAscii = 0
     
170.         Sendkeys "{TAB}"
     
171.     End If
     
172. End Sub
     
173. 
     
174. Private Sub txtPort_KeyPress(KeyAscii As Integer)
     
175.     If KeyAscii = 13 Then
     
176.         KeyAscii = 0
     
177.         Sendkeys "{TAB}"
     
178.     End If
     
179. End Sub
     
180. 
     
181. Private Sub txtServer_KeyPress(KeyAscii As Integer)
     
182.     If KeyAscii = 13 Then
     
183.         KeyAscii = 0
     
184.         Sendkeys "{TAB}"
     
185.     End If
     
186. End Sub
     
187. 
     
188. Private Sub txtSubject_KeyPress(KeyAscii As Integer)
     
189.     If KeyAscii = 13 Then
     
190.         KeyAscii = 0
     
191.         Sendkeys "{TAB}"
     
192.     End If
     
193. End Sub
     
194. 
     
195. Private Sub txtToMail_KeyPress(KeyAscii As Integer)
     
196.     If KeyAscii = 13 Then
     
197.         KeyAscii = 0
     
198.         Sendkeys "{TAB}"
     
199.     End If
     
200. End Sub
     
201. 
     
202. Private Sub txtUsername_KeyPress(KeyAscii As Integer)
     
203.     If KeyAscii = 13 Then
     
204.         KeyAscii = 0
     
205.         Sendkeys "{TAB}"
     
206.     End If
     
207. End Sub

คัดลอกไปที่คลิปบอร์ด

ดาวน์โหลดโค้ดต้นฉบับ VB6 ได้ที่นี่ ...