Solved

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

Posted on 2006-12-01
3
307 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
  • 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

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

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

What does UTC stand for?  “Coordinated Universal Time” – Think of this as the true time on Planet Earth that never changes with the exception of minor leap seconds here and there to account for the changes in the planet's rotation.   What does th…
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
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…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

770 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