Solved

Adding a line of code to this macro that will move a mail message to another folder.

Posted on 2006-12-01
3
311 Views
Last Modified: 2010-04-08
Blue Devil fan provided me with the following code which strips an attachment off of mail message and saves the attachment to a network folder.  It then places a hyperlink the saved file path in the original message body.  Works great.

I would like to see if one more piece of functionality to it.  After the attachment is stripped off and saved, I would like to move the remaining message out of the public folder and into another public folder.  The other folder is beneath this one.

So in other words say the Public folder where I run this macro is
\Public Folders\All Public Folders\MyFolder

I would like to move it to:
\Public Folders\All Public Folders\MyFolder\processed

Currently I am moving it manually but it would be great if just a line of additional code in the macro below could do it?

Thanks!

-----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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 18055498
Try this.

Sub SaveFolderAttachments()
    Dim olkMessage As Outlook.MailItem, _
        olkAttachment As Outlook.Attachment, _
        olkFolder As Outlook.MAPIFolder, _
        objFSO As Object, _
        myOrt As String, _
        myPath As String, _
        intIndex As Integer
    Set olkFolder = OpenMAPIFolder("\Public Folders\All Public Folders\MyFolder\processed")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    myOrt = "J:\Programming\"
    For intIndex = Application.ActiveExplorer.CurrentFolder.Items.Count To 1 Step -1
        Set olkMessage = Application.ActiveExplorer.CurrentFolder.Items.Item(intIndex)
        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
            olkMessage.Move olkFolder
        End If
    Next
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

'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: 18138331
Thanks.  I'll probably be back again some day on this topic.  I never got it to work quite right but have had to move on to other, pressing, items.  Thanks for the help.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 18142827
Ok.  I'll be here when you're ready to pick it up.
0

Featured Post

SuperAntiSpyware Licenses Discounted by 25% !

Exclusive offer to Experts Exchange Members!
Buy SuperAntiSpyware License(s) from us and save 25% on the regular purchase price.
- Includes Full SuperAntiSpyware Vendor Support Entitlements
- Your Subscription does not begin until you activate your license
- Buy for your friends

Question has a verified solution.

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

How to resolve IMCEAEX NDRs in Exchange or Exchange Online related to invalid X500 addresses.
Changing a few Outlook Options can help keep you organized!
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
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: …

737 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