ส่งเมล์ ผ่าน VBA ไม่ได้มี Message เตือน
กระทู้เก่าบอร์ด อ.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

8 Reply in this Topic. Dispaly 1 pages and you are on page number 1

1 @R10657
ข้อความนี้เกิดจาก Outlook Security Manage เตือนเราออกมาว่ามีใครกำลังจะส่ง email โดยอัตโนมัติ(จะด้วยวิธีใดก็ตาม) และเท่าที่ทราบ ความสามารถพิเศษนี้ไม่สามารถ disabled ได้ด้วยผู้ใช้เอง ต้องซื้อโปรแกรมที่ disabled มาจาก third party ครับ

สิ่งที่คิดว่าอาจจะพอทำได้ก็คือ (ผมยังไม่ได้ลองนะครับ) ไปหาโปรแกรมที่ส่ง 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 นี้ทำงานต่อไปครับ
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]
3 @R10821
นึกออกแล้วครับ

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 ได้เลยครับ
8 @R20345
ขอบคุณอาจารย์ สันติสุข
ผมจะลองๆแกะๆดูครับผม

แต่เป็นไปได้สูงว่าน่าจะทำไม่ได้ห้าๆๆ จะลองๆดูครับ ^^
@ ประกาศใช้งานเว็บบอร์ดใหม่ => บอร์ดเรียนรู้ Access สำหรับคนไทย
แล้วจะใส่ลิ้งอ้างอิงมาที่โพสต์เก่านี้หรือไม่ก็ตามสะดวกครับ
Time: 0.3476s