ไปได้โค๊ดที่อาจารย์ลงไว้ใน Youtube ผมเก็บเมลล์เพื่อนๆ ไว้ถ้าต้องการ Loop ชื่อเมลล์ลงในบรรทัด .To = Nz(ฟิลด์เก็บเมลล์)
ต้องทำโค๊ดยังไงครับ หรือมีโค๊ดอื่นมั๊ยครับ สำหรับการส่งเมลล์เป็นกลุ่มๆOn Error GoTo Err:
Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String
'late binding
Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")
' load all default configurations
mailConfig.Load -1
Set fields = mailConfig.fields
'Set All Email Properties
With NewMail
.Sender = Forms!mainmail!mygmail
.From = Nz(Forms!mainmail!mydetail)
.To = Nz(Me.fmail) '<<<<<<<<< ต้องการ Loop ลงตรงนี้ <<<<<<<<<<<<<<<<<<<< .CC = Nz(Forms!mainmail!sumnao1)
.BCC = Nz(Forms!mainmail!sumnao2)
.Subject = Nz(Forms!mainmail!ruang1)
.BodyPart.Charset = "utf-8"
.HTMLbody = "<Font Face=AngsanaUPC Size=" & Forms!mainmail!fontSiz & " Color=" & Forms!mainmail!seefon & ">" & Forms!mainmail!bui1 & Nz(Forms!mainmail!detail2) & Forms!mainmail!bui2 & "</Font>"
If Not IsNull(Forms!mainmail!fi1) Then
If Dir(Forms!mainmail!fi1) <> "" Then
.Addattachment Nz(Forms!mainmail!fi1)
End If
End If
If Not IsNull(Forms!mainmail!fi2) Then
If Dir(Forms!mainmail!fi2) <> "" Then
.Addattachment Nz(Forms!mainmail!fi2)
End If
End If
If Not IsNull(Forms!mainmail!fi3) Then
If Dir(Forms!mainmail!fi3) <> "" Then
.Addattachment Nz(Forms!mainmail!fi3)
End If
End If
End With
msConfigURL = "
http://schemas.microsoft.com/cdo/configuration"
With fields
.Item(msConfigURL & "/smtpusessl") = True
.Item(msConfigURL & "/smtpauthenticate") = 1
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
.Item(msConfigURL & "/sendusername") = Forms!mainmail!mygmail
.Item(msConfigURL & "/sendpassword") = DLookup("mypass", "mypass")
.Update
End With
NewMail.Configuration = mailConfig
NewMail.Send
Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfig = Nothing
End
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select
Resume Exit_Err
แสดงกระทู้
