爲什麼要編譯錯誤？ excel vba引用outlook

Question

這個'archiveOutlookFolder'代碼工作正常，直到我運行其他代碼，刪除/重新添加對Outlook的引用。卸載/加載Outlook後，我得到objFolder.MoveTo objDestFolder行上的編譯錯誤。

我必須卸載/加載Outlook，因爲不同的人在整個辦公室都有不同的outlook版本。因此，爲了防止出現錯誤，如果工作簿加載了版本，則會卸載它，然後加載用戶的版本。

重申：在卸載/加載Outlook後，我開始在'archiveOutlookFolder'子的'objFolder.MoveTo objDestFolder'行上收到編譯錯誤。

任何協助解決這將不勝感激。謝謝！

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

工作代碼：

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 

Answer 2

我沒有在Outlook中測試這一點，但一些更改archiveOutlookFolder子。既然你已經硬編碼了一些文件夾名稱，你最好檢查它們在設置期間是否變成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