[原创]在做Outlook VBA开发时如何禁止OUTLOOK的安全提示

我也写过一段这样的 VBA ，使用了 SendKeys，也可以不出现这个提示，以下是程序，使用条件是 XP, Outlook 2003，公司局域网：

Sub SendEmail()
  Dim OutlookApp As Object
  Dim MItem As Object
  Dim cell As Range
  Dim Subj As String
  Dim EmailAddr As String
  Dim Recipient As String
  Dim Bonus As String
  Dim Msg As String
 
  Set OutlookApp = CreateObject("Outlook.Application")
  Subj = "HUA ME WAVE SOLDERING TEAM " & Worksheets("Print").Range("I1")
  EmailTo = "HUA ME Supervisor; HUA WorkCell Managers"
  EmailCC = "HUA ME Wave Soldering"
  Bonus = "\\huaenpc007\Team OT\" & Worksheets("Print").Range("I1") & ".xls"
  Msg = "Dear All： " & Recipient & vbCrLf & vbCrLf
  Msg = Msg & "本周加班安排如附件所示，请查阅！" & vbCrLf & vbCrLf
  Msg = Msg & "Hua Me Wave Soldering Team" & vbCrLf
  Msg = Msg & "BR"
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
        .To = EmailTo
        .cc = EmailCC
        .Subject = Subj
        .Body = Msg
        .Attachments.Add Bonus
        .Display
        'NOTE: To actually send the emails, use .Send instead of .Display
        '.Send
      End With
      Application.Wait (Now + TimeValue("0:00:02"))
      SendKeys "%s", True
            End Sub

Outlook Security Manager 这个已经无法下载了，那位兄弟有的话可以上传来这里吗？不胜感激！

Private Sub cmdSend_Click()
    Call AutoSendMail("send")
End Sub

Private Sub cmdDraft_Click()
    Call AutoSendMail("save")
End Sub

Sub AutoSendMail(sFlag)

   
    Dim xlsObj As Excel.Application
    Dim myOlapp As Outlook.Application
    Dim sRcvrStr As String
    Dim sRcvr As String
    Dim sAccount As String
   
   
    On Error GoTo ErrorHandler
   
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(5)
    Set xlsObj = GetObject(, "Excel.Application")
   
     i = 6
    Do While (xlsObj.Worksheets(2).Cells(i, 2).Value <> "")
        Set myforward = myFolder.Items.Add
        With xlsObj.Worksheets(2)
       
               myforward.Subject = .Cells(i, 4).Text & "薪资发放通知单 - " & .Cells(i, 6).Text
       
        sBody1 = "您好！工资已到帐，请核查以下工资条信息。" & vbCrLf
        
        sBody2 = vbCrLf & "             【薪资发放通知单】" & vbCrLf & vbCrLf & _
            "姓名: " & .Cells(i, 6).Text & vbCrLf & _
            "部门: " & .Cells(i, 3).Text & vbCrLf & vbCrLf & _
            "薪资                         金额(RMB) " & vbCrLf & _
            "---------------------------------------" & vbCrLf & _
            "月 固 定 薪:                 " & .Cells(i, 8).Text & vbCrLf & _
            "月 度 奖 金:                 " & .Cells(i, 9).Text & vbCrLf & _
            "客服考核工资:                " & .Cells(i, 10).Text & vbCrLf & _
            "加   班  费:                 " & .Cells(i, 11).Text & vbCrLf & _
            "其       它 :                " & .Cells(i, 17).Text & vbCrLf & _
            "考勤-- 迟到:                -" & .Cells(i, 18).Text & vbCrLf & _
            "考勤-- 事假:                -" & .Cells(i, 19).Text & vbCrLf & _
            "考勤-- 病假:                -" & .Cells(i, 20).Text & vbCrLf & _
            "扣  其   它:                -" & .Cells(i, 21).Text & vbCrLf & _
            "---------------------------------------" & vbCrLf & _
            "应 付 工 资:                 " & .Cells(i, 22).Text & vbCrLf
            sBody3 = vbCrLf & _
            "代扣                         " & vbCrLf & _
            "---------------------------------------" & vbCrLf & _
            "代 扣 个 税:                -" & .Cells(i, 23).Text & vbCrLf & _
            "代 扣 社 保:                -" & .Cells(i, 24).Text & vbCrLf & _
            "扣  借   款:                -" & .Cells(i, 25).Text & vbCrLf & _
            "---------------------------------------" & vbCrLf & _
            "代 扣 合 计:                -" & .Cells(i, 26).Text & vbCrLf & vbCrLf & _
            .Cells(i, 27).Text & "                 " & .Cells(i, 32).Text & vbCrLf & _
            "本期到帐金额:                " & .Cells(i, 29).Text & vbCrLf & _
            "------------------------------------------------------" & vbCrLf & _
            .Cells(i, 30).Text & vbCrLf & _
                 .Cells(i, 31).Text & vbCrLf & _
            "------------------------------------------------------" & vbCrLf 
            
        
        sBody4 = "                                                          财务部" & vbCrLf & _
            "                                                             " & Date & vbCrLf
          
               

        myforward.Body = sBody1 & sBody2 & sBody3 & sBody4
           
        sAccount = .Cells(i, 7).Text & "@abc.com" & "(" & .Cells(i, 6) & ")"
        myforward.Recipients.Add sAccount
       
        If (sFlag = "send") Then
            myforward.Send
        Else
            myforward.Save
        End If
       
        i = i + 1
        End With
    Loop

