+ -
当前位置:首页 → 问答吧 → outlook exchange server有大小限制,我想用一个VBA实现规则的功能。

outlook exchange server有大小限制,我想用一个VBA实现规则的功能。

时间:2011-02-27

来源:互联网

利用outlook2003 vba 移动收到的邮件或会议通知到不同的指定文件夹
内,具体功能要求如下:在硬盘某分区建立一个Excel表 文件,第一列表头“发件人邮件地址”;第二列表头“发件人姓名”;第三列“文件夹名称”
当收到邮件、会议通知时触发VBA程序,如果发件人包含先前设置好的excel表内第一列或第二列某单元给的值,则将邮件自动移动到以该单元格右边单元格的值为名的outlook文件夹内。 请高手帮忙!

作者: safty_xu   发布时间: 2011-02-27

最好用EXCEL记录实现。
如果EXCEL结合实现不了,我想借用ACCESS+ADODB+SQL实现。但是以下代码中估计问题出在SQL语句,请帮忙指点。SQL语句可能无法应用senderemailaddress 及sendername,请高手指点!

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
     
     
     ' (1) default Inbox
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
     ' (2) only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    Dim fldr As Outlook.MAPIFolder
   
        Dim cnn As New ADODB.Connection
        Dim rs As New ADODB.Recordset
        Dim mydata As String
        Dim SQL As String
        Dim s As String
    If TypeName(item) = "MailItem" Then
        Set Msg = item
            x = Msg.SenderEmailAddress
        mydata = "D:\outlook规则.mdb"
        Set cnn = New ADODB.Connection  '建立与数据库的连接
        With cnn
            .Provider = "microsoft.jet.oledb.4.0"
            .Open mydata
        End With
            SQL = "select * from  rule   where 邮箱 LIKE '%" & Msg.SenderEmailAddress & "%' or 姓名 LIKE '%" & Msg.SenderName & "%'"
            rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
            If rs.RecordCount <> 0 Then
               rs.movefirst
               Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders(rs.Fields("归类文件夹"))
               Msg.Move fldr
            rs.Close
            Set rs = Nothing
            Set cnn = Nothing
            End If
    End If
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

附件

outlook规则.rar(7.75 KB)

2011-2-27 21:58, 下载次数: 0

作者: safty_xu   发布时间: 2011-02-27