Can I create a macro that accesses a Shared Email???

[Mister H]

Hi All:

I have been using this code to save email messages in a sub folder of my inbox. I am now trying to revise it to work the same for a bunch of people but I need to reference the Shared Email box as opposed to my own (Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4) ADIs Completed")). here is the code I am currently using:

Sub Save_Emails_As_MSG_Files_To_Selected_Folder()
'Constructed by Mark Huggins for the ARIR Processing Staff October 2015.
  Dim folder As MAPIFolder
  Dim Item As Object
  Dim mAttachment As Attachment
  Dim Path As String, Subject As String, Value As String
  Dim Success As Boolean
  Dim I As Integer
  Dim StrSavePath As String
  Dim objFolder As Object
  Dim EmailCount As Integer
  Const TemporaryFolder = 2
  Dim FSO As Object
  Dim xl As Object
  On Error GoTo ErrorHandler
#If Develop Then
  Set folder = ActiveExplorer.CurrentFolder
#Else
  
  Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4)  ADIs Completed")
#End If
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set xl = CreateObject("Excel.Application")
  On Error GoTo 0
    StrSavePath = BrowseForFolder
    
    If StrSavePath = "" Then
    MsgBox ("ERROR - CAUTION, NO EMAILS SAVED..." & Chr(10) & Chr(10) & "Your ADI Emails WERE NOT SAVED as msg files.  They have all remained in the folder:" & Chr(10) & "4)  ADIs Completed" & Chr(10) & Chr(10) & "***  NOTE  ***" & Chr(10) & Chr(10) & "You MUST choose a folder to save them to.  You will have to run the macro:" & Chr(10) & " 'Save ADI Emails as MSG Files' again.")
    GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
    On Error Resume Next
    Set objFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4)  ADIs Completed")
    EmailCount = objFolder.Items.Count
    Set objFolder = Nothing
 
  For Each Item In folder.Items
    
    If Item.Class = olMail Then
      
      For Each mAttachment In Item.Attachments
        Select Case mAttachment.Type
          Case olByValue
            
            Select Case FSO.GetExtensionName(mAttachment.Filename)
              Case "xls", "xlsx", "xlsm"
                
                Path = FSO.BuildPath( _
                  FSO.GetSpecialFolder(TemporaryFolder), _
                  FSO.GetTempName & "." & FSO.GetExtensionName(mAttachment.Filename))
                mAttachment.SaveAsFile Path
                
                Success = GetValue(xl, Path, Value)
                
                Kill Path
                
                If Success Then
                
                  Subject = Trim$(ValidFileName(Item.Subject))
                  Value = Trim$(ValidFileName(Value))
                  
                  If Subject = "" Then Subject = "(No subject)"
                  
Path = NewFileName(StrSavePath & Subject & " " & Value & ".msg")
                  Item.SaveAs Path
                  
                  Exit For
                End If
            End Select
        End Select
      Next
    End If
  Next
  xl.Quit
  
  For I = folder.Items.Count To 1 Step -1
    folder.Items(I).Move Outlook.Session.GetDefaultFolder(olFolderDeletedItems)
  Next
MsgBox ("COPY and MOVE COMPLETED:" & Chr(10) & Chr(10) & "The " & EmailCount & " emails that were in the folder:   4)  ADIs Completed    have now been saved as msg files.  They have been saved to the folder:" & Chr(10) & Chr(10) & StrSavePath & Chr(10) & Chr(10) & "ALL of the emails have been moved to your Deleted Items folder.")
  
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
ExitSub:
End Sub

I have been trying to find a code that would just reference the CURRENT (Active) Folder but cant seem to find anything. I did find a script that showed me the path of the actual folder I want but it doesn't seem to help me. I am very unfamiliar with Outlook VBA. This was the returned address of the folder:

FolderPath: :
\\Revenue, Sud (MS)\Inbox\ROCSB\Completed

ANY assistance or redirect would be greatly appreciated.

THANKS,
Mark

[Mister H]

No Answer Received ????

Hmmmmm Not as easy as I had hoped... HOWEVER I am still hopeful that someone can understand Outlook VBA and get me moving in the right direction....

THANKS

[skatonni]

You have the answer in your code.

I am guessing you do not have a line like this

#Const Develop = True '  or False

This is not necessary. Comment or delete.

#If Develop Then
    Set folder = ActiveExplorer.CurrentFolder
#Else
    Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4)  ADIs Completed")
#End If

Simply use

Set folder = ActiveExplorer.CurrentFolder

or

Set folder = Outlook.Session.Folders("Revenue, Sud (MS").Folders("Inbox").Folders("ROCSB").Folders("Completed")

[Mister H]

THANKS skatonni... Your Expertise is VERY Much Appreciated I have not had a chance to try it out but I am confidant it will do the trick