Question

我有一个应该转到outlook文件夹的代码，并计算当周每个日期有多少封电子邮件。

但此刻它似乎没有正确阅读！

上周的数据以及代码所包含的内容如下：

monday: 21 in folder - counts 10
tuesday: 10 - 7
wednesday: 10 -13
thursday: 9 - 11
friday: 2 - 1

这是代码：

  ' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim arrEmailDates()

' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders("Estates").Folders("Bookings")
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    Exit Sub
End If

' Put ReceivedTimes in array
EmailCount = objFolder.Items.Count
For iCount = 1 To EmailCount
    With objFolder.Items(iCount)
        ReDim Preserve arrEmailDates(iCount - 1)
        arrEmailDates(iCount - 1) = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
    End With
Next iCount

' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

' Count the emails dates equal to active cell
Sheets("test email count").Range("e2").Select
Do Until IsEmpty(ActiveCell)

    DateCount = 0
    myDate = ActiveCell.Value

    For i = 0 To UBound(arrEmailDates) - 1
        If arrEmailDates(i) = myDate Then DateCount = DateCount + 1
    Next i

    Selection.Offset(0, 1).Activate
    ActiveCell.Value = DateCount
    Selection.Offset(1, -1).Activate
Loop

谁能告诉我哪里出错了？

Answer 1

我已经将这些代码存放了几年 - 可能需要调整您需要创建一个工作簿，并为工作表提供shtAnalysis的代号。

将此代码添加到工作簿中的普通模块，然后运行CreateReport过程。

Public Sub CreateReport()

    Dim oOutlook As Object 'Outlook.Application
    Dim nNameSpace As Object 'Outlook.Namespace
    Dim mFolderSelected As Object 'Outlook.MAPIFolder
    Dim oItem As Object
    Dim rLastCell As Range
    Dim x As Long

    'Solves the "Code execution has been interrupted" problem.
    Application.EnableCancelKey = xlDisabled
    Application.EnableCancelKey = xlInterrupt

    Set oOutlook = GetObject(, "Outlook.Application")
    Set nNameSpace = oOutlook.GetNamespace("MAPI")

    Set mFolderSelected = nNameSpace.PickFolder

    shtAnalysis.Cells.Delete Shift:=xlUp

    ProcessFolder mFolderSelected

    Set rLastCell = LastCell(shtAnalysis)

    With shtAnalysis
        .Columns.ColumnWidth = 100
        .Cells.EntireColumn.AutoFit

        .Range(.Cells(1, 1), .Cells(rLastCell.Row, rLastCell.Column)).Sort _
            Key1:=.Range("A2"), Order1:=xlDescending, Header:=xlYes

        'Add totals to row 1 & column A.
            .Rows("1:1").Insert Shift:=xlDown
            .Columns("A:A").Insert Shift:=xlToRight
            For x = 3 To rLastCell.Column
                With .Cells(1, x)
                    .FormulaR1C1 = "=SUM(R3C:R" & rLastCell.Row & "C)"
                    .NumberFormat = "General"
                    .Font.Bold = True
                    .Font.ColorIndex = 3
                End With
            Next x
            For x = 3 To rLastCell.Row
                With .Cells(x, 1)
                    .FormulaR1C1 = "=SUM(RC3:RC" & rLastCell.Column & ")"
                    .NumberFormat = "General"
                    .Font.Bold = True
                    .Font.ColorIndex = 3
                End With
            Next x
            'Add grand total.
            With .Cells(1, 1)
                .FormulaR1C1 = "=SUM(RC3:RC" & rLastCell.Column & ")"
                .NumberFormat = "General"
                .Font.Bold = True
                .Font.Size = 14
                .Font.ColorIndex = 3
            End With
    End With

    ThisWorkbook.Activate
    MsgBox "Complete", vbOKOnly

End Sub

Private Sub ProcessFolder(oParent As Object)

    Dim oFolder As Object 'Outlook.MAPIFolder
    Dim oMail As Object
    Dim sName As String

    On Error Resume Next
    For Each oMail In oParent.Items
        PlaceDetails Int(oMail.SentOn), oParent
    Next oMail

    If (oParent.Folders.Count > 0) Then
        For Each oFolder In oParent.Folders
            ProcessFolder oFolder
        Next oFolder
    End If
    On Error GoTo 0

