กระทู้เก่าบอร์ด อ.Yeadram
4,084 8
URL.หัวข้อ /
URL
ส่งเมล์ ผ่าน VBA ไม่ได้มี Message เตือน
เจอข้อความนี้ ต้องแก้ไข อย่างไร ครับ
A program is trying to automatically send e-mail on your behalf
แตกจากกระทู้ การส่งเมล์
http://www.thai-access.com/suphap.php?topic_id=1347
A program is trying to automatically send e-mail on your behalf
แตกจากกระทู้ การส่งเมล์
http://www.thai-access.com/suphap.php?topic_id=1347
8 Reply in this Topic. Dispaly 1 pages and you are on page number 1
2 @R10773
ไม่นะครับ ผมเคย SET ได้แต่ลืมไปแล้ว เอา Source ผมไปดีกว่า
ส่งได้
ลองดู ไม่ผ่าน Outlook
Public Function SendEmail(Optional ByVal SendTo As String = "", Optional ByVal SendCC As String = "", Optional ByVal SendBCC As String = "", Optional ByVal SendSubject As String = "", Optional ByVal SendBodyText As String = "", Optional ByVal SendAttach As String = "", Optional ByVal SendAttach1 As String = "", Optional ByVal SendAttach2 As String = "", Optional ByVal SendAttach3 As String = "")
'Optional ByVal PasswordOpen As String = ""
DoCmd.SetWarnings False
If Dir("c:\Autogen Report\EXCEL", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\EXCEL"
End If
If Dir("c:\Autogen Report\SNP", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\SNP"
End If
If Dir("c:\Autogen Report\PDF", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\PDF"
End If
On Error GoTo ErrCheck
Dim SubjectText, strAttach As String
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2 'Must use this to use Delivery Notification
Const cdoAnonymous = 0
Const cdoBasic = 1 ' clear text
Const cdoNTLM = 2 'NTLM
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay
Dim iCfg As Object
Dim iMsg As Object
Set iCfg = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
With iCfg.Fields
'Start SMTP Remote SErver
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Mail Server Name"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
'_________________________________________________ ___
'++Comment out Authentication++
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Email@mail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
'End SMTP Remote Server
.Update
'MsgBox "Config SMTP Server Pass"
End With
With iMsg
.From = "abc@mail.com"
'objEmail.To = strTo
If Trim(SendTo) <> "" Then .To = (SendTo)
If Trim(SendCC) <> "" Then .CC = (SendCC)
If Trim(SendBCC) <> "" Then .Bcc = (SendBCC)
'objEmail.Subject = strSubject
If Trim(SendSubject) <> "" Then .Subject = (SendSubject)
'objEmail.TextBody = strMessage
If Trim(SendBodyText) <> "" Then .TextBody = (SendBodyText)
If Trim(SendAttach) <> "" Then .AddAttachment (SendAttach)
If Trim(SendAttach1) <> "" Then .AddAttachment (SendAttach1)
If Trim(SendAttach2) <> "" Then .AddAttachment (SendAttach2)
If Trim(SendAttach3) <> "" Then .AddAttachment (SendAttach3)
Set .Configuration = iCfg
.Fields.Update
.Send
End With
ErrExit:
Set iMsg = Nothing
Set iCfg = Nothing
Exit Function
ErrCheck:
Select Case Err
Case -2146697203
MsgBox "Error No " & Err & " was generated by " & Err.Source & Chr(13) & Err.Description & Chr(13) & "Cannot Find Attach File"
Case -2147220973 ‘Cannot Connect to Server
MsgBox "Error No " & Err & " was generated by " & Err.Source & Chr(13) & Err.Description & Chr(13) & " Cannot Connect to Server "
Case -2147024894 ‘Cannot Find Attach File
MsgBox " Cannot Find Attach File."
Case 2024 Or 2302 Or 2282 ' Cannot find file or Folder
MsgBox "Cannot find file or Folder"
Resume Next
Case Else
MsgBox "Error No " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
End Select
Resume ErrExit
End Function
abc@mail.comEmail@mail.com[RED]password[/FONT]
ส่งได้
ลองดู ไม่ผ่าน Outlook
Public Function SendEmail(Optional ByVal SendTo As String = "", Optional ByVal SendCC As String = "", Optional ByVal SendBCC As String = "", Optional ByVal SendSubject As String = "", Optional ByVal SendBodyText As String = "", Optional ByVal SendAttach As String = "", Optional ByVal SendAttach1 As String = "", Optional ByVal SendAttach2 As String = "", Optional ByVal SendAttach3 As String = "")
'Optional ByVal PasswordOpen As String = ""
DoCmd.SetWarnings False
If Dir("c:\Autogen Report\EXCEL", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\EXCEL"
End If
If Dir("c:\Autogen Report\SNP", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\SNP"
End If
If Dir("c:\Autogen Report\PDF", vbDirectory) = "" Then
If Dir("c:\Autogen Report", vbDirectory) = "" Then MkDir "c:\Autogen Report"
MkDir "c:\Autogen Report\PDF"
End If
On Error GoTo ErrCheck
Dim SubjectText, strAttach As String
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2 'Must use this to use Delivery Notification
Const cdoAnonymous = 0
Const cdoBasic = 1 ' clear text
Const cdoNTLM = 2 'NTLM
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay
Dim iCfg As Object
Dim iMsg As Object
Set iCfg = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
With iCfg.Fields
'Start SMTP Remote SErver
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Mail Server Name"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
'_________________________________________________ ___
'++Comment out Authentication++
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Email@mail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
'End SMTP Remote Server
.Update
'MsgBox "Config SMTP Server Pass"
End With
With iMsg
.From = "abc@mail.com"
'objEmail.To = strTo
If Trim(SendTo) <> "" Then .To = (SendTo)
If Trim(SendCC) <> "" Then .CC = (SendCC)
If Trim(SendBCC) <> "" Then .Bcc = (SendBCC)
'objEmail.Subject = strSubject
If Trim(SendSubject) <> "" Then .Subject = (SendSubject)
'objEmail.TextBody = strMessage
If Trim(SendBodyText) <> "" Then .TextBody = (SendBodyText)
If Trim(SendAttach) <> "" Then .AddAttachment (SendAttach)
If Trim(SendAttach1) <> "" Then .AddAttachment (SendAttach1)
If Trim(SendAttach2) <> "" Then .AddAttachment (SendAttach2)
If Trim(SendAttach3) <> "" Then .AddAttachment (SendAttach3)
Set .Configuration = iCfg
.Fields.Update
.Send
End With
ErrExit:
Set iMsg = Nothing
Set iCfg = Nothing
Exit Function
ErrCheck:
Select Case Err
Case -2146697203
MsgBox "Error No " & Err & " was generated by " & Err.Source & Chr(13) & Err.Description & Chr(13) & "Cannot Find Attach File"
Case -2147220973 ‘Cannot Connect to Server
MsgBox "Error No " & Err & " was generated by " & Err.Source & Chr(13) & Err.Description & Chr(13) & " Cannot Connect to Server "
Case -2147024894 ‘Cannot Find Attach File
MsgBox " Cannot Find Attach File."
Case 2024 Or 2302 Or 2282 ' Cannot find file or Folder
MsgBox "Cannot find file or Folder"
Resume Next
Case Else
MsgBox "Error No " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
End Select
Resume ErrExit
End Function
abc@mail.comEmail@mail.com[RED]password[/FONT]
3 @R10821
นึกออกแล้วครับ
Set Mail default เป็น Outlook Express ครับ
แต่ Default mail มันจะเปลี่ยน ทุกครั้งที่ มีการ Update จาก Microsoft
ผมเลย เปลี่ยนมาใช้วิธี ส่ง ตรง แทน ครับ
Set Mail default เป็น Outlook Express ครับ
แต่ Default mail มันจะเปลี่ยน ทุกครั้งที่ มีการ Update จาก Microsoft
ผมเลย เปลี่ยนมาใช้วิธี ส่ง ตรง แทน ครับ
4 @R20335
ขออนุญาตขุดนะครับ พอดีกำลังหาทางทำอยู่ครับ
คืออยากให้ส่งอีเมลมาเตือน เมื่อพอเปิดหน้าฟอร์มที่มีการเตือน เช่นเตือนสินค้าจะหมด ก็ให้ส่งอีเมลมาแจ้งเราแบบนี้ครับผม
ส่งตรงๆโดยไม่ผ่านอะไรเลยได้ไหมครับ
คืออยากให้ส่งอีเมลมาเตือน เมื่อพอเปิดหน้าฟอร์มที่มีการเตือน เช่นเตือนสินค้าจะหมด ก็ให้ส่งอีเมลมาแจ้งเราแบบนี้ครับผม
ส่งตรงๆโดยไม่ผ่านอะไรเลยได้ไหมครับ
5 @R20337
วิธีที่ผมแนะนำในย่อหน้าที่ 3 ใช้ไม่ได้หรือ
6 @R20342
ผมไม่เข้าใจว่า จะต้องแก้ไขตรงไหนด้วยหรือเปล่าครับ
และมันต้องเอาโค้ดไปไว้ตรงไหน เรียกใช้ยังไงครับ
และมันต้องเอาโค้ดไปไว้ตรงไหน เรียกใช้ยังไงครับ
7 @R20343
ที่ผมเคยทำ ผมไม่ได้เขียนด้วย Microsoft Access นะครับ เพราะมันไม่เหมาะสมที่จะต้องให้ Access รันตลอดเวลาเพียงเพื่อรอเวลาจะคิวรี่ข้อมูลเพื่อส่งเป็นอีเมล์ ที่ผมทำก็คือเขียนเป็น VBScript บนเครื่อง Windows Server เพื่ออ่านฐานข้อมูลซึ่งอยู่บนเครื่องเซิฟเวอร์เช่นกัน แล้วเช็คว่าถ้าตรงเงื่อนไขก็ให้ส่งเมล์ไปยังบุคคลที่เกี่ยวข้อง ตย.ของโค้ดที่ผมใช้
Dim wEngine, DB, RS, SQL
Dim WshShell
Dim wReturn
Set WshShell = CreateObject("WScript.Shell")
Set wEngine = CreateObject("DAO.DBEngine.36")
Set DB = wEngine.OpenDatabase("MyDB.mdb")
SQL = "SELECT ข้อมุลที่ต้องการส่งเมล์"
Set RS = DB.OpenRecordset(SQL)
With RS
Do Until .EOF
wReturn = WshShell.Run("\sendemail -f email_account_ที่เป็นผู้ส่ง -t email_account_ผู้รับ -u Subject_ของเมล์ -o message-file=ไฟล์ที่เก็บเนื้อความในเมล์ -s ชื่อ_smtp_server -xu user_account_ของผู้มีสิทธิ์ใช้_smtp -xp รหัสผ่านของ_user_account_ของผู้มีสิทธิ์ใช้_smtp" , 0 , True)
.MoveNext
Loop
End With
RS.Close: Set RS = Nothing
สมมุติว่าตั้งชื่อไฟล์ของโค้ดนี้ว่า SendMail.vbs
แล้วก็สร้างไฟล์ SendMail.cmd ให้มีคำสั่ง cscript //B //Nologo SendMail.vbs
สุดท้ายก็ตั้ง WindowsTask Scheduler ให้เรียกใช้ SendMail.cmd ทำงานตามเวลาที่ตั้งไว้
ผมเองไม่เชี่ยวชาญทางด้าน system admin และ VBScript ก็ไม่รู้ว่ามันจะมีวิธีลัดสั้นกว่านี้ในการสร้าง command file เพื่อใส่ลง Scheduler หรือเปล่า เอาว่าดูไว้เป็นแนวทางแล้วกัน ส่วน VBScript มีคำสั่งอะไรบ้าง ก็หาในเวป Microsoft ได้เลยครับ
Dim wEngine, DB, RS, SQL
Dim WshShell
Dim wReturn
Set WshShell = CreateObject("WScript.Shell")
Set wEngine = CreateObject("DAO.DBEngine.36")
Set DB = wEngine.OpenDatabase("MyDB.mdb")
SQL = "SELECT ข้อมุลที่ต้องการส่งเมล์"
Set RS = DB.OpenRecordset(SQL)
With RS
Do Until .EOF
wReturn = WshShell.Run("\sendemail -f email_account_ที่เป็นผู้ส่ง -t email_account_ผู้รับ -u Subject_ของเมล์ -o message-file=ไฟล์ที่เก็บเนื้อความในเมล์ -s ชื่อ_smtp_server -xu user_account_ของผู้มีสิทธิ์ใช้_smtp -xp รหัสผ่านของ_user_account_ของผู้มีสิทธิ์ใช้_smtp" , 0 , True)
.MoveNext
Loop
End With
RS.Close: Set RS = Nothing
สมมุติว่าตั้งชื่อไฟล์ของโค้ดนี้ว่า SendMail.vbs
แล้วก็สร้างไฟล์ SendMail.cmd ให้มีคำสั่ง cscript //B //Nologo SendMail.vbs
สุดท้ายก็ตั้ง WindowsTask Scheduler ให้เรียกใช้ SendMail.cmd ทำงานตามเวลาที่ตั้งไว้
ผมเองไม่เชี่ยวชาญทางด้าน system admin และ VBScript ก็ไม่รู้ว่ามันจะมีวิธีลัดสั้นกว่านี้ในการสร้าง command file เพื่อใส่ลง Scheduler หรือเปล่า เอาว่าดูไว้เป็นแนวทางแล้วกัน ส่วน VBScript มีคำสั่งอะไรบ้าง ก็หาในเวป Microsoft ได้เลยครับ
8 @R20345
ขอบคุณอาจารย์ สันติสุข
ผมจะลองๆแกะๆดูครับผม
แต่เป็นไปได้สูงว่าน่าจะทำไม่ได้ห้าๆๆ จะลองๆดูครับ ^^
ผมจะลองๆแกะๆดูครับผม
แต่เป็นไปได้สูงว่าน่าจะทำไม่ได้ห้าๆๆ จะลองๆดูครับ ^^
Time: 0.3476s
สิ่งที่คิดว่าอาจจะพอทำได้ก็คือ (ผมยังไม่ได้ลองนะครับ) ไปหาโปรแกรมที่ส่ง email ตัวอื่นๆมาใช้แทน Outlook แล้วกำหนดให้โปรแกรมนั้นเป็น Default Email Client Program ครับ ส่วนวิธีการกำหนดนั้น คิดว่าแต่ละโปรแกรมจะมี option ให้ทำได้ คุณต้องไปหาเอง
อีกวิธีที่ผมใช้คือไปโหลด Command-Line Email Client Program ซึ่งเป็น Freeware มาจาก http://caspian.dotconf.net/menu/Software/SendEmail ผมเลือกใช้เวอร์ชั่นล่าสุดคือตัวที่เขียนว่า sendEmail-v155.zip (With TLS Support) (1.4mb) หลังจาก extract ไฟล์ที่ดาวโหลดมาแล้ว คุณก็จะได้ไฟล์ sendEmail.exe, sendEmail.pl และไฟล์ .TXT อีกสองสามไฟล์ ลองไปอ่านเอาเองนะครับว่าต้องกำหนด argument หรือ option อะไรเพื่อใช้ในการสั่งให้โปรแกรมนี้ทำงาน เมื่อรู้แล้ว เราก็ใช้ฟังก์ชั่น Shell("[drive\path]sendEmail.exe argument options.....") เพื่อสั่งให้ sendEmail.exe นี้ทำงานต่อไปครับ