वार्तालाप के फ़ोल्डर में चयनित संदेश को स्थानांतरित करने के लिए VBA फ़ंक्शन या मैक्रो

Question

मैं अपने सभी आउटलुक संदेशों को बातचीत के रूप में व्यवस्थित करता हूं। मैं वर्तमान में चयनित संदेश को इनबॉक्स से उनके संबंधित फ़ोल्डर में स्थानांतरित करने के लिए एक फ़ंक्शन की तलाश कर रहा हूं।

उदाहरण के लिए, यदि मेरे पास "वीकली स्टेटस रिपोर्ट" नामक एक ईमेल वार्तालाप है, जिसे "इंजीनियरिंग" फ़ोल्डर में दर्ज किया गया है और मुझे मेरे इनबॉक्स में उत्तर प्राप्त होता है, तो मैं मैक्रो को चलाना चाहता हूं और उत्तर को "स्थानांतरित" करना है। इंजीनियरिंग "फ़ोल्डर।

मैं Microsoft Office Professional Plus 2010 में Outlook का उपयोग कर रहा हूं।

काम की समस्या को हल करने में मेरा प्रारंभिक प्रयास, लेकिन मैं निम्न करना चाहूंगा:

1. गैर-मेलिटेम ऑब्जेक्ट्स के लिए कार्यक्षमता जोड़ें;
2. साफ करो For Each पहले जाँच कर लें कि क्या बातचीत के लिए सभी रूट आइटम एक ही टेबल पर हैं। यदि वे नहीं करते हैं, तो मैं वांछित फ़ोल्डर का चयन करने के लिए संवाद के साथ उपयोगकर्ता को संकेत देना चाहूंगा।

यहाँ मेरा वर्तमान प्रयास है:

Sub moveMailToConversationFolder()

    Dim olNs As NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim selectedItem As Object
    Dim item As Outlook.mailItem ' Mail Item
    Dim folder As Outlook.MAPIFolder ' Current Item's Folder
    Dim conversation As Outlook.conversation ' Get the conversation
    ' Dim ItemsTable As Outlook.table ' Conversation table object
    Dim mailItem As Object
    Dim mailparent As Object

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    ' On Error GoTo MsgErr
    ' // Must Selected Item.
    Set selectedItem = Application.ActiveExplorer.Selection.item(1)

    ' // If Item = a MailItem.
    If TypeOf selectedItem Is Outlook.mailItem Then
        Set item = selectedItem
        Set conversation = item.GetConversation

        If Not IsNull(conversation) Then
            ' Set ItemsTable = conversation.GetTable

            ' MsgBox conversation.GetRootItems.Count

            For Each mailItem In conversation.GetRootItems ' Items in the conversation.
                If TypeOf mailItem Is Outlook.mailItem Then
                    Set folder = mailItem.Parent
                    item.move GetFolder(folder.FolderPath)
                End If
            Next
        End If
    End If

End Sub

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

Answer 1

यहाँ एक समान स्क्रिप्ट है जो मदद कर सकती है।

मेरा उपयोग मामला थोड़ा अलग है - मैं मैन्युअल रूप से कस्टम दृश्य में आइटम का चयन करता हूं और फिर टूलबार बटन से स्क्रिप्ट चलाता हूं। (मुझे लगता है कि बातचीत ठीक से ट्रैक नहीं की गई है, और कभी-कभी एक वार्तालाप विभिन्न परियोजनाओं में बदल जाता है।)

Option Explicit
Option Base 0

Public Sub MoveToFirstFolder()
  Dim oNamespace As Outlook.NameSpace, oSelection As Outlook.Selection
  Dim oFolder As Outlook.MAPIFolder
  Dim oItem As Object, i As Integer

  Set oNamespace = Application.GetNamespace("MAPI")

  Set oSelection = oNamespace.Application.ActiveExplorer.Selection
  If oSelection.Count < 2 Then Exit Sub

  Set oFolder = getFirstNonDefaultFolder(oSelection)
  If oFolder Is Nothing Then Exit Sub

  ' move items
  For i = 1 To oSelection.Count
    Set oItem = oSelection.Item(i)
    If Not oItem.Parent = oFolder Then
      oSelection.Item(i).Move oFolder
    End If
  Next i
End Sub

Private Function getFirstNonDefaultFolder(oSelection As Outlook.Selection) As Outlook.Folder
  Dim oItem As Object
  Dim oFolder As Outlook.Folder
  Dim i As Integer

  ' get folder
  For i = 1 To oSelection.Count
    Set oFolder = oSelection.Item(i).Parent
    Debug.Print ">" & oFolder.FullFolderPath
    If Not isDefaultFolder(oFolder) Then
      Set getFirstNonDefaultFolder = oFolder
      Exit Function
    End If
  Next i
End Function

Private Function isDefaultFolder(oFolder As Outlook.Folder) As Boolean
  Dim oNamespace As Outlook.NameSpace
  Dim defaultFolders, fldrNum

  isDefaultFolder = False

  defaultFolders = Array( _
    olFolderInbox, olFolderSentMail, _
    olFolderDrafts, _
    olFolderDeletedItems, olFolderJunk, _
    olFolderOutbox, _
    olFolderCalendar, _
    olFolderContacts, olFolderSuggestedContacts, _
    olFolderNotes, _
    olFolderTasks, olFolderToDo, _
    olFolderJournal, _
    olFolderConflicts, olFolderLocalFailures, olFolderServerFailures, olFolderSyncIssues, _
    olFolderManagedEmail, olPublicFoldersAllPublicFolders _
  )

  Set oNamespace = Application.GetNamespace("MAPI")

  On Error Resume Next  ' Non-existant DefaultFolders cause errors
  For Each fldrNum In defaultFolders
    If oFolder = oNamespace.GetDefaultFolder(fldrNum) Then
      If Err.Number Then
        Err.Clear
      Else
        isDefaultFolder = True
        Exit Function
      End If
    End If
  Next fldrNum
End Function