Excel VBA，设置一个Outlook文件夹，这是一个公用文件夹

Question

我正在尝试将电子邮件从收件箱文件夹（名为“A_Classer”）移动到 Outlook 公用文件夹（目标文件夹的变量名为 olFolder） 我尝试了 getshareddefaultfolder 方法和 OpenSharedFolder 方法，但我无法解决我的语法问题 共享文件夹的名称是“Québec”，它的路径（来自 Windows 属性）是（“Dossiers publics - guillaume.hebert@cima.ca/Tous les dossiers publics/Québec”） 代码停在：set olFolder...

下面是我尝试过的所有版本的代码

Sub move_to_public_folder()

Dim msg As Outlook.MailItem
Dim olFolder As Outlook.Folder         'public folder where I want the email to be moved
Dim sourceFolder As Outlook.Folder           'current folder of the emails that are to be moved
Dim OlApp As Object

Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient

Set OlApp = CreateObject("Outlook.Application")                         'Outlook application call
Set myNamespace = OlApp.GetNamespace("MAPI")

Set myRecipient = myNamespace.CreateRecipient("Guillaume Hébert")
myRecipient.Resolve
If myRecipient.Resolved Then
    Cells(1, 1) = Cells(1, 1) + 1
End If

Set olFolder = myNamespace.OpenSharedFolder("Québec")            'FIRST try I made
'Set olFolder = myNamespace.OpenSharedFolder _                    'Second try I made
    '("Dossiers publics - guillaume.hebert@cima.ca/Tous les dossiers publics/Québec")
'Set olFolder = myNamespace.GetSharedDefaultFolder _              'Last try I made
                    '(myRecipient, olPublicFoldersAllPublicFolders)



Set sourceFolder = Session.GetDefaultFolder(sourceFolderInbox)
Set sourceFolder = sourceFolder.Folders("A_Classer")
If sourceFolder Is Nothing Then Exit Sub

I = sourceFolder.Items.Count
nbre_op = I                                                         'détermine combien de courriel dans le répertoire
I = 1
While I <= nbre_op
    Set msg = olFolder.Items(1)
    msg.Move olFolder
    I = I + 1
Wend

Set OlApp = Nothing

结束子

提前感谢您提供的所有帮助

Answer 1

您是否连接到 Exchange 服务器？

如果您使用OpenSharedFolder 方法，您需要指定URL。此方法用于访问以下共享文件夹类型：

• 网络日历 (webcal://mysite/mycalendar)
• RSS 提要 (feed://mysite/myfeed)
• Microsoft SharePoint Foundation 文件夹 (stssync://mysite/myfolder)
• iCalendar 日历 (.ics) 文件
• vCard 联系人 (.vcf) 文件
• Outlook 消息 (.msg) 文件

我建议使用GetSharedDefaultFolder 方法，该方法返回一个Folder 对象，该对象代表指定用户的指定默认文件夹。例如，您可以获取收件箱文件夹，然后您可以找到所需的。

当您运行以下行时，您在代码中遇到什么错误？

'Set olFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olPublicFoldersAllPublicFolders)

Answer 2

找到了！发送给@Eugene 和@xmojmr。

Sub move_to_public_folder()
    Dim msg As Outlook.MailItem
    Dim olFolder As Outlook.Folder         'source folder
    Dim objFolder As Outlook.Folder         'target folder
    'Dim sourceFolder As Outlook.Folder           'current folder of the emails that are to be moved
    Dim OlApp As Object
    'Dim fldr As Outlook.Folder
    Dim chemin_repertoire_outlook_cible As String       'path containing the target folder

    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient

    Set OlApp = CreateObject("Outlook.Application")                         'Outlook application call
    Set myNamespace = OlApp.GetNamespace("MAPI")

    Set myRecipient = myNamespace.CreateRecipient("Guillaume Hébert")
    myRecipient.Resolve
    If myRecipient.Resolved Then
        Cells(1, 1) = Cells(1, 1) + 1
    End If

    Set OlApp = CreateObject("Outlook.Application")                         'Outlook application call
    Set olFolder = Session.GetDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("A_Classer")

    lig = 11
    col = 4

    chemin_repertoire_outlook_cible = Cells(lig, col)                'target folder name setting
    Set objFolder = GetFolder(chemin_repertoire_outlook_cible)
    I = olFolder.Items.Count
    nbre_op = I
    I = 1
    While I <= nbre_op                                       'loop to move all msg in source folder (olFolder)
        Set msg = olFolder.Items(1)
        msg.Move objFolder
        I = I + 1
    Wend

 Set OlApp = Nothing
End Sub

GetFolder函数如下

Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' source of this function is:  http://www.outlookcode.com/d/code/getfolder.htm
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  Dim objApp As Outlook.Application
  Dim objNS As Outlook.Namespace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.Folder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next


  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Outlook.Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing

End Function

希望它可以在某个时候对其他人有所帮助。