Vba 在excel中使用宏发送邮件时，如何抑制Outlook警告_Vba_Excel_Outlook

Vba 在excel中使用宏发送邮件时，如何抑制Outlook警告

vba excel outlook

Vba 在excel中使用宏发送邮件时，如何抑制Outlook警告,vba,excel,outlook,Vba,Excel,Outlook,我正在尝试使用excel中的宏发送电子邮件但当我运行此代码时，我的邮件客户端（即MS Outlook）会显示类似于有人想代表您发送邮件。选择是或否是否有任何方法可以用来抑制该警告，以便发送电子邮件时不会出现任何问题？您需要使用赎回DLL来禁用该警告下载我创建了一种在机器上自动安装此DLL的方法，您可以尝试我知道的最好的方法是创建outlook应用程序项、创建邮件、显示邮件并使用sendkeys发送邮件（相当于键入alt s）缺点是sendkeys方法可能有点缺陷。为了使它更健壮

我正在尝试使用excel中的宏发送电子邮件

但当我运行此代码时，我的邮件客户端（即MS Outlook）会显示类似于

有人想代表您发送邮件。选择是或否

是否有任何方法可以用来抑制该警告，以便发送电子邮件时不会出现任何问题？

您需要使用赎回DLL来禁用该警告

下载

我创建了一种在机器上自动安装此DLL的方法，您可以尝试

我知道的最好的方法是创建outlook应用程序项、创建邮件、显示邮件并使用sendkeys发送邮件（相当于键入alt s）

缺点是sendkeys方法可能有点缺陷。为了使它更健壮，我让邮件项目的检查器（即它所在的窗口）在调用sendkeys之前立即激活它。代码如下所示：

Dim olApp As outlook.Application
Dim objNS As Outlook.Namespace
Dim objMail As Outlook.MailItem
Dim objSentItems As Outlook.MAPIFolder
Dim myInspector As Outlook.Inspector

'Check whether outlook is open, if it is use get object, if not use create object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    Set olApp = CreateObject("Outlook.Application")
End If

Set objNS = olApp.GetNamespace("MAPI")
objNS.Logon

'Prepare the mail object    
Set objMail = olApp.CreateItem(olMailItem)

With objMail
.To = <insert recipients name as string>
.Subject = <insert subject as string>
.Body = <insert message as string>
.Display   
End With

'Give outlook some time to display the message    
Application.Wait (Now + TimeValue("0:00:05"))

'Get a reference the inspector obj (the window the mail item is displayed in)
Set myInspector = objMail.GetInspector

'Activate the window that the mail item is in and use sendkeys to send the message
myInspector.Activate
SendKeys "%s", True

Dim olApp作为outlook.Application
将OBJN设置为Outlook.Namespace
将objMail设置为Outlook.MailItem
将objSentItems设置为Outlook.MAPIFolder
将myInspector设置为Outlook.Inspector
'检查outlook是否已打开，如果是，请使用get object，如果不是，请使用create object
出错时继续下一步
设置olApp=GetObject（，“Outlook.Application”）
错误转到0
如果olApp什么都不是，那么
设置olApp=CreateObject（“Outlook.Application”）
如果结束
Set objNS=olApp.GetNamespace（“MAPI”）
objNS.Logon
'准备邮件对象
Set objMail=olApp.CreateItem（olMailItem）
用objMail
.至=
.主题=
.正文=
.展示
以
'给outlook一些时间来显示邮件
Application.Wait（现在+时间值（“0:00:05”））
'从inspector obj（显示邮件项目的窗口）获取参考信息
设置myInspector=objMail.GetInspector
'激活邮件项目所在的窗口，并使用sendkeys发送邮件
我的检查员，激活
发送密钥“%s”，为真

我通常会用代码检查sent文件夹中的邮件数量是否增加，如果没有，我会让应用程序再次等待并重复最后2行代码，然后重新检查sent文件夹中的邮件数量是否增加。代码最多执行5次。第五次之后，会出现一个消息框，警告消息可能尚未发送

我从未发现这种方法在从excel发送消息时失败，尽管我曾经在我们的系统速度特别慢时看到警告消息，但在调查中发现消息已发送。

几年前，我在互联网上的某个地方找到了下面的代码。它会自动为您回答“是”

Option Compare Database
' Declare Windows' API functions
Private Declare Function RegisterWindowMessage _
        Lib "user32" Alias "RegisterWindowMessageA" _
        (ByVal lpString As String) As Long

 Private Declare Function FindWindow Lib "user32" _
            Alias "FindWindowA" (ByVal lpClassName As Any, _
            ByVal lpWindowName As Any) As Long


Private Declare Function SendMessage Lib "user32" _
        Alias "SendMessageA" (ByVal hwnd As Long, _
        ByVal wMsg As Long, ByVal wParam As Long, _
        lParam As Any) As Long

Function TurnAutoYesOn()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 1, 0)

End Function

Function TurnOffAutoYes()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 0, 0)
End Function


Function fEmailTest()

TurnAutoYesOn  '*** Add this before your email has been sent



Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
    .To = " <Receipient1@domain.com>;  <Receipient2@domain.com"
    .Subject = "Your Subject Here"
    .HTMLBody = "Your message body here"
    .Send
End With

TurnOffAutoYes '*** Add this after your email has been sent


End Function

