如何用VBA做一个Weekly的Email Alert

Mengkelyu

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

目前实现了100%；效果大致如下：

每周Outlook会自动给我自己的邮箱发下面的Email

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

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

首先要在VBA Reference里面勾选下面这个选项

然后我在Excel里面设定了时间范围

因为我们的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

Mengkelyu

成功运行后，就会在excel里面输出一个如下的Summary

然后我用了Excel公式生成了下面的文字总结

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

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

Mengkelyu

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

Mengkelyu

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

写了一个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程序

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

Mengkelyu

Email reminder public.zip