利用VBA自动保存outlook附件

创建VBA方法如下：

 

Public p As String '文件保存位置，也是解压文件存放位置
Public Sub SaveAttach(Item As Outlook.MailItem)
    p = "C:\Users\Administrator.TXV6HLXTU3ZW8KD\Desktop\"
    SaveAttachment Item, p, "*.rar"  '此处*.rar可以改成其他正则表达式
    ' MsgBox "附件已保存"
End Sub

' 保存附件
' path为保存路径，condition为附件名匹配条件
Private Sub SaveAttachment(ByVal Item As Object, path$, Optional condition$ = "*")
    Dim olAtt As Attachment
    Dim i As Integer
    Dim m As Long
    Dim s As String
    If Item.Attachments.Count > 0 Then
        For i = 1 To Item.Attachments.Count
            Set olAtt = Item.Attachments(i)
            '保存文件
            If olAtt.FileName Like condition Then
                olAtt.SaveAsFile path & olAtt.FileName
		'以下部分为解压rar文件，p为保存位置
                s = "C:\Program Files\WinRAR\WinRAR.exe" & " X " & path & olAtt.FileName & " " & p '注意找到解压软件位置
                m = Shell(s, vbHide)
            End If
        Next
    End If
    Set olAtt = Nothing
End Sub

在outlook中新建规则，选择动作为执行脚本，选择脚本为此方法，即可实现收到邮件后自动保存附件并解压到桌面。

 

保存附件代码

 

Sub 保存非标表格(mailitem As Outlook.mailitem)
    Dim olAtt As Attachment
    Set olAtt = mailitem.Attachments(1)
    olAtt.SaveAsFile "D:\baidu\Desktop\丝路非标邮件\非标\" & olAtt.FileName
End Sub

 

 

遍历文件夹获取正文HTML代码

 

Sub 遍历已有丝路()
    Dim NS As Outlook.NameSpace
    Dim folder As MAPIFolder
    Dim mailitem As mailitem
    Dim output, cmd, datetime As String
    Dim num, temp As Integer

    Set NS = Session.Application.GetNamespace("MAPI")
    Set folder = NS.GetDefaultFolder(olFolderInbox).Folders("丝路")
    num = folder.Items.Count
    temp = 0

    For i = 1 To num
        Set mailitem = folder.Items(i)
        If InStr(mailitem.Subject, "百度丝路运营数据报表") > 0 Then
            output = "D:\baidu\Desktop\丝路非标邮件\丝路\丝路邮件" & Right(mailitem.Subject, 10) & "_" & temp & ".txt"
            Open output For Output As #1
            Print #1, mailitem.HTMLBody
            '关闭文本文件
            Close #1
            temp = temp + 1
        End If
    Next

End Sub