Однокнопочный файл электронной почты - Outlook 365 - PullRequest
Новая
       5

Однокнопочный файл электронной почты - Outlook 365

0 голосов
/ 18 октября 2018

Я пытаюсь создать макрос файла в одну кнопку, который просматривает Catagory и записывает письмо в соответствующую папку.У меня проблема в том, что у меня должен быть код, специфичный для каждой категории, поскольку папки имеют разные пути.Есть ли способ не указывать полный путь в коде?

См. Пример ниже 

Sub Move_Email()

Dim itm As MailItem
Dim CATNAME As String
Set itm = ActiveExplorer.Selection(1
If itm.Categories = "Customer1" Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders("01 - My Accounts").Folders("Customer1")
Else
    If itm.Categories = "Supplier1" Then
        itm.Move Session.GetDefaultFolder(olFolderInbox).Folders("01 - My Suppliers").Folders("Supplier1")
    Else
    Exit Sub
    End If
 Exit Sub
 End If
 End Sub

Я бы хотел, чтобы это было больше похоже на 

Sub Move_Email2()

Dim itm As MailItem
Dim CATNAME As String
Set itm = ActiveExplorer.Selection(1)
CATNAME = itm.Categories

If itm.Categories = CATNAME Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders(CATNAME)
End If
End Sub

Возможно ли это?

Попытка 1: 

Sub Move_Email2()

Dim itm As MailItem
Dim Name As String
Dim FoundFolder As Folder
Set itm = ActiveExplorer.Selection(1)

Name = itm.Categories

If Len(Trim$(Name)) = 0 Then Exit Sub

Set FoundFolder = FindInFolders(Application.Session.Folders, Name)

If Not FoundFolder Is Nothing Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders(FoundFolder.FolderPath)
End If

End Sub

1 Ответ

0 голосов
/ 19 октября 2018

Вы можете использовать имя папки для поиска папки, например: 

Sub Move_Email2()

Dim itm As MailItem
Dim Name As String
Dim FoundFolderPath As String
Dim strFolderPath As Folder
Set itm = ActiveExplorer.Selection(1)

If Len(Trim$(Name)) = 0 Then Exit Sub

For Each Name In itm.Categories
    Set FoundFolder = FindInFolders(Application.Session.Folders, Name)
    If Not FoundFolder Is Nothing Then
        itm.Move GetFolder(FoundFolder.FolderPath)
    End If
Next

End Sub
Function FindInFolders(TheFolders As Outlook.Folders, Name As String)
  Dim SubFolder As Outlook.MAPIFolder

  On Error Resume Next

  Set FindInFolders = Nothing

  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Next
End Function
Function GetFolder(ByVal FolderPath As String) As Outlook.Folder
 Dim TestFolder As Outlook.Folder
 Dim FoldersArray As Variant
 Dim i As Integer

 On Error GoTo GetFolder_Error
 If Left(FolderPath, 2) = "\\" Then
 FolderPath = Right(FolderPath, Len(FolderPath) - 2)
 End If
 'Convert folderpath to array
 FoldersArray = Split(FolderPath, "\")
 Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
 If Not TestFolder Is Nothing Then
 For i = 1 To UBound(FoldersArray, 1)
 Dim SubFolders As Outlook.Folders
 Set SubFolders = TestFolder.Folders
 Set TestFolder = SubFolders.item(FoldersArray(i))
 If TestFolder Is Nothing Then
 Set GetFolder = Nothing
 End If
 Next
 End If
 'Return the TestFolder
 Set GetFolder = TestFolder
 Exit Function

GetFolder_Error:
 Set GetFolder = Nothing
 Exit Function
End Function

Пожалуйста, перейдите по этой ссылке:

Как найти папку по имени в Outlook?

Получение объекта папки из пути к папке

...