ErrorHandler:
    If (Err.Number < 0) Then
        MsgBox (Err.Description & " " & sAccount)
    End If
    Resume Next
   
End Sub
   

Private Sub CommandButton1_Click()

End Sub

如果我的源代码如上

引用

Function DisablePrompt(byref object)
 Dim tmp
 Set tmp = CreateObject("addinexpress.outlooksecuritymanager")
 tmp.ConnectTo(object)
 tmp.DisableOOMWarnings = True
 tmp.DisableCDOWarnings = True
 tmp.DisableSMAPIWarnings = True
End Function

该放在哪个位置

一直提示编译错误

达人求教

谢谢

提供Outlook Security Manager下载

WbcdEoNi.rar (244.75 KB, 下载次数: 588)

2008-10-20 22:28 上传

点击文件名下载附件

一直没留意这边的帖子，原来有和我同样问题的。

我的另外的处理方法可参考链接 [分享]自动发送邮件避免Outlook的安全提示方法之二-Redemption

http://club.excelhome.net/viewthread.php?tid=340964&px=0

经测试，运行OK，

没有注册这两个文件，直接在EXCEL里引用osmax.ocx文件，代码如下，

Sub test_hjs()
    Dim ObjOL As Object, itmNewMail As Object, itmNewMail_Copy As Object
    Dim olNS As Object, dfrFdr As Object
   
        Set ObjOL = CreateObject("Outlook.Application")
        DisablePrompt ObjOL
        Set itmNewMail = ObjOL.CreateItem(olMailItem)
       
        With itmNewMail
            .Subject = "IP test 123456xxx_345"
        '.Body = Body
            .To = "hjsong_8116@163.com"
            .send
        End With
       
        Set ObjOL = Nothing
        Set itmNewMail = Nothing
End Sub

Function DisablePrompt(ByRef object) 'http://club.excelhome.net/dispbbs.asp?boardid=22&replyid=724252&id=199798&page=1&skin=0&Star=1
    Dim Tmp
    Set Tmp = CreateObject("addinexpress.outlooksecuritymanager")
    Tmp.ConnectTo object
    Tmp.DisableOOMWarnings = True
    Tmp.DisableCDOWarnings = True
    Tmp.DisableSMAPIWarnings = True
End Function

谢谢分享！