选项比较数据库
“声明Windows”API函数
私有声明函数RegisterWindowMessage_
Lib“user32”别名“RegisterWindowMessageA”_
（ByVal lpString作为字符串）一样长
私有声明函数findwindowlib“user32”_
别名“FindWindowA”（ByVal lpClassName，如有）_
ByVal lpWindowName（如有）尽可能长
私有声明函数SendMessage Lib“user32”_
别名“SendMessageA”（ByVal hwnd，长度为_
ByVal wMsg尽可能长，ByVal wParam尽可能长_
lpram（如有）一样长
函数TurnAutoYesOn（）
暗淡无光
是的，很长
暗淡如长
uClickYes=RegisterWindowMessage（“单击是、暂停、恢复”）
wnd=FindWindow（“排他性”，0&）
Res=SendMessage（wnd，uClickYes，1,0）
端函数
功能关闭Autoyes（）
暗淡无光
是的，很长
暗淡如长
uClickYes=RegisterWindowMessage（“单击是、暂停、恢复”）
wnd=FindWindow（“排他性”，0&）
Res=SendMessage（wnd，uClickYes，0，0）
端函数
函数fEmailTest（）
TurnAutoYesOn'***在发送电子邮件之前添加此项
设置appOutLook=CreateObject（“Outlook.Application”）
设置mailookout=appOutLook.CreateItem（olMailItem）
使用MailOutLook
.To=“；由于宏未由受信任的发布者签名，因此将弹出该窗口。此列表位于Outlook设置中。您必须对宏进行签名，并将签名者输入到受信任的发布者列表中。或者全局允许未签名的宏。
一些选项：
使用最新的防病毒软件（Outlook将不会显示提示）
扩展MAPI（仅适用于C++或Delphi，不适用于VB脚本或.Net语言）。但是，您可以使用使用扩展MAPI但可从任何语言（包括VBS）访问的包装器
像这样的产品
有关讨论和可用选项列表，请参阅。添加到Julia Grant的答案中
和回答德索奇
当直接使用Julia代码时，我得到了错误RegisterWindowMessage
应通过将私有声明函数
替换为声明PtrSafe函数
在申报部分
Option Compare Database
' Declare Windows' API functions
Declare PtrSafe Function RegisterWindowMessage _
        Lib "user32" Alias "RegisterWindowMessageA" _
        (ByVal lpString As String) As Long

 Declare PtrSafe Function FindWindow Lib "user32" _
            Alias "FindWindowA" (ByVal lpClassName As Any, _
            ByVal lpWindowName As Any) As Long


Declare PtrSafe Function SendMessage Lib "user32" _
        Alias "SendMessageA" (ByVal hwnd As Long, _
        ByVal wMsg As Long, ByVal wParam As Long, _
        lParam As Any) As Long

Function TurnAutoYesOn()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 1, 0)

End Function

Function TurnOffAutoYes()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 0, 0)
End Function


Function fEmailTest()

TurnAutoYesOn  '*** Add this before your email has been sent



Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
    .To = " <Receipient1@domain.com>;  <Receipient2@domain.com"
    .Subject = "Your Subject Here"
    .HTMLBody = "Your message body here"
    .Send
End With

TurnOffAutoYes '*** Add this after your email has been sent


End Function

选项比较数据库
“声明Windows”API函数
声明PtrSafe函数寄存器Windows消息_
Lib“user32”别名“RegisterWindowMessageA”_
（ByVal lpString作为字符串）一样长
声明PtrSafe函数FindWindow Lib“user32”_
别名“FindWindowA”（ByVal lpClassName，如有）_
ByVal lpWindowName（如有）尽可能长
声明PtrSafe函数SendMessage Lib“user32”_
别名“SendMessageA”（ByVal hwnd，长度为_
ByVal wMsg尽可能长，ByVal wParam尽可能长_
lpram（如有）一样长
函数TurnAutoYesOn（）
暗淡无光
是的，很长
暗淡如长
uClickYes=RegisterWindowMessage（“单击是、暂停、恢复”）
wnd=FindWindow（“排他性”，0&）
Res=SendMessage（wnd，uClickYes，1,0）
端函数
功能关闭Autoyes（）
暗淡无光
是的，很长
暗淡如长
uClickYes=RegisterWindowMessage（“单击是、暂停、恢复”）
wnd=FindWindow（“排他性”，0&）
Res=SendMessage（wnd，uClickYes，0，0）
端函数
函数fEmailTest（）
TurnAutoYesOn'***在发送电子邮件之前添加此项
设置appOutLook=CreateObj
Option Explicit

 Private Const xlUp As Long = -4162

Sub SendEmailsFromExcel()

    Dim xlApp As Object

    Dim isEmailTo As String    ' Col A
    Dim isSubject As String    ' Col B
    Dim isMessage As String    ' Col C

    Dim i As Integer
    Dim objMsg As MailItem
    Set objMsg = Application.CreateItem(olMailItem)

    Dim emailsMatrix As Variant

    Dim objWB As Object
    Dim objWs As Object
    Dim FileStr As String

    FileStr = "C:\Users\...\Documents\EmailsInExcel.xlsx"

    Set xlApp = CreateObject("excel.application")

    With xlApp
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    Set objWB = xlApp.Workbooks.Open(FileStr)
    Set objWs = objWB.Sheets(1)

    ' Matrix load:  A - Email Address, B - Subject, C - Body
    emailsMatrix = objWs.Range("A1:C" & xlApp.Cells(objWs.Rows.Count, "A").End(xlUp).Row)

    objWB.Close

    Set objWB = Nothing
    xlApp.Quit
    Set xlApp = Nothing

'   Done getting Excel emails file.

    For i = 1 To UBound(emailsMatrix)
        isEmailTo = emailsMatrix(i, 1)
        isSubject = emailsMatrix(i, 2)
        isMessage = emailsMatrix(i, 3)


        objMsg.Recipients.Add isEmailTo
        objMsg.Subject = isSubject
        objMsg.Body = isMessage
        objMsg.Send
    Next i

End Sub