Выберите папку в Outlook, используя VBA - PullRequest
Новая
       11

Выберите папку в Outlook, используя VBA

0 голосов
/ 05 июня 2018

У меня огромное количество папок в папке входящих сообщений Outlook.У меня есть макрос, который будет перечислять (в объекте списка) все папки, в которых есть текст xxxx.

Однако мне придется вручную развернуть иерархию папок, чтобы выбрать папку и открытьЭто.Ничего страшного, но очень много времени, учитывая количество уровней папок, которые у меня есть.

Есть ли кто-нибудь, кто может помочь мне с некоторым кодом, чтобы взять текстовый путь из моей записи в списке и с помощьюдважды щелкните, просто выберите папку?

Вот пример пути (отредактирован!):

\\john.smith@somemailbox.biz\Inbox\04_Projects\Florida\Data Migration\01_Data Cleansing & Testing

Большое спасибо

Макрос (код очень простой, но я тольконачинающий): 

Sub MainProc()
    'On Error GoTo On_Error
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Folders As Outlook.Folders
    Dim Folder As Outlook.Folder
    Dim reply As Integer
    Dim NumFolders As Integer

    Set Session = Application.Session
    Set Folders = Session.Folders
    ArrayElem = 0
    BugOut = False
    '----------------
    RowCount = 0
    '----------------
    ReDim FoldArray(1)
    FSearch = InputBox("Enter search text", "Find folders")
    'MySearch = "Test21"
    'MySearch = InputBox("Type in a folder name", "Folder Search")
    '----------------------------------------------------------
    ' There is only one folder we need  in the "Folders" collection
     ' and this is actually the mailbox 
    '----------------------------------------------------------
    For Each Folder In Folders
        If Folder.Name = "john.smith@somemailbox.biz" Then
            Call Subsid(Folder)
       End If
    Next
    'For i = LBound(MyArray) To UBound(MyArray)
    '   msg = msg & MyArray(i) & vbNewLine
    'Next i
    'MsgBox msg
    'MsgBox RowCount
    If RowCount <> 0 Then
        FindMyForm.TextBox1.BackColor = RGB(204, 255, 204)
        FindMyForm.TextBox1.Value = "Here are the folders that contain '" & 
    FSearch & "'"
       Else
        FindMyForm.TextBox1.BackColor = RGB(255, 204, 204)
        FindMyForm.TextBox1.Value = "I'm afraid there are no folders that 
contain '" & FSearch & "'"
    End If
    FindMyForm.ListBox1.List = FoldArray
    FindMyForm.StartUpPosition = 2
    FindMyForm.Show

Exiting:
        Set Session = Nothing
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub

Дополнительный код: 

Private Sub SubSid(CurrentFolder As Outlook.Folder)
    Dim SubFolders As Outlook.Folders
    Dim SubFolder As Outlook.Folder

    Set SubFolders = CurrentFolder.Folders
    For Each SubFolder In CurrentFolder.Folders
        'SubFolder.Display
        If SubFolder.Name = "Inbox" Then
            Call ArrayProc(SubFolder)
        End If
    Next SubFolder

End Sub

Массив Население: 

Private Sub ArrayProc(CurrentFolder As Outlook.Folder)
    Dim SubFolders As Outlook.Folders
    Dim SubFolder As Outlook.Folder
    Dim StayAtLevel As Boolean
    Dim SubString As String
    Dim NewString As String

    '---------------------------------------------
    ' We are now at the "INBOX" level of folders
    '---------------------------------------------
    Set SubFolders = CurrentFolder.Folders
    'MsgBox CurrentFolder.FolderPath
        For Each SubFolder In SubFolders
        If InStr(1, SubFolder.Name, FSearch) Then
            ReDim Preserve FoldArray(UBound(FoldArray) + 1)
            SubString = SubFolder.FolderPath
            NewString = Replace(SubString, "\\John.smith@somemailbox.biz\", "")
            FoldArray(ArrayElem) = NewString
            ArrayElem = ArrayElem + 1
            RowCount = RowCount + 1
            End If
          Call ArrayProc(SubFolder)
    Next SubFolder 
End Sub
...