Question

此＆＃39; archiveOutlookFolder＆＃39;代码工作正常，直到我运行其他代码删除/重新添加对outlook的引用。卸载/加载Outlook后，我在objFolder.MoveTo objDestFolder行上收到编译错误。

我必须卸载/加载Outlook，因为不同的人在整个办公室都有不同版本的Outlook。因此，为防止出现错误，如果工作簿已加载版本，则会将其卸载，然后加载用户的版本。

重申：在卸载/加载Outlook后，我开始在＆＃39; objFolder.MoveTo objDestFolder＆＃39; “archiveOutlookFolder＆＃39;子。

任何解决此问题的协助都将不胜感激。谢谢！

Private Sub LoadOutlook()

Application.Run "UnloadOutlook"

    On Error GoTo unable2Load

    ThisWorkbook.VBProject.References.AddFromFile "MSOUTL.OLB"

    Exit Sub

unable2Load:

If Err.Number = 32813 Then Exit Sub

If Err.Number = 48 Then'for some reason 16 won't load without specific reference
ThisWorkbook.VBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB"
Exit Sub
End If

    MsgBox err.number & vblf & vblf & err.description

End Sub

Private Sub UnloadOutlook()

    On Error GoTo unable2Unload

    Dim References As Object
    Set References = ThisWorkbook.VBProject.References
    References.Remove References("Outlook")

    Exit Sub

unable2Unload:

If Err.Number = 9 Then Exit Sub 'already unloaded

MsgBox err.number & vblf & vblf & err.description

End Sub


Private Sub archiveOutlookFolder()

on error goto errHandler

Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objFolder As Folder
Dim AAfolderToMove As String
Dim PNAToMove As String
Dim eventFolderTomove As String
Dim foundEventFolder As Boolean

Dim olAAfolders As Outlook.Folder
Dim olFolder As Outlook.Folder

PNAToMove = ThisWorkbook.Sheets("data").Range("cleanpna").Value

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
    Set objOutlook = CreateObject("Outlook.Application")
End If

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set olAAfolders = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("Audits-Actuals")

foundEventFolder = False

For Each olFolder In olAAfolders.Folders
    If InStr(olFolder.Name, PNAToMove) > 0 Then
    eventFolderTomove = olFolder.Name
    foundEventFolder = True
    Exit For
    End If
Next olFolder

If foundEventFolder = False Then
MsgBox "I did not find an Outlook folder for this event to move to Past events. Please move manually.", vbCritical, "Audits\Actuals"
Exit Sub
End If

   Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
   Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("Audits-Actuals").Folders(eventFolderTomove)
   Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("PAST Audits-Actuals")

   objFolder.MoveTo objDestFolder

   Set objDestFolder = Nothing
   Set objFolder = Nothing
   Set objSourceFolder = Nothing
   Set objOutlook = Nothing
   Set objDestFolder = Nothing

   Exit Sub

errhandler:

subName = "archiveOutlookFolder"
thisErrNum = Err.Number
thisErrDes = Err.Description

Call sendErrorAlert

End Sub

Answer 1

我没有在Outlook中对此进行过测试，但对您的 archiveOutlookFolder Sub进行了一些更改。由于您已对某些文件夹名称进行了硬编码，因此最好在设置过程中检查它们是否为Nothing，如果它没有，您可能想让用户选择一个文件夹吗？

关于If InStr(olFolder.Name, PNAToMove) > 0 Then，这意味着当Outlook文件夹名称的某些部分包含 PNAToMove的值时，您需要执行某些操作。

Private Const olFolderInbox = 6

