Office365电子邮件文件管理器

Question

我的公司已迁移到Office365，现在我创建的电子邮件文件宏不起作用。本质上，它会打开excel以获取规则表，并将电子邮件从收件箱（或当前文件夹）移动到excel文件定义的目标文件夹。

我现在得到以下类型的不匹配：

Set olNs = Application.Getnamespane("MAPI")

如果我跳过了这一行，因为我认为这是旧代码中的旧行，那么我就不需要它了

Set Items = Inbox.Items

下面的完整代码，如果可能的话，请提供任何帮助，只需进行简单的更改即可使它生效！

Public Sub File_Emails_Not_Today()
    Email_Mover (False)
End Sub

Public Function Email_Mover(blnFileToday As Boolean)
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim Items As Outlook.Items
    Dim lngCount As Long
    Dim i As Integer
    Dim TorF As Boolean
    Dim blnResearch As Boolean 'Research

    Dim strSender As String
    Dim strDomain As String

'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = Application.ActiveExplorer.CurrentFolder
    Set Items = Inbox.Items

    On Error GoTo Recover

    'Get Email List Array
    Dim EmailArray As Variant
    EmailArray = Create_Array("P:\Personal\Code\Email Filer.xlsx")

'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)
        'Check to ensure it is an email
        If Not Left(Item.Body, 10) = "EMC Source" Then
            If Item.Class = olMail Then
                TorF = False
                blnResearch = False 'Research
                'File All Messages or just old ones?
                If blnFileToday Then
                    TorF = True
                ElseIf Not Day(Item.ReceivedTime) = Day(Now) Then
                    TorF = True
                End If
                If TorF Then
                    strDomain = GetDomain(Item.SenderEmailAddress)
                    strSender = Item.Sender
                    'Cycle through array to find a rule
                    For i = 1 To UBound(EmailArray)
                        If Trim(UCase(strSender)) = Trim(UCase(CStr(EmailArray(i, 1)))) Or _
                            Trim(UCase(strDomain)) = Trim(UCase(CStr(EmailArray(i, 2)))) Then
                            'auto delete?
                            Select Case EmailArray(i, 3)
                            Case "Delete"
                                Item.Delete
                                TorF = False
                                Exit For
                            Case "2. Research" 'Research
                                blnResearch = True 'Research
                            End Select
                            'Set the destination
                            Set SubFolder = SetSubFolder(EmailArray(i, 3), EmailArray(i, 4), _
                                                        EmailArray(i, 5), EmailArray(i, 6))
                            Exit For
                        End If
                    Next i
                    'Move the Email
                    If Not SubFolder Is Nothing Then
                        If Not SubFolder = Inbox Then
                            If TorF Then Item.Move SubFolder
                            'lngCount = lngCount - 1
                        End If
                    End If
                End If
            End If
        End If
        Set SubFolder = Nothing
Recover:
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set Items = Nothing

    Exit Function

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Function

Public Function SetSubFolder(sf1, _
                            Optional sf2, _
                            Optional sf3, _
                            Optional sf4) As Outlook.MAPIFolder

Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")

With olNs.Folders("Matthew.Rees@columbiathreadneedle.com").Folders("Folders")
        If Not sf4 = "" Then
            Set SetSubFolder = .Folders(sf1).Folders(sf2).Folders(sf3).Folders(sf4)
        Else
            If Not sf3 = "" Then
                Set SetSubFolder = .Folders(sf1).Folders(sf2).Folders(sf3)
            Else
                If Not sf2 = "" Then
                    Set SetSubFolder = .Folders(sf1).Folders(sf2)
                Else
                    Set SetSubFolder = .Folders(sf1)
                End If
            End If
        End If
End With
End Function

Function Create_Array(strFileLocation As String) As Variant

Dim wb As Object
Dim ws As Object
Dim xlApp As Object
Dim i, j As Integer
Dim arr() As String
Dim xrow As Integer
Dim strX As String

Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
Set wb = xlApp.Workbooks.Open(strFileLocation)
Set ws = wb.sheets("List")
With ws
    'quick and dirty way to find the number of rules
    xrow = 400
    strX = "foobar"
    Do Until strX = ""
        strX = .cells(xrow, 3)
        xrow = xrow + 1
    Loop
    xrow = xrow - 1
    'resixe the array
    ReDim arr(xrow, 6)

    For i = 2 To xrow
        For j = 1 To 6
            arr(i - 1, j) = .cells(i, j)
        Next j
    Next i
End With
wb.Close
xlApp.Application.Visible = False
Create_Array = arr
End Function