We help IT Professionals succeed at work.

Converting VBA Script to Exchange Script (Public Folder)

BPeb asked
Medium Priority
Last Modified: 2010-08-05
Recently I needed to write code to save and remove certain attachaments from incoming emails.  I wrote the code in my personal Outlook account and it works well.  The assumption when I wrote did this was that the administrator would create dedicated account and I'd drop it there all would be fine, but nope, the admin wants to use a public folder instead.  

Though I have lots of VBA experience I'm new to Outlook/Exchange coding, but I have been able to get the code I need figured so far.  But I need tips on converting my code to run in a public folder (I have admin rights to the folder).  

So far I've been able to figure out that I need the following subs and that my code has to be in the 'ItemAdd' sub, but what do I need to change in the real code below to make it run in a public folder?  I have some ideas, but I don't want to destroy what works without some idea of where I'm going first.  Tips, suggestions, links, samples?  

Thanks for looking, hope you can help.

== I know I need these ===
Private Sub Application_Quit()
Private Sub Application_Startup()
Private Sub oFolder_ItemAdd(ByVal Item As Object)

== Code I need to convert ===
Private Sub Application_NewMail()
Dim olApp As Outlook.Application, olNS As Outlook.NameSpace, objMsg As Outlook.MailItem
Dim olFld As Outlook.MAPIFolder, oMail As Outlook.MailItem, objAttachments As Outlook.Attachments
Dim strFile As String, ItemNo As Long, AttachNo As Long

    'Use Application object to avoid macro warning message to user
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFld = olNS.GetDefaultFolder(olFolderInbox)
    olFld.Items.Sort "Received", False
    If olFld.Items(1).Class = olMail Then 'Must be a mail object
        Set oMail = olFld.Items.GetFirst
        Set objAttachments = olFld.Items(1).Attachments
        AddLogEntry FilePath_Logfile, "Processing email '" & oMail.Subject & "' from " & oMail.SenderName, Null
        If objAttachments.Count > 0 Then  'Must have an attachement
            AttachNo = objAttachments.Count
            For ItemNo = 1 To AttachNo
                strFile = Trim(objAttachments.Item(1).FileName)
                If Right$(strFile, 3) = "txt" Then
                    strFile = FilePath_Out & strFile
                    If Len(Dir(strFile)) > 0 Then
                        MoveFile FilePath_Out & Trim(objAttachments.Item(1).FileName), FilePath_BackUp & Trim(objAttachments.Item(1).FileName)
                    End If
                    objAttachments.Item(1).SaveAsFile strFile
                    'Remove attachement
                    If oMail.BodyFormat <> olFormatHTML Then
                        oMail.Body = oMail.Body & vbCrLf & "Attachment saved:" & vbCrLf & strFile
                        oMail.HTMLBody = oMail.HTMLBody & "<p>" & "Attachment saved:" & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>"
                    End If
                    AddLogEntry FilePath_Logfile, Null, "Attachment saved:" & strFile
                    'Improper file attachement type
                    AddLogEntry FilePath_Logfile, Null, "***Invalid attachment " & objAttachments.Item(ItemNo).FileName & " in '" & oMail.Subject & "'"
                End If
            Next ItemNo
            AddLogEntry FilePath_Logfile, Null, "***No attachments found in '" & oMail.Subject & "'"
        End If
    End If
    Set oMail = Nothing
    Set olFld = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub
Watch Question

Top Expert 2010
You cannot run code "inside" a public folder.  You can run code against the contents of a public folder, but it'd have to run from a workstation where Outlook was open and running.  I'm not sure that's what you want.  The only way to have code running at the Exchange server is to write it as an "event-sink".  Event-sinks are essentially macros running at the Exchange level.  They are more complex than Outlook macros and any mistakes in the code will affect the entire Exchange server, not one account or mailbox.  If you want to install Outlook on the Exchange server, or if it's already installed there, then you could write this code as VBScript or even a full VB program and run it automatically when the server is logged in.  It wouldn't be an event-sink, but it would not depend on a workstation and Outlook being open an running.

To run the code against a public folder instead of your inbox requires a bit of extra code (below) and modifying one line of your code.  Specifically, change this line

    Set olFld = olNS.GetDefaultFolder(olFolderInbox)


    Set olFld = OpenMAPIFolder("\Public Folders\All Public Folders\My Public Folder")

Here's the additional code you need.

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function

Not the solution you were looking for? Getting a personalized solution is easy.

Ask the Experts


I've seen that code and your helpful comments too on other similar questions.

I'm now thinking that the best way to handle this is to go to VB6 and write a monitoring exe.  I've seen code to do this elswhere and have made a stab at it, but am getting an error message about an object required even though I'm pretty sure I have all me references selected.  

Oh well, I'll solve that tomorrow.

Thanks for responding.
Top Expert 2010

Using VB6 would be a good solution.  You'll still have to have Outlook on the computer this runs on, but Outlook won't need to be open and running.  If you try and run your code as is from VB6, then I would expect it to have a problem.  The subs/functions that begin with Application_ will only work when run from inside Outlook.  In VB6 there is not Application object that refers to the Outlook application.  Also, if this is going to run against a public folder, then the NewMail event isn't what you need.  Instead, you'll need to trap the ItemAdd event on the folder object.  Basically, something like this:

Dim olApp As Outlook.Application, _
    olNS As Outlook.NameSpace, _
    WithEvents olPublicFolder As Outlook.Items

Private Sub Form_Load()
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    olNS.Logon "ProfileName", "password", False, True
    Set olPublicFolder = OpenMAPIFolder("\Public Folders\All Public Folders\My Public Folder").Items
End Sub

Private Sub Form_Terminate()
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Private Sub olPublicFolder_ItemAdd(ByVal Item As Object)
    'Your code goes here.  You don't need all the code you had before, just
    'that portion that process the individual item that arrived in the mailbox and
    'triggered this event.
End Sub
Access more of Experts Exchange with a free account
Thanks for using Experts Exchange.

Create a free account to continue.

Limited access with a free account allows you to:

  • View three pieces of content (articles, solutions, posts, and videos)
  • Ask the experts questions (counted toward content limit)
  • Customize your dashboard and profile

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.