Private Sub archiveOutlookFolder()

    Const AA_FOLDER As String = "Audits-Actuals"
    Const DEST_FOLDER As String = "PAST Audits-Actuals"

    On Error GoTo errhandler

    Dim objOutlook As Object ' Outlook.Application
    Dim objNamespace As Object ' Outlook.Namespace
    Dim objSourceFolder As Object ' Outlook.MAPIFolder
    Dim objDestFolder As Object ' Outlook.MAPIFolder
    Dim objFolder As Object ' Folder
    Dim AAfolderToMove As String
    Dim PNAToMove As String
    Dim eventFolderTomove As String
    Dim foundEventFolder As Boolean

    Dim olAAfolders As Object ' Outlook.Folder
    Dim olFolder As Object ' Outlook.Folder

    PNAToMove = ThisWorkbook.Sheets("data").Range("cleanpna").Value

    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
    End If

    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) ' <-- Make use of this!
    'Set olAAfolders = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("Audits-Actuals")
    Set olAAfolders = objSourceFolder.Parent.Folders(AA_FOLDER) ' ("Audits-Actuals")

    foundEventFolder = False

    For Each olFolder In olAAfolders.Folders
        If InStr(olFolder.Name, PNAToMove) > 0 Then
            eventFolderTomove = olFolder.Name
            foundEventFolder = True
            Exit For
        End If
    Next olFolder

    If Not foundEventFolder Then ' If foundEventFolder = False Then
        MsgBox "I did not find an Outlook folder for this event to move to Past events. Please move manually.", vbCritical, "Audits\Actuals"
        Exit Sub
    End If

    'Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) ' Moved this up!
    'Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("Audits-Actuals").Folders(eventFolderTomove)
    Set objFolder = objSourceFolder.Parent.Folders(AA_FOLDER).Folders(eventFolderTomove)
    'Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("PAST Audits-Actuals")
    Set objDestFolder = objSourceFolder.Parent.Folders(DEST_FOLDER)

   If Not (objFolder Is Nothing And objDestFolder Is Nothing) Then objFolder.MoveTo objDestFolder

   Set objDestFolder = Nothing
   Set objFolder = Nothing
   Set objSourceFolder = Nothing
   Set objOutlook = Nothing
   Set objDestFolder = Nothing

   Exit Sub

errhandler:

    subName = "archiveOutlookFolder"
    thisErrNum = Err.Number
    thisErrDes = Err.Description

    Call sendErrorAlert

End Sub

Answer 2

工作代码：

Private Const olFolderInbox = 6

Private Sub archiveOutlookFolder()

On Error GoTo errhandler

Dim AA_FOLDER As String
Dim DEST_FOLDER As String

AA_FOLDER = "Audits-Actuals"
DEST_FOLDER = "PAST Audits-Actuals"

Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim objSourceFolder As Object ' Outlook.MAPIFolder
Dim objDestFolder As Object ' Outlook.MAPIFolder
Dim objFolder As Object ' Outlook.Folder
Dim olAAfolders As Object ' Outlook.Folder
Dim olFolder As Object ' Outlook.Folder

Dim AAfolderToMove As String
Dim PNAToMove As String
Dim eventFolderTomove As String
Dim foundEventFolder As Boolean

PNAToMove = ThisWorkbook.Sheets("data").Range("cleanpna").Value

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo errhandler
If objOutlook Is Nothing Then
    Set objOutlook = CreateObject("Outlook.Application")
End If

tryAgain:
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set olAAfolders = objSourceFolder.Parent.Folders(AA_FOLDER)

foundEventFolder = False

For Each olFolder In olAAfolders.Folders
    If InStr(olFolder.Name, PNAToMove) > 0 Then
        eventFolderTomove = olFolder.Name
        foundEventFolder = True
        Exit For
    End If
Next olFolder

If Not foundEventFolder And AA_FOLDER = "Audits-Actuals" Then
AA_FOLDER = "PAST Audits-Actuals"
DEST_FOLDER = "Audits-Actuals"
GoTo tryAgain
End If

If Not foundEventFolder Then
MsgBox "I did not find an Outlook folder for this event to move automatically. Please move manually.", vbCritical, "Audits\Actuals"
Exit Sub
End If

Set objFolder = objSourceFolder.Parent.Folders(AA_FOLDER).Folders(eventFolderTomove)
Set objDestFolder = objSourceFolder.Parent.Folders(DEST_FOLDER)

If Not (objFolder Is Nothing And objDestFolder Is Nothing) Then objFolder.MoveTo objDestFolder

Set olAAfolders = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing
Set objFolder = Nothing
Set objSourceFolder = Nothing
Set objOutlook = Nothing

Exit Sub

errhandler:

MsgBox Err.Number & vbLf & Err.Description

End Sub

为什么编译错误？ excel vba引用outlook

2 个答案: