ThisOutlookSession 모듈에서 여러 Outlook 폴더에 매크로를 어떻게 적용합니까?

Question

이 사이트의 정보를 사용하여 메시지를 상위 폴더로 이동할 때 메시지를 "보낸 사람 이름" 하위 폴더로 정렬하는 매크로를 만들 수 있었습니다. 예를 들어:

1. 받은편지함에 메시지가 도착했습니다.

2. 메시지를 "후속 작업" 폴더로 옮깁니다.

3. 보낸 사람 이름이라는 하위 폴더가 없으면 생성됩니다.

   3a. 메시지는 즉시 후속 조치/발신자 이름으로 이동됩니다.

아래 코드는 이러한 단계를 완벽하게 수행합니다. 이제 해야 할 일은 코드를 다른 폴더에 적용하는 것입니다. 현재 내 코드는 자동으로 작동하기를 원하기 때문에 "ThisOutlookSession" 모듈에 있습니다.

내 질문은: 받은 편지함의 여러 하위 폴더에 매크로를 어떻게 적용합니까? 즉:

받은편지함 - 여기에는 적용되지 않음

  follow-up  - applied here
  team       - applied here
  vendors    - applied here

지금까지 내가 가지고 있는 코드는 다음과 같습니다.

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

  ' set object reference to default Inbox
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Follow-up").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String

  ' don't do anything for non-Mailitems
  If TypeName(item) <> "MailItem" Then GoTo ProgramExit

  Set Msg = item

  ' move received email to target folder based on sender name
  senderName = Msg.senderName

  If CheckForFolder(senderName) = False Then  ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("follow-up").Folders(senderName)
  End If

  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders("follow-up")

' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
  CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders("Follow-up")

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Answer 1

누군가 이것을 발견하고 궁금해할 경우를 대비해 저는 스스로 알아낼 수 있었습니다. 저는 아직 이 분야에 익숙하지 않으며 "Items" 태그를 변경하여 제가 보고 있는 항목을 정의한 다음 각각의 폴더를 가리키도록 새 변수를 설정할 수 있다는 것을 몰랐습니다. 그렇게 하고 나면 각 폴더에 하위 항목을 추가할 수 있게 되었고, 그만뒀습니다.

Private WithEvents Corporate As Outlook.Items
Private WithEvents Subsidiary As Outlook.Items
Private WithEvents ServDsk As Outlook.Items
Private WithEvents Vendors As Outlook.Items


Public Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

  ' set object reference to default Inbox
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set DefFol = objNS.GetDefaultFolder(olFolderInbox)
  Set Corporate = DefFol.Folders("Corporate Teammates").Items
  Set Subsidiary = DefFol.Folders("Subsidiary").Items
  Set ServDsk = DefFol.Folders("Service Desk").Items
  Set Vendors = DefFol.Folders("Vendors").Items

End Sub


Private Sub Corporate_ItemAdd(ByVal up As Object)


' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String
  Dim dirstr As String
  Dim strDomain As String


  ' don't do anything for non-Mailitems
  If TypeName(up) <> "MailItem" Then GoTo ProgramExit

  Set Msg = up

  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")

  ' move received email to target folder based on sender name
  senderName = Msg.senderName
  dirstr = "Corporate Teammates"



  If CheckForFolder(senderName, dirstr) = False Then ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName, dirstr)
  Else
   ' Set olApp = Outlook.Application
   ' Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(senderName)
  End If

  Msg.UnRead = False
  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description & dirstr
  Resume ProgramExit
End Sub

Private Sub Subsidiary_ItemAdd(ByVal up As Object)


' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String
  Dim dirstr As String


  ' don't do anything for non-Mailitems
  If TypeName(up) <> "MailItem" Then GoTo ProgramExit

  Set Msg = up

  ' move received email to target folder based on sender name
  senderName = Msg.senderName
  dirstr = "Subsidiary"

  If CheckForFolder(senderName, dirstr) = False Then ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName, dirstr)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(senderName)
  End If

  Msg.UnRead = False
  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description & dirstr
  Resume ProgramExit
End Sub

Private Sub ServDsk_ItemAdd(ByVal up As Object)


' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim folderName As String
  Dim dirstr As String


  ' don't do anything for non-Mailitems
  If TypeName(up) <> "MailItem" Then GoTo ProgramExit


  ' move received email to target folder based on sender name
  dirstr = "Service Desk"

' checks the subject to decide how to handle the sorting
Select Case True
   Case InStr(Msg.Subject, "Demand") > 0
    folderName = "Demands"
   Case InStr(Msg.Subject, "Demand") = 1
    folderName = "Demands"
   Case InStr(Msg.Subject, "Incident") > 0
    folderName = "Tickets"
   Case InStr(Msg.Subject, "Problem") > 0
    folderName = "Tickets"
   Case InStr(Msg.Subject, "Opened") > 0
    folderName = "Tickets"
   Case InStr(Msg.Subject, "task") > 0
    folderName = "Tasks"
   Case InStr(Msg.Subject, "Status") > 0
    folderName = "Tickets"
   Case InStr(Msg.Subject, "TASK") > 0
    folderName = "Tasks"
   Case InStr(Msg.Subject, "Approval") > 0
    folderName = "OCH Approval requests"
   Case InStr(Msg.Subject, "Request") > 0
    folderName = "Requests"
   Case InStr(Msg.Subject, "Maintenance") > 0
    folderName = "Maintenance"
   Case InStr(Msg.Subject, "Alert") > 0
    folderName = "Alerts"
   Case InStr(Msg.Subject, "Notice") > 0
    folderName = "Alerts"
   Case InStr(Msg.Subject, "Reminder") > 0
    folderName = "Alerts"
End Select


  If CheckForFolder(folderName, dirstr) = False Then ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(folderName, dirstr)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(folderName)
  End If

  Msg.UnRead = False
  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description & dirstr
  Resume ProgramExit
End Sub

Private Sub Vendors_ItemAdd(ByVal up As Object)


' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String
  Dim dirstr As String
  Dim strDomain As String


  ' don't do anything for non-Mailitems
  If TypeName(up) <> "MailItem" Then GoTo ProgramExit

  Set Msg = up

' strips the domain name out of the sender address
  If InStr(1, Msg.SenderEmailAddress, "@") > 0 Then
         strDomain = Right(Msg.SenderEmailAddress, Len(Msg.SenderEmailAddress) - InStr(Msg.SenderEmailAddress, "@"))
  End If


If CheckForFolder(senderName, strDomain) = False Then ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName, strDomain)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Vendors").Folders(strDomain)
End if

  Msg.UnRead = False
  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description & dirstr
  Resume ProgramExit
End Sub





Function CheckForFolder(strFolder As String, dirstr As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")


Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(dirstr)


' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
  CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing

End Function




Function CreateSubFolder(strFolder As String, dirstr As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(dirstr)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)


ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function