End Sub

Public Sub PlaceDetails(dDate As Date, oFolders As Object)

    Dim rFoundCell As Range
    Dim lRow As Long, lColumn As Long
    Dim sItem As String
    Dim lLevel As Long
    Dim x As Long

    sItem = oFolders.FullFolderPath 'User the full path of the folder.
    If Left(sItem, "2") = "\\" Then
        sItem = Mid(sItem, 3, Len(sItem)) 'Remove leading backslashes.
    End If
    lLevel = Len(sItem) - Len(Replace(sItem, "\", ""))

    For x = 1 To lLevel
        sItem = Left(sItem, InStr(sItem, "\") - 1) & Replace(sItem, "\", Chr(10) & Application.WorksheetFunction.Rept(" ", x) & Chr(149), InStr(sItem, "\"), 1)
    Next x


    With shtAnalysis
        .Columns(1).EntireColumn.AutoFit

        'First find the column by looking for sItem in row 1.
        Set rFoundCell = .Rows("1:1").Cells.Find(What:=sItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
        If Not rFoundCell Is Nothing Then
            lColumn = rFoundCell.Column
        Else
            lColumn = LastCell(shtAnalysis).Column + 1
        End If
        Set rFoundCell = Nothing

        'Next find the row by looking for dDate in column A.
        Set rFoundCell = .Columns("A:A").Cells.Find(What:=dDate, After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
        If Not rFoundCell Is Nothing Then
            lRow = rFoundCell.Row
        Else
            lRow = LastCell(shtAnalysis).Row + 1
        End If
        Set rFoundCell = Nothing

        'Place the data.
        .Cells(lRow, 1).Value = dDate
        .Cells(1, lColumn).Value = sItem
        If .Cells(lRow, lColumn) = "" Then
            .Cells(lRow, lColumn).NumberFormat = "General"
            .Cells(lRow, lColumn) = 1
        Else
            .Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
        End If

    End With

End Sub

' Purpose   : Finds the last cell containing data or a formula within the given worksheet.
'             If the Optional Col is passed it finds the last row for a specific column.
'---------------------------------------------------------------------------------------
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

这将产生如下结果：

Answer 2

更大的错误是：

On Error Resume Next
' without
On Error GoTo 0
' to stop bypassing errors.

实际错误可能是：

For i = 0 To UBound(arrEmailDates) - 1

代码可能如下所示：

Sub countMail()

    ' Set Variables
    Dim objOutlook As Object, objnSpace As Object, objFolder As Object
    Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
    Dim myDate As Date
    Dim arrEmailDates()

    Dim i As Long
    ' Get Outlook Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    ' Get Folder Object
    On Error Resume Next
    Set objFolder = objnSpace.Folders("Estates").Folders("Bookings")

    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Set objFolder = Nothing
        Set objnSpace = Nothing
        Set objOutlook = Nothing
        Exit Sub
    End If

    On Error GoTo 0     ' Turn off error bypass as quickly as possible

    ' Put ReceivedTimes in array
    EmailCount = objFolder.items.Count

    For iCount = 1 To EmailCount

        With objFolder.items(iCount)

            ReDim Preserve arrEmailDates(iCount - 1)

            ' Bypass error on items without a received date
            On Error Resume Next
            arrEmailDates(iCount - 1) = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
            On Error GoTo 0     ' Turn off error bypass as quickly as possible

        End With

    Next iCount

    'For i = 0 To UBound(arrEmailDates) - 1
    For i = 0 To UBound(arrEmailDates)
        Debug.Print i & " - " & arrEmailDates(i)
    Next i

    ' Clear Outlook objects
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

    ' Count the emails dates equal to active cell
    Sheets("test email count").Range("e2").Select
    Do Until IsEmpty(ActiveCell)

        DateCount = 0
        myDate = ActiveCell.Value
        Debug.Print " mydate: " & myDate

        'For i = 0 To UBound(arrEmailDates) - 1
        For i = 0 To UBound(arrEmailDates)
            If arrEmailDates(i) = myDate Then DateCount = DateCount + 1
        Next i

        Selection.Offset(0, 1).Activate
        ActiveCell.Value = DateCount
        Selection.Offset(1, -1).Activate

    Loop

End Sub

展望整理特定日期收到的电子邮件数量

2 个答案: