> Ok Community,
>
> Ken helped me get 97% of the emails saved as ".msg" format outside of
> Outlook. However, due to the nautre of what I am copying, I truly need 100%
> saved. One of the problems I have identified are Access Data Collections.
> Some have a messageclass of IPM.InfoPath.Form.InfoPath and others are
> IPM.Note. The difference are whether or not the forms were sent via the HTML
> option in Access or as an InfoPath form. The source doesn't matter because
> if it is in the mail folder, it must be copied.
>
> Another problem I noted, is that even though the code tells it to, it does
> not apply the Category "Not Copied" (category exists) to all items not
> copied. It also doesn't apply a category that has been added as a test
> immediately after instatiating the item but those items copy out as the msg
> format.
>
> Finally, I have seen many examples of how to step through the Outlook Folder
> structure for a pst (not an Exchange mailbox), I need to be able to recreate
> that folder structure externally and then copy the emails inside that folder
> as well. I am assuming that the email copies would occur immediately after I
> have created the folder using existing code (nested loops). The nice thing
> is that due to space limitations at our location, the save location will have
> to be the Desktop on the C drive (C:\Users\<username>\Desktop\MailBurn\" and
> not on a network location. I will need to recreate the entire folder structure
>
> I am including the existing text to help solve the first two issues. Thanks
> to one and all for your time and assistance with these problems.
>
> Chris
>
> -----CODE START-----
> Public Sub ExportSAR()
>
> Dim TheEmail As Object
> Dim ReportEmail As ReportItem
> Dim eItem As Outlook.Items
> Dim EmailNS As NameSpace
> Dim fldrCount, EmailPath2, NbrItem, myfolder
> Dim strSubj, strTime, strSend, mailClassCheck, EmailPath As String
> Dim NewFileName, ReportHeader As String
> Dim Cats
> Dim CheckErr, Exists As Boolean
>
> CheckErr = False
> Set EmailNS = Application.GetNamespace("MAPI")
> Set myfolder = Application.ActiveExplorer.CurrentFolder
> NbrItem = myfolder.Items.Count
> On Error GoTo Error_Handler
>
> EmailPath = BrowseForFolderShell
> MsgBox EmailPath
> 'EmailPath = InputBox("Enter the save folder location:", "Email Save
> Path", CurDir)
> For i = 1 To NbrItem
> Set TheEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
> TheEmail.Categories = TheEmail.Categories & ";" & "Red Category"
> mailClassCheck = TheEmail.MessageClass
> If Left(mailClassCheck, 6) = "REPORT" Or Left(mailClassCheck, 6) =
> "Report" Or Right(mailClassCheck, 8) = "InfoPath" Then
> Set ReportEmail =
> Application.ActiveExplorer.CurrentFolder.Items.Item(i)
> If ReportEmail.Subject = "" Then strSubj = "no subject"
> If Right(ReportEmail.MessageClass, 2) = "DR" Then ReportHeader =
> "DeliveryReport" Else ReportHeader = "Read Receipt"
>
> strSubj = Replace(ReportEmail.Subject, "/", "-")
> strSubj = Replace(strSubj, "\", "-")
> strSubj = Replace(strSubj, ":", "--")
> strSubj = Replace(strSubj, "?", sReplace)
> strSubj = Replace(strSubj, "*", sReplace)
> strSubj = Replace(strSubj, Chr(34), sReplace)
> strSubj = Replace(strSubj, "<", sReplace)
> strSubj = Replace(strSubj, ">", sReplace)
> strSubj = Replace(strSubj, "|", sReplace)
> strTime = Replace(ReportEmail.CreationTime, "/", "-")
> strTime = Replace(strTime, "\", "-")
> strTime = Replace(strTime, ":", ".")
> strTime = Replace(strTime, "?", sReplace)
> strTime = Replace(strTime, "*", sReplace)
> strTime = Replace(strTime, Chr(34), sReplace)
> strTime = Replace(strTime, "<", sReplace)
> strTime = Replace(strTime, ">", sReplace)
> strTime = Replace(strTime, "|", sReplace)
> NewFileName = ReportHeader & "_" & strSubj & strTime & ".msg"
>
> If NewFileName <> "" Then
> ReportEmail.SaveAs EmailPath & NewFileName, olMSG
> Else
> MsgBox "No file name was entered. Operation aborted.", 64,
> "Cancel Operation"
> Exit Sub
> End If
> GoTo Step1
> End If
> If TheEmail.Subject = "" Then strSubj = "no subject"
>
> strSend = Replace(TheEmail.SenderName, "/", "-")
> strSend = Replace(strSend, "\", "-")
> strSend = Replace(strSend, ":", "--")
> strSend = Replace(strSend, "?", sReplace)
> strSend = Replace(strSend, "*", sReplace)
> strSend = Replace(strSend, Chr(34), sReplace)
> strSend = Replace(strSend, "<", sReplace)
> strSend = Replace(strSend, ">", sReplace)
> strSend = Replace(strSend, "|", sReplace)
> strSubj = Replace(TheEmail.Subject, "/", "-")
> strSubj = Replace(strSubj, "\", "-")
> strSubj = Replace(strSubj, ":", "--")
> strSubj = Replace(strSubj, "?", sReplace)
> strSubj = Replace(strSubj, "*", sReplace)
> strSubj = Replace(strSubj, Chr(34), sReplace)
> strSubj = Replace(strSubj, "<", sReplace)
> strSubj = Replace(strSubj, ">", sReplace)
> strSubj = Replace(strSubj, "|", sReplace)
> strTime = Replace(TheEmail.ReceivedTime, "/", "-")
> strTime = Replace(strTime, "\", "-")
> strTime = Replace(strTime, ":", ".")
> strTime = Replace(strTime, "?", sReplace)
> strTime = Replace(strTime, "*", sReplace)
> strTime = Replace(strTime, Chr(34), sReplace)
> strTime = Replace(strTime, "<", sReplace)
> strTime = Replace(strTime, ">", sReplace)
> strTime = Replace(strTime, "|", sReplace)
> NewFileName = strSend & "_" & strTime & "_" & strSubj & ".msg"
>
> If NewFileName <> "" Then
> TheEmail.SaveAs EmailPath & NewFileName, olMSG
> Else
> MsgBox "No file name was entered. Operation aborted.", 64,
> "Cancel Operation"
> Exit Sub
> End If
> Step1:
> strSubj = ""
> strTime = ""
> Next i
> GoTo Done
>
> Error_Handler:
> If TheEmail Is Nothing Then
> MsgBox Err.Number & ":" & Err.Description
> Else
> MsgBox TheEmail.MessageClass & Chr$(13) & TheEmail.Subject & Chr$(13) &
> Err.Number & ": " & Err.Description
> TheEmail.Categories = TheEmail.Categories & ";" & "Not Copied"
> TheEmail.Save
> End If
> Resume Next
>
> Done:
> End Sub
>
> Public Function BrowseForFolderShell(Optional Hwnd As Long = 0, Optional
> sTitle As String = "Browse for Folder", Optional BIF_Options As Integer,
> Optional vRootFolder As Variant) As String
>
> Dim objShell As Object
> Dim objFolder As Variant
> Dim strFolderFullPath As String
>
> Set objShell = CreateObject("Shell.Application")
> Set objFolder = objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options,
> vRootFolder)
>
> If (Not objFolder Is Nothing) Then
> '// NB: If SpecFolder= 0 = Desktop then ....
> On Error Resume Next
> If IsError(objFolder.Items.Item.Path) Then strFolderFullPath =
> CStr(objFolder): GoTo GotIt
> On Error GoTo 0
> '// Is it the Root Dir?...if so change
> If Len(objFolder.Items.Item.Path) > 3 Then
> strFolderFullPath = objFolder.Items.Item.Path '&
> Application.PathSeparator
> Else
> strFolderFullPath = objFolder.Items.Item.Path '& Application.
> End If
> Else
> '// User cancelled
> GoTo XitProperly
> End If
>
> GotIt:
> BrowseForFolderShell = strFolderFullPath & "\"
>
> XitProperly:
> Set objFolder = Nothing
> Set objShell = Nothing
>
> End Function
> -----CODE END-----