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