如何用VBA做一个Weekly的Email Alert



  • 我司有一些公用邮箱,我想通过VBA来实现每周给我发送一个Weekly收到了哪些邮件; 哪些邮件回复了; 哪些邮件还没有回复的Summary。

    目前实现了100%;效果大致如下:

    每周Outlook会自动给我自己的邮箱发下面的Email
    d393468b-2efb-470b-bb60-52dba55c553c-image.png

    如何实现的呢,可以分成几步

    1. 通过VBA来收集某个时间段内收到的邮件

    首先要在VBA Reference里面勾选下面这个选项
    5cc6a70d-d6fd-48ec-b92c-16860d79c1f6-image.png
    然后我在Excel里面设定了时间范围
    3bbe41bc-f7e0-4034-aaca-841ecda018c5-image.png

    因为我们的Outlook里面会同时用到好几个账号,所以账号名也写在了Excel里。

    然后运行下面代码的accTopFolder

    
    Option Explicit
    '这是一个全局变量,用来控制什么时候所有想要的Email都已经成功输出
    Dim EndofEmails As Integer
    
    ------------------------------------------------------------------------------------------------------------------------------------------
    Sub accTopFolder()
    
    
    
    Application.ScreenUpdating = False
    
    Dim oAccount As Account
    Dim ns As Namespace
    Dim fldr As Folder
    Dim item As Object, ItemRow As Long
    Dim inbx As Folder
    
    Set ns = GetNamespace("MAPI")
    
    'Emails是我用来输出Email信息的工作表,这里是清空之前的内容
    Emails.Cells.Range("A2").Resize(999, 10).ClearContents
    
    For Each oAccount In Session.Accounts
    
        Debug.Print vbCr & "oAccount: " & oAccount
        '
        For Each fldr In ns.Folders
        ' Shows all the names so you can replace "test"
            Debug.Print " top folder: " & fldr.Name
           'Range("EmailBox").Value是我想要操作的Email的账号名
            If fldr = Range("EmailBox").Value Then
                Set inbx = fldr.Folders("Inbox")
                ItemRow = 2
                ' 按照Email 收到的时间排序
                inbx.Items.Sort "[ReceivedTime]"
                EndofEmails = 0
                For Each item In inbx.Items
                    Call getMyemails(item, Emails.Cells(ItemRow, 1), Range("timestart").Value, Range("timeend").Value)
                    ItemRow = ItemRow + 1
                    If EndofEmails = 1 Then
                        MsgBox "Retrived all the emails"
                        Exit Sub
                    End If
                Next
                Exit For
            End If
        Next
    Next
    
    Set inbx = Nothing
    Set ns = Nothing
    
    Application.ScreenUpdating = True
    
    End Sub
    
    
    --------------------------------------------------------------------------------------------------------
    Private Sub getMyemails(obMail, target As Range, timestart, timeend)
    Dim status As Integer
    If obMail.ReceivedTime >= timestart And obMail.ReceivedTime <= timeend Then
        target = obMail.SenderEmailAddress
        'if starts with/O=EXCHANG, it is internal email
        If Left(obMail.SenderEmailAddress, 10) = "/O=EXCHANG" Then
         target = "Internal"
        End If
        target.Offset(0, 1) = obMail.To
        target.Offset(0, 2) = obMail.Subject
        target.Offset(0, 3) = obMail.ReceivedTime
        target.Offset(0, 4) = obMail.Body
        Debug.Print obMail.Body
        status = obMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003")
        If status = 104 Then
            target.Offset(0, 5) = "Forwarded"
        ElseIf status = 103 Then
            target.Offset(0, 5) = "Replied"
        Else
            target.Offset(0, 5) = "Unhandled"
        End If
        
        If target <> "Internal" And target.Offset(0, 5) = "Unhandled" Then
            target.Offset(0, 6) = 1
        Else
            target.Offset(0, 6) = 0
        End If
    Else
        EndofEmails = 1
    End If
    
    End Sub
    
    


  • 成功运行后,就会在excel里面输出一个如下的Summary
    18dc7d29-22d7-4fcc-a5a8-fa1534d42ca2-image.png

    然后我用了Excel公式生成了下面的文字总结
    36f04c93-ff06-4a2a-a0e8-868150c3288f-image.png

    最后用下面的代码把这些内容发给我自己

    ThisWorkbook.Save
    
        Dim xStrFile As String
        Dim xFilePath As String
        Dim xFileDlg As FileDialog
        Dim xFileDlgItem As Variant
        Dim xOutApp As Outlook.Application
        Dim xMailOut As Outlook.MailItem
        Application.ScreenUpdating = False
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailOut = xOutApp.CreateItem(olMailItem)
    
            With xMailOut
                .BodyFormat = olFormatRichText
                .To = "keke's email"
                .Subject = "Email Alerts"
                .HTMLBody = Range("EmailBody").Value '我生成的文字总结
                .Attachments.Add ThisWorkbook.FullName
                .Send 'OR.display
            End With
    
        Set xMailOut = Nothing
        Set xOutApp = Nothing
        Application.ScreenUpdating = True
    End Sub
    
    
    


  • 下一步是让这个VBA每周五自动运行;可以通过VBScript和Windows Task Scheduler 来实现。目前还没有写好代码,打算先让实习生每周帮我点下Excel运行哈哈。Excel如下,大家可以拿去玩~
    Email reminder Public.zip



  • 更新:已经完全实现自动化了

    写了一个VBS文件,现在双击这个VBA文件就可以运行上面的宏

    'Input Excel File's Full Path
      ExcelFilePath = "My email Path"
    
    'Input Module/Macro name within the Excel File
      MacroPath = "Auto.AutoAll" '这里是运行的宏所在的Module+ 宏名称
    
    'Create an instance of Excel
      Set ExcelApp = CreateObject("Excel.Application")
    
    'Do you want this Excel instance to be visible?
      ExcelApp.Visible = False 'or "False"
    
    'Prevent any App Launch Alerts (ie Update External Links)
      ExcelApp.DisplayAlerts = False
    
    'Open Excel File
      Set wb = ExcelApp.Workbooks.Open(ExcelFilePath)
    
    'Execute Macro Code
      ExcelApp.Run MacroPath
    
    'Save Excel File (if applicable)
      wb.Save
    
    'Reset Display Alerts Before Closing
      ExcelApp.DisplayAlerts = True
    
    'Close Excel File
      wb.Close
    
    'End instance of Excel
      ExcelApp.Quit
    
    'Leaves an onscreen message!
      MsgBox "Your Automated Task successfully ran at " & TimeValue(Now), vbInformation
    

    然后找到Windows自带的Task Scheduler程序

    d9cc9026-6bdb-471e-9aa3-0b097ea58dd6-image.png

    这里点击Create Basic Task,按照指示操作即可

    32453763-1caa-490c-aa9a-8906e12d0aed-image.png




Log in to reply