Saving Emails as Messages Problems with Access Data Collection et

  • Thread starter Thread starter Chris
  • Start date Start date
Status
Not open for further replies.
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-----
 
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

"Chris" wrote:


> 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-----
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
J Saving Send emails to a folder on the server Outlook VBA and Custom Forms 63
R Saving Emails and Attachments as .msg file Using Outlook 3
M Saving emails using Visual Basic - Selecting folder with msoFileDialogFolderPicker Outlook VBA and Custom Forms 6
I Saving attachments from multiple emails and updating file name Outlook VBA and Custom Forms 0
D Saving Selected Emails as PDF and saving Attachments Outlook VBA and Custom Forms 6
M Dialog called up multiple times when saving emails from macro Outlook VBA and Custom Forms 2
Kevin H Remotely saving emails Using Outlook 1
S trouble with Outlook 2010 saving sent emails Using Outlook 2
D Saving outlook emails in html and attachments Using Outlook 4
S Automate saving of attachments on new incoming emails Outlook VBA and Custom Forms 3
Rupert Dragwater Background colors not saving in Outlook 365 Using Outlook 15
CWM330 Saving Data: Don't check certain folders Using Outlook 2
D Outlook 2016 Outlook not saving Sent Items Using Outlook 4
I Error saving screenshots in a custom form in outlook 2016, outlook 365 - ok in outlook 2013, outlook 2010 Outlook VBA and Custom Forms 5
M Adding Subject to this Link-Saving VBA Outlook VBA and Custom Forms 5
L Attachment saving and tracking - PLEASE help! Outlook VBA and Custom Forms 5
B Saving items under a folder Using Outlook 3
R Quick Access view in File Explorer when saving attachments Using Outlook 0
N Saving And Deleting Outlook Attachments with Unknown Error Message Outlook VBA and Custom Forms 1
V Saving attachment from outlook in My Documents Outlook VBA and Custom Forms 14
A saving attachement to folder named the same as rule name Outlook VBA and Custom Forms 0
T Saving all email to file folder in Windows Using Outlook 2
J Saving attachments from specific sender (phone number) to specific folder on hard drive Using Outlook 3
C Saving Outlook attachments and links to attachments with VBA Outlook VBA and Custom Forms 2
R Outlook 2010 Modify Style "Do not check spelling or grammar" not saving Outlook VBA and Custom Forms 0
R Outlook Office 365 not saving addresses Using Outlook 0
A Keep color categories when saving vCards Using Outlook 1
P Saving All Messages to the Hard Drive Using VBA Outlook VBA and Custom Forms 5
e_a_g_l_e_p_i question about saving my .pst so I can import it to my Outlook after I build a new system Using Outlook 10
S Editing an email with notes and saving it for record using Macro Outlook VBA and Custom Forms 3
O Saving Attachments to folder on disk and adding Initials to end of file name Outlook VBA and Custom Forms 9
J Outlook 2013 crashes saving VBA & clicking tools | digital signature Outlook VBA and Custom Forms 1
bifjamod Saving sent email to specific folder based on category with wildcard Outlook VBA and Custom Forms 1
N Saving .msg as sent item on send Outlook VBA and Custom Forms 1
erichamion Changes to meeting body not properly saving Outlook VBA and Custom Forms 4
A ItemAdd on Imap Folder get endless loop after saving item Using Outlook 5
T Saving Outlook 2010 email with attachments but read the email without Outlook Using Outlook 2
T From Field Blank when saving to folder other than Sent items Using Outlook 2
L Outlook DST (Daylight Saving Time) problem Using Outlook 0
F Using Outlook 2007 as an IMAP Mail Station Without Saving Data Locally Using Outlook 2
E Saving Changes To Edited E-Mail Received Message Using Outlook 0
D File Lock issue when saving message from Outlook to new folder Using Outlook 1
D Remove extension while saving attachments Using Outlook 1
K Printing & Saving Outlook Contacts Using Outlook 3
S Not saving attachments in the Sent Folder Using Outlook 2
W Default Saving a message as text Using Outlook 2
R Outlook 2007 QAT buttons not saving Using Outlook 2
C Exchange 2003 - Outlook 2003 - Calendar entries saving over each other Using Outlook 2
J Saving Published Outlook Form as msg Using Outlook 1
J Saving recent colors used for fonts in an email? Using Outlook 1

Similar threads

Back
Top