Same VBA code to move mails within multiple mailbox

[maxfactor]

Hi dears!


I am into an Enterprise environment, where I have my main mailbox and moreover I have full access permissions on another mailbox.
So I have configured Outlook just with my mailbox but it let me automatically see two mailbox on the left: MY-ONE and the OTHER-ONE.


I'm trying to write a vba script to move mails within the same mailbox, just into another folder (so not from one mailbox to the other one).


The vba script is configured as an action of a rule, and it receives an Outlook.MailItem as a parameter.
In other words I want to manually execute that rule on any folder of any mailbox and get a move of matching mail (based on subject) into another folder (based on subject) in the same mailbox of the Outlook.MailItem object.


This is what I have done until now (it is boring but I will comment every line to explain what it does in my mind):




Public Sub AppResponseManage(Item As Outlook.MailItem)


Dim myOlApp
Dim myOlNameSpace
Dim objInboxFolder
Dim objProjectFolder
Dim itms
Dim ItemCount, UnReadItemCount
Dim a, b, c, d


Set myOlApp = Item.Application ' define the app environment based on the mail received as a parameter
Set myOlNameSpace = myOlApp.Session ' define the namespace environment based on the mail received as a parameter


Dim mailbox, inbox


Set mailbox = Item.Parent.Store.GetRootFolder ' get the mailbox to which the mail belongs
Set inbox = Item.Parent.Store.GetDefaultFolder(olFolderInbox) ' get the inbox folder of the above mailbox


Set objInboxFolder = myOlNameSpace.folders(mailbox.Name).folders(inbox.Name) ' define the inbox folder based on the two above


Dim sendName, errorName, deviceName, ifName, mailSubject, exists As String
'here there will be some simple actions that extract sender-name and other words from the mail subject (some of these will represent the folder path where the mail will be moved)


'as a first check I verify if already exists a folder named as the sender (in the inbox folder):
CheckSender:
a = 1
Do Until a > objInboxFolder.folders.Count ' THIS IS THE FIRST BIG PROBLEM : THE COUNT IS MOST OF TIME ZERO AND VERY VERY RARELY TEN (THE TRUTH, AS I HAVE TEN FOLDERS IN THE INBOX)

' HERE I STOP COMMENTING: IT IS MANDATORY TO SOLVE THE ABOVE PROBLEM FOR ME BEFORE GOING ON ;-)

If objInboxFolder.folders.Item(a).Name = sendName Then GoTo CheckError
a = a + 1
Loop
GoTo CreateAll


CheckError:
MsgBox objInboxFolder.folders.Item(a).Name & " exists"
b = 1
Do Until b > objInboxFolder.folders.Item(a).Count
If objInboxFolder.folders.Item(a).folders.Item(b).Name = errorName Then GoTo CheckDevice
b = b + 1
Loop
GoTo CreateError


CheckDevice:
MsgBox objInboxFolder.folders.Item(a).folders.Item(b).Name & " exists"
c = 1
Do Until c > objInboxFolder.folders.Item(a).folders.Item(b).Count
If objInboxFolder.folders.Item(a).folders.Item(b).folders.Item(c).Name = deviceName Then GoTo CheckInterface
c = c + 1
Loop
GoTo CreateDevice


CheckInterface:
MsgBox objInboxFolder.folders.Item(a).folders.Item(b).folders.Item(c).Name & " exists"
d = 1
Do Until d > objInboxFolder.folders.Item(a).folders.Item(b).folders.Item(c).Count
If objInboxFolder.folders.Item(a).folders.Item(b).folders.Item(c).folders.Item (d).Name = ifName Then GoTo MoveMail
d = d + 1
Loop


CreateInterface:
' Set objProjectFolder = objInboxFolder.folders(sendName).folders(errorName).folders(deviceName).fol ders.Add(ifName)
GoTo MoveMail


CreateDevice:
' Set objProjectFolder = objInboxFolder.folders(sendName).folders(errorName).folders.Add(deviceName) .folders.Add(ifName)
GoTo MoveMail


CreateError:
' Set objProjectFolder = objInboxFolder.folders(sendName).folders.Add(errorName).folders.Add(deviceN ame).folders.Add(ifName)
GoTo MoveMail


CreateAll:
' Set objProjectFolder = objInboxFolder.folders.Add(sendName).folders.Add(errorName).folders.Add(dev iceName).folders.Add(ifName)

MoveMail:
MsgBox Item.Subject


End Sub


Thanks in advance
MaxFactor

[gmayor]

It appears that you are trying to process all the folders and sub folders to locate a particular folder 'sendName' that being the case use the following.I have not defined sendName or added the processing.

Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace

    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
'##############
        If olFolder.Name = sendName Then
            'do stuff
        End If
'##############
        If olFolder.folders.Count > 0 Then
            For Each SubFolder In olFolder.folders
                cFolders.Add SubFolder
            Next SubFolder
        End If
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Exit Sub

[maxfactor]

Thank you gMayor, but I need to intercept the inbox folder of the mailbox of the mailbox to which the mail belongs.

The code

Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.GetDefaultFolder(olFolderInbox)

will return the inbox folder of the main mainbox, while it could belong to a secondary one (over which on which I have full access permissions).

So, starting from the MailItem object I have to get the right mailbox, and so I was thinking about something like:

Set myOlApp = Item.Application
Set olNS = myOlApp.Session
cFolders.Add olNS.GetDefaultFolder(olFolderInbox)

but something does not work because cFolders.Count is always 1 (and I know it is not so).

Am I trying to get something impossible? Thanks

[gmayor]

You could change

cFolders.Add olNS.GetDefaultFolder(olFolderInbox)

to

cFolders.Add olNS.PickFolder

which would allow you to select the top level folder

or working from the message Item olItem

cFolders.Add olItem.Parent

should give you the folder the current item is in as the top level folder. This should be fine as long as you are working in the same account.