[VB6] การส่งเมล์ด้วย CDO (Collaboration Data Objects) พร้อมกับการแนบไฟล์
http://www.g2gnet.com/webboard/images/vb6/SendMailCDO.pngวันนี้แอดมินก็จะมาแนะนำวิธีในการส่งอีเมล์จากโค้ด 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 รายละเอียดต่างๆก็คงต้องไปศึกษาหาความรู้เพิ่มเติมกันเองครับผม ...
http://www.g2gnet.com/webboard/images/vb6/SendMailCDORef.png
Project --> References ... Microsoft CDO for Windows 200 Library ...
ฟังค์ชั่นในส่วนของการส่งเมล์ ... โดยจะรีเทิร์นค่า True หากส่งเมล์เสร็จสมบูรณ์, False คือไม่สำเร็จ
' / --------------------------------------------------------------------------------
' / Function to send mail.
Public Function SendMail() As Boolean
' / --------------------------------------------------------------------------------
'// Trap Error
On Error GoTo ErrHandler
Dim CdoMail As CDO.Message
Set CdoMail = New CDO.Message
With CdoMail
.Configuration.Fields(cdoSMTPServer) = txtServer.Text
.Configuration.Fields(cdoSMTPServerPort) = Val(txtPort.Text)
.Configuration.Fields(cdoSMTPUseSSL) = chkSSL.Value
.Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
.Configuration.Fields(cdoSendUserName) = txtUsername.Text
.Configuration.Fields(cdoSendPassword) = txtPassword.Text
.Configuration.Fields(cdoSMTPConnectionTimeout) = 30
.Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
.Configuration.Fields.Update
CdoMail.To = Trim$(txtToMail.Text)
CdoMail.From = Trim$(txtFromMail.Text)
CdoMail.Subject = Trim$(txtSubject.Text)
CdoMail.TextBody = Trim$(txtMessage.Text)
End With
'// Attachment
If Trim$(txtAttachFile.Text) <> vbNullString Then CdoMail.AddAttachment (txtAttachFile.Text)
'// Sending mail.
CdoMail.Send
'// Clear memory
Set CdoMail = Nothing
'// Send Complete.
SendMail = True
Exit Function
ErrHandler:
Msg = "Error Number: " & Err.Number & vbCrLf & Err.Description
SendMail = False
End Function
โค้ดในการส่งเมล์ด้วย VB6 แบบเต็ม ...
' / --------------------------------------------------------------------------------
' / Developer : Mr.Surapon Yodsanga (Thongkorn Tubtimkrob)
' / eMail : thongkorn@hotmail.com
' / URL: http://www.g2gnet.com (Khon Kaen - Thailand)
' / Facebook: https://www.facebook.com/g2gnet (For Thailand)
' / Facebook: https://www.facebook.com/commonindy (Worldwide)
' / Purpose : Send mail using CDO with Visual Basic 6.0
' / Microsoft Visual Basic 6.0 (SP6)
' /
' / This is open source code under @CopyLeft by Thongkorn Tubtimkrob.
' / You can modify and/or distribute without to inform the developer.
' / --------------------------------------------------------------------------------
'// References ... Microsoft CDO for Windows 2000 library.
Dim Msg As String
' / --------------------------------------------------------------------------------
' / Function to send mail.
Public Function SendMail() As Boolean
' / --------------------------------------------------------------------------------
'// Trap Error
On Error GoTo ErrHandler
Dim CdoMail As CDO.Message
Set CdoMail = New CDO.Message
With CdoMail
.Configuration.Fields(cdoSMTPServer) = txtServer.Text
.Configuration.Fields(cdoSMTPServerPort) = Val(txtPort.Text)
.Configuration.Fields(cdoSMTPUseSSL) = chkSSL.Value
.Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
.Configuration.Fields(cdoSendUserName) = txtUsername.Text
.Configuration.Fields(cdoSendPassword) = txtPassword.Text
.Configuration.Fields(cdoSMTPConnectionTimeout) = 30
.Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
.Configuration.Fields.Update
CdoMail.To = Trim$(txtToMail.Text)
CdoMail.From = Trim$(txtFromMail.Text)
CdoMail.Subject = Trim$(txtSubject.Text)
CdoMail.TextBody = Trim$(txtMessage.Text)
End With
'// Attachment
If Trim$(txtAttachFile.Text) <> vbNullString Then CdoMail.AddAttachment (txtAttachFile.Text)
'// Sending mail.
CdoMail.Send
'// Clear memory
Set CdoMail = Nothing
'// Send Complete.
SendMail = True
Exit Function
ErrHandler:
Msg = "Error Number: " & Err.Number & vbCrLf & Err.Description
SendMail = False
End Function
' / --------------------------------------------------------------------------------
Private Sub cmdSend_Click()
Dim blnStatus As Boolean
Dim CtrlAs Control
'// Validate data before to sending them exclude attachments.
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is TextBox Then
If Trim$(Ctrl.Text) = vbNullString And LCase$(Ctrl.Name) <> "txtattachfile" Then
lblStatus.Caption = "Error: You must to enter all the field, exclude attachments."
Exit Sub
End If
End If
Next
Frame1.Enabled = False
Frame2.Enabled = False
cmdSend.Enabled = False
lblStatus.Caption = "Sending data ..."
'// Sending Mail
blnStatus = SendMail
Frame1.Enabled = True
Frame2.Enabled = True
cmdSend.Enabled = True
'// Sending Status.
lblStatus.Caption = IIf(blnStatus = True, "Message sent successfully.", Msg)
End Sub
Private Sub chkSSL_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
Sendkeys "{TAB}"
End If
End Sub
' / --------------------------------------------------------------------------------
' / Attatch File.
Private Sub cmdBrowseFile_Click()
' / --------------------------------------------------------------------------------
'On Error Resume Next
'// Trap Error
On Error GoTo ErrHandler
With dlgOpenFile
.DialogTitle = " Graphics File Format " '// Title Bar
.Filter = "Picture or Image (*.jpg;*.gif;*.bmp;*.png)|*.jpg;*.gif;*.bmp;*.png" '// Image types
.InitDir = App.Path
.CancelError = True
.ShowOpen
If .FileName <> "" Then txtAttachFile.Text = .FileName
End With
If txtAttachFile = "" Then Exit Sub
ExitProc:
Exit Sub
ErrHandler:
Select Case Err.Number
Case 32755
Err.Clear
Resume ExitProc
Case Else
MsgBox Err.Number & vbCrLf & Err.Description
End Select
End Sub
Private Sub Form_Load()
'// SMTP Setting
Me.txtServer.Text = "smtp.gmail.com"
Me.txtUsername.Text = "youraccount@gmail.com" '<-- CHANGE
Me.txtPassword.Text = "password" '<-- CHANGE
Me.txtPort.Text = "465"
'// Body
Me.txtFromName.Text = "G2GNet"'<-- CHANGE
Me.txtFromMail.Text = "From@yourmail.com" '<-- CHANGE
Me.txtToMail.Text = "To@someonemail.com" '<-- CHANGE
Me.txtSubject.Text = "·´Êͺ¡ÒÃÊè§ÍÕàÁÅì " & Now()
Me.txtMessage.Text = "This is a test Email from Visual Basic 6.0 on " & Now
End Sub
'/Solve problem SendKeys not work in Windows 8+
Public Sub Sendkeys(Text As String, Optional Wait As Boolean = False)
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.shell")
WshShell.Sendkeys Text, Wait
Set WshShell = Nothing
End Sub
Private Sub txtAttachFile_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtFromMail_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtFromName_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtPassword_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtPort_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtServer_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtSubject_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtToMail_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
Private Sub txtUsername_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Sendkeys "{TAB}"
End If
End Sub
ดาวน์โหลดโค้ดต้นฉบับ VB6 ได้ที่นี่ ...
หน้า:
[1]