IBM Rational 系统开发最佳实践工具包	WebSphere MQ 最佳实践 TOP 15

Excel VBA 发邮件(A program is trying to automatically send e-mail on your behalf)

楼主jara（一怒拔剑）2006-03-17 13:17:48 在 VB / VBA 提问

Public Sub test()
Application.ScreenUpdating = False

Dim mailaddress As String
Dim i As Integer

Dim objOL As Object
Dim itmNewMail As Object

For i = 1 To 1
Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)

mailaddress = Cells(i, 1)
With itmNewMail
.To = mailaddress
.Subject = "test subject"
.Body = "test VBA"
.Send

Set objOL = Nothing
Set itmNewMail = Nothing
End With
Next i

Application.ScreenUpdating = True
End Sub

以上程序从一个excel文件中第一行第一列中取出邮件地址，并发送邮件
但是每次发的时候都会出现outlook的提示框：
A program is trying to automatically send e-mail on your behalf
Do you want to allow this?
要点yes才能发送，有什么办法可以去掉这个框吗？
或者自动点yes
问题点数：100、回复次数：15Top

1 楼titihao（）回复于 2006-03-17 15:29:17 得分 10

xlApp.Application.DisplayAlerts = False

你试着加上上述代码看行不行？可以去掉提示窗口的。Top

2 楼faysky2（出来混，迟早是要还嘀）回复于 2006-03-17 23:10:33 得分 10

思路：
发送邮件时，用FindWindow不停地检测是否有提示窗口，如果找到窗口，则向它上面的确定按钮发送Click事件，成功后，停止检测Top

3 楼jara（一怒拔剑）回复于 2006-03-18 10:23:38 得分 0

谢谢楼上两位，因为我没学过VB VBA也是照样画葫芦刚学的
能不能给我解释一下。

xlApp.Application.DisplayAlerts = False 加在哪里呢，怎么我加上去运行通不过呢？
FindWindow怎么用？可不可以写给我看一下
谢谢
Top

4 楼jiangsheng（蒋晟.Net[MVP]）回复于 2006-03-18 11:19:17 得分 10

http://support.microsoft.com/kb/327657/zh-cnTop

5 楼jiangsheng（蒋晟.Net[MVP]）回复于 2006-03-18 11:20:09 得分 0

http://support.microsoft.com/kb/q264130/Top

6 楼jara（一怒拔剑）回复于 2006-03-18 14:14:24 得分 0

我用的是2003，楼上的办法没用啊Top

7 楼jara（一怒拔剑）回复于 2006-03-18 14:15:25 得分 0

大家不用拿这个message 去google里查，我都查过了Top

8 楼jara（一怒拔剑）回复于 2006-03-27 19:57:20 得分 0

顶一下Top

9 楼faysky2（出来混，迟早是要还嘀）回复于 2006-03-27 22:46:34 得分 20

试了一下，Click没发送成功，把代码帖出来大家分析：

vb:一个窗体Form1，一个定时器Timer1
代码（粘上代码后，生成sendClick.exe，放到C盘下）：

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function SetFocusApi Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Const GW_HWNDLAST = 1
Private Const BM_CLICK = &HF5
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const MK_LBUTTON = &H1

Private Sub Form_Load()
Me.Visible = False
Timer1.Interval = 100
Timer1.Enabled = True
End Sub

Private Sub BTNclick(ByVal mhwnd As Long)
Dim Tid1 As Long, Tid2 As Long, pid As Long
Tid1 = GetWindowThreadProcessId(mhwnd, pid)
Tid2 = App.ThreadID
Call AttachThreadInput(Tid1, Tid2, True)

SetFocusApi mhwnd
'在按钮相对坐标(1,1)处点击
SendMessage mhwnd, WM_LBUTTONDOWN, MK_LBUTTON, ByVal &H10002
SendMessage mhwnd, WM_LBUTTONUP, MK_LBUTTON, ByVal &H10002
End Sub

Private Sub Timer1_Timer()
Dim whwnd As Long, btnHwnd As Long
whwnd = FindWindow("#32770", "Microsoft Office Outlook")
'MsgBox wHwnd
btnHwnd = FindWindowEx(whwnd, 0, "Button", vbNullString)
btnHwnd = GetWindow(btnHwnd, GW_HWNDLAST) '经测试，用GW_HWNDLAST得到的是Yes按钮的句柄
Debug.Print IsWindowEnabled(btnHwnd)
If IsWindowEnabled(btnHwnd) Then '如果Yes按钮的Enabled已经为True，则模拟Click
BTNclick btnHwnd
' SendMessage btnHwnd, BM_CLICK, 0, 0 '用SendMessage也没成功
' MsgBox "已经发送"
Timer1.Enabled = False
Unload Me
End If
End Sub

'******************************
'VBA的代码：
Public Sub test()
Application.ScreenUpdating = False

Dim mailaddress As String
Dim i As Integer
Dim TID As Long

Dim objOL As Object
Dim itmNewMail As Object

For i = 1 To 1
Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)

mailaddress = Cells(i, 1)
With itmNewMail
.To = mailaddress
.Subject = "test subject"
.Body = "test VBA"
Shell "c:\sendClick.exe" '调用C盘的 sendClick.exe
.Send
Set objOL = Nothing
Set itmNewMail = Nothing
End With
Next i

Application.ScreenUpdating = True
End Sub

很奇怪，如果是对一般的MsgBox的按钮发送Click都成功，但就是对OutLook的提示框的却不起作用，不知道怎么回事
Top

10 楼rainstormmaster（暴风雨 v2.0）回复于 2006-03-29 09:45:27 得分 10

//很奇怪，如果是对一般的MsgBox的按钮发送Click都成功，但就是对OutLook的提示框的却不起作用，不知道怎么回事

这个不好说，可能的原因是outlook对有关消息进行了反拦截Top

11 楼faysky2（出来混，迟早是要还嘀）回复于 2006-03-29 11:16:26 得分 10

谢谢老大的指点

如果用SendMessage发送BM_CLICK消息，而不用 BTNclick btnHwnd 发送，在弹出提示框后，点一下它（点在提示框窗体上），则可以发送成功，而用 BTNclick btnHwnd 发送，即使点了窗体也不成功

搞不明白了Top

12 楼rainstormmaster（暴风雨 v2.0）回复于 2006-03-29 14:49:14 得分 10

你说的现象看起来好象是SetFocusApi mhwnd这句没有执行成功Top

13 楼rainstormmaster（暴风雨 v2.0）回复于 2006-03-29 14:50:55 得分 20

另外，解决这类问题我通常都是用多线程或者CBT钩子解决Top

14 楼jara（一怒拔剑）回复于 2006-04-03 14:40:26 得分 0

谢谢各位高人，太深奥了，不懂
谁能给我个final solutionTop

15 楼jara（一怒拔剑）回复于 2006-05-03 10:05:13 得分 0

没人知道？Top