Solved

Can firing this macro be automated?

Posted on 2006-11-15
8
305 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
 

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
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 
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 500 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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
Set OWA language and time zone in Exchange for individuals, all users or per database.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

744 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

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now