Question

我正在努力找出如何从word宏创建公共文件夹，暂时我正在调试Outlook。问题是我的宏将由几个用户运行，因此我无法在“公共文件夹-xxxx@xxx.no”中进行硬编码。那么有没有办法避免这种情况？

    Sub AddContactsFolder()
     Dim myNameSpace As Outlook.NameSpace
     Dim myFolder As MAPIFolder
     Dim myNewFolder As MAPIFolder

     Set myNameSpace = Application.GetNamespace("MAPI")
    'Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
    'Set myFolder = myNameSpace.GetSharedDefaultFolder(

    'Set myFolder = GetFolder("Public Folders - xxxx@xxxx.no/All Public Folders/Prototech/")
    'fails below .....
    Set myFolder = GetFolder("Public Folders - *.xxxxx.no/All Public Folders/Prototech/Avd. 150 R&D") '.Folders.Add("Test")
    Set myNewFolder = myFolder.Folders.Add("AAAAA")
    End Sub


    Public Function GetFolder(strFolderPath As String) As MAPIFolder
      ' 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.MAPIFolder
      Dim arrFolders() As String
      Dim I As Long
      On Error Resume Next

      strFolderPath = Replace(strFolderPath, "/", "\")
      arrFolders() = Split(strFolderPath, "\")
      Set objApp = 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

Answer 1

遍历Namespace.Stores集合中的所有商店，为每个商店检查Store.ExchangeStoreType属性。对于PF商店，它将是2 (OlExchangeStoreType.olExchangePublicFolder)。然后，您可以从Store.GetRootFolder文件夹开始向下钻取文件夹层次结构。

Answer 2

您无需指定用户。

Sub AddContactsFolder()

    Dim myNameSpace As Outlook.Namespace
    Dim myFolder As Folder
    Dim myNewFolder As Folder

    Dim TopPublicFolder As Folder

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set TopPublicFolder = myNameSpace.GetDefaultFolder(olPublicFoldersAllPublicFolders)
    Set myFolder = TopPublicFolder.Folders("Prototech").Folders("Avd. 150 R&D")
    Set myNewFolder = myFolder.Folders.Add("AAAAA")

End Sub

Answer 3

这是修改后的工作代码，感谢niton

Sub createPublicFolder(folderName As String)

Dim OutApp As Object

Set OutApp = CreateObject("Outlook.Application")
Dim myNameSpace As Object
Dim myFolder As Object
Dim myNewFolder As Object

Dim TopPublicFolder As Object

Set myNameSpace = OutApp.GetNamespace("MAPI")
Set TopPublicFolder = myNameSpace.GetDefaultFolder(18)
Set myFolder = TopPublicFolder.Folders("Prototech").Folders("Avd. 150 R&D")
Set myNewFolder = myFolder.Folders.Add(folderName)
End Sub

vba中的公用文件夹

3 个答案: