?
Solved

Can firing this macro be automated?

Posted on 2006-11-15
8
Medium Priority
?
317 Views
Last Modified: 2010-04-08
Blue Devil Fan graciously provided me with the below macro code.

In a nutshell, when fired, it saves all of the attachments on all of the emails in  folder to a network drive.
It also saves them to a subfolder with this hieracrchy: Sender Name > Date Sent
It then strips the attachment from the email and drops a hyperlink in the message body pointed to the saved file on the network.

It works great.  Now I would like to know if it can be taken even one step further.  Can it run on it's own when a message is received.  I need to take some time off and need these attachments to continue to  be saved as they come in orf it will cause BIG problems for me.  I would MUCH rather have this automated then to rely on someone else doing it in my absence.

What are the options (any?).  Please note that the folder which receives these messages (the ones with attachments that need to be saved) is a PUBLIC FOLDER.

-----Begin macro code-------------------
Sub SaveFolderAttachments()
    Dim olkMessage As Outlook.MailItem, _
        olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        myOrt As String, _
        myPath As String
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    myOrt = "J:\Programming\"
    For Each olkMessage In Application.ActiveExplorer.CurrentFolder.Items
        myPath = myOrt & olkMessage.SenderName
        If Not objFSO.FolderExists(myPath) Then
            objFSO.CreateFolder (myPath)
        End If
        myPath = myPath & "\" & Format(olkMessage.SentOn,"MM-DD-YYYY")
       If Not objFSO.FolderExists(myPath) Then
            objFSO.CreateFolder (myPath)
        End If
        myPath = myPath & "\"
        If olkMessage.Attachments.Count > 0 Then
            olkMessage.HTMLBody = olkMessage.HTMLBody & "<br><br><b>Saved Attachments</b><br>"
            For Each olkAttachment In olkMessage.Attachments
                With olkAttachment
                    .SaveAsFile myPath & olkAttachment.FileName
                    olkMessage.HTMLBody = olkMessage.HTMLBody & "<a href=""file://" & myPath & olkAttachment.FileName & """>" & olkAttachment.FileName & "</a><br>"
                    .Delete
                End With
            Next
            olkMessage.Save
        End If
    Next
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

-----End macro code-------------------
0
Comment
Question by:snyperj
  • 4
  • 4
8 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 17952039
Greetings, snyperj.

Yes, this is possible, but perhaps not in the way you imagine.  It can process messages as they are received, but Outlook macros only run when Outlook is open and running.  If you are out of the office, then for this to work you'd have to leave your computer logged in and running the entire time for this to work.

Cheers!
0
 

Author Comment

by:snyperj
ID: 17952546
OK, so saying that I was able to leave my computer on - what would  need to do ti have the processing happen as each message is received.  Again, bearing in mind thtat this is a Public Folder we are talking about.


I know that through Folder Assistant, I can have a copy of the emails automatically forwarded from the Public Folder to my personal inbox even if my computer is not running.  So something, somewhere is monitoring the folder at all times in order to do that, right?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 17965171
snyperj,

The simplest solution is to use the code below with an Outlook rule.  Set the rule fire on messages as they arrive.  Set the rule's action to run a script and choose this script.

Sub SaveFolderAttachments(Item As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        myOrt As String, _
        myPath As String
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    myOrt = "J:\Programming\"
    myPath = myOrt & Item.SenderName
    If Not objFSO.FolderExists(myPath) Then
        objFSO.CreateFolder (myPath)
    End If
    myPath = myPath & "\" & Format(Item.SentOn,"MM-DD-YYYY")
    If Not objFSO.FolderExists(myPath) Then
        objFSO.CreateFolder (myPath)
    End If
    myPath = myPath & "\"
    If Item.Attachments.Count > 0 Then
        Item.HTMLBody = Item.HTMLBody & "<br><br><b>Saved Attachments</b><br>"
        For Each olkAttachment In Item.Attachments
            With olkAttachment
                .SaveAsFile myPath & olkAttachment.FileName
                Item.HTMLBody = Item.HTMLBody & "<a href=""file://" & myPath & olkAttachment.FileName & """>" & olkAttachment.FileName & "</a><br>"
                .Delete
            End With
        Next
        Item.Save
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 

Author Comment

by:snyperj
ID: 17965503
Right- but how to do that on a Public Folder?  I thought you couldn't do rules on a Public Folder, only use the Folder Assistant and I don't see any options there to run script.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 17998972
Sorry to be so slow getting back to you on this.  You're right, what I posted isn't going to work for a public folder.  I wasn't thinking about the public folder aspect when I made my previous post.  For a public folder we're going to need the following in addition to what I posted above.  

'This code goes in the ThisOutlookSession module.
Dim WithEvents olkFolder As Outlook.Items

Private Sub Application_Quit()
    Set olkFolder = Nothing
End Sub

Private Sub Application_Startup()
    'Change the public folder path on the following line
    Set olkFolder = OpenMAPIFolder("\Public Folders\All Public Folders\My Public Folder").Items
End Sub

Private Sub olkFolder_ItemAdd(ByVal Item As Object)
    If Item.Class = olMail Then
        SaveFolderAttachments Item
    End If
End Sub

'This code can go in any module
'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)
    Else
        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("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function

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

Author Comment

by:snyperj
ID: 18048841
I copied everything to the modules as described.  However, I must not have something quite right.

When I open outlook I am getting:

Run-time error '-2147221233(8004010F)':
The operation failed.  An object could not be found.

>>when I click "debug" I am taken to the following line near the bottom of the Function OpenMapiFolder()

Set flr = flr.Folders(szDir)

What to do, what to do?
0
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 total points
ID: 18050311
That error means that the public folder path has an error in it.  The routine that opens the folder isn't able to find one of the fodlers in the path.
0
 

Author Comment

by:snyperj
ID: 18054895
You were right of course.  I had forgotten the leading slash before Public Folders.  It works!  Thanks.

Followup question can be found here:
http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_22079327.html
0

Featured Post

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Outlook for dependable use in a very small business   This article is about using the Outlook application (part of Microsoft Office) in a very small business, or for homeowners where dependability and reliability are critical requirements. This …
This article will help to fix the below errors for MS Exchange Server 2016 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.
Suggested Courses

850 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question