Saving Emails as Messages Problems with Access Data Collection et

[Chris]

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

 

[Chris]

OK, I discovered the problem with the access data collections. The files
name ends up being too large so I put a check in to check the length of the
file name and if it is too long, ask the user to rename it with the original
filename being the default.

The Code is:

If Len(NewFileName) > 145 Then
TooLong:
NewFileName = InputBox("Please Enter a New File Name that is
shorter than 146 characters." & Chr$(13) & "Current file name is " &
Len(NewFileName) & "characters.", _
"File Name Too Long", NewFileName)
If Len(NewFileName) > 145 Then
MsgBox "File name is still too long." & Chr$(13) & "Current file
name is " & Len(NewFileName) & "characters.", vbOKOnly, "File Name is Too
Long"
GoTo TooLong
Else
TheEmail.SaveAs EmailPath & NewFileName, olMSG
End If