Перемещение писем в общую папку с использованием динамических путей - PullRequest
Новая
       37

Перемещение писем в общую папку с использованием динамических путей

0 голосов
/ 27 сентября 2011

В нашей корпоративной среде у нас есть почтовый ящик (не входящий по умолчанию) со многими подпапками.У нас также есть общая папка, которая является точным зеркалом структуры папок почтового ящика.

Я пытаюсь определить путь к выбранному письму и переместить это письмо в его зеркальную папку в общих папках.

Я бы сказал, что 95% этого кода верны, но у меня осталось сообщение об ошибке Outlook «Невозможно переместить элементы».

Код должен выполнять следующие действия:
1. обнаруживает текущую папку выбранных сообщений электронной почты
2. преобразует MAPIFolder в строку пути
3. сокращает строку, чтобы удалить структуру корневого каталога почтовых ящиков
4. добавляет оставшуюся строку вСтруктура корневого каталога общей папки
5. преобразует полученный путь обратно в MAPIFolder
6. переместить выбранные электронные письма в зеркальную папку в общих папках 

Sub PublicFolderAutoArchive()

    Dim olApp As Object
    Dim currentNameSpace As NameSpace
    Dim wipFolder As MAPIFolder
    Dim objFolder As MAPIFolder
    Dim pubFolder As String
    Dim wipFolderString As String
    Dim Messages As Selection
    Dim itm As Object
    Dim Msg As MailItem
    Dim Proceed As VbMsgBoxResult

    Set olApp = Application
    Set currentNameSpace = olApp.GetNamespace("MAPI")
    Set wipFolder = Application.ActiveExplorer.CurrentFolder
    Set Messages = ActiveExplorer.Selection

    ' Destination root directory'
    ' Tried with both "\\Public Folders" and "Public Folders" .. neither worked
    pubFolder = "\\Public Folders\All Public Folders\InboxMirror"

    ' wipFolder.FolderPath Could be any folder in our mailbox such as:  
    ' "\\Mailbox - Corporate Account\Inbox\SubFolder1\SubFolder2"
    ' however, the \\Mailbox - Corporate Account\Inbox\" part is 
    ' static and never changes so the variable below removes the static
    ' section, then the remainder of the path is added onto the root 
    ' of the public folder path which is an exact mirror of the inbox.
    ' This is to allow a dynamic Archive system where the destination 
    'path matches the source path except for the root directory.
    wipFolderString = Right(wipFolder.FolderPath, Len(wipFolder.FolderPath) - 35)

    ' tried with and without the & "\" ... neither worked
    Set objFolder = GetFolder(pubFolder & wipFolderString & "\")

    If Messages.Count = 0 Then
        Exit Sub
    End If

    For Each itm In Messages
        If itm.Class = olMail Then
            Proceed = MsgBox("Are you sure you want archive the message to the Public Folder?", _
            vbYesNo + vbQuestion, "Confirm Archive")
            If Proceed = vbYes Then
                Set Msg = itm
                Msg.Move objFolder
            End If
        End If
    Next
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

Примечание: Приведенный выше почтовый ящик является лишь примером, а не фактическим именем почтового ящика.Я использовал MsgBox, чтобы убедиться, что строка пути правильно соединена со всеми соответствующими обратными слешами и что функция Right () получала то, что мне нужно, из исходного пути.

Ответы [ 2 ]

1 голос
/ 21 ноября 2012

Я не уверен, но должно быть что-то вроде? 

set objApp = New Outlook.Application

вместо 

    set objApp = Application
0 голосов
/ 03 июля 2013

Судя по коду, кажется, что вашей реализации GetFolder() не нравится двойная обратная косая черта, которую вы задаете в начале пути.Есть даже комментарий, указывающий это в начале функции.Попробуйте удалить эти два символа из передней части pubFolder.

В качестве альтернативы, вы можете изменить GetFolder, чтобы разрешить их.Несколько строк вроде этого должны помочь. 

If Left(strFolderPath, 2) = "\\" Then
    strFolderPath = Right(strFolderPath, Len(strFolderPath) - 2)
End If
...