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

praijna

我也写过一段这样的 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 这个已经无法下载了，那位兄弟有的话可以上传来这里吗？不胜感激！

五彩缤纷

Outlook Security Manager 控件无法下载，那位兄弟有的话，挂一个上来啊！

五彩缤纷

Outlook Security Manager 控件无法下载，那位兄弟有的话，挂一个上来啊！

mymlady

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

该放在哪个位置

一直提示编译错误

达人求教

谢谢

mymlady

提供Outlook Security Manager下载

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

2008-10-20 22:28 上传

点击文件名下载附件

[此贴子已经被作者于2008-10-20 22:28:55编辑过]

sunyujie

SDFASDGFASDF

csb2000cn

我采用Long_III前辈的代码，因为用regsvr32注册时失败，提示找不到指定的模块
结果也是运行到tmp.connectto object时，出现了如下框框：
C:\Documents and Settings\zhusu1\My Documents\error.jpg
图片上传不了,大意就是 outlook security manager is not found
是我下载的OSMAX.OCX文件有问题还是操作上有问题
  例如放错了地方
请路过的高手多多指教!!谢谢

[ 本帖最后由 csb2000cn 于 2008-12-17 17:57 编辑 ]

csb2000cn

终于能用了,原来是regsvr32不支持长文件名
把路径名改为 regsvr32 c:\Progra~1\Common~1\Outloo~1\osmax.ocx即可注册成功
要重启之后才能生效
不过一波刚平,一波又起,如何才能让 .to 和.cc 之后可以支持多个收件人,用array好像是不行滴

Long_III

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

我的另外的处理方法可参考链接 [分享]自动发送邮件避免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

谢谢分享！

[此贴子已经被作者于2008-7-30 13:44:55编辑过]