N
NakedJ
I am new to VBA, and have been trying to piece together code that will
export emails that are HTML format to a location on my hard drive.
The code that I have (below) saves some of the HTML files, but not all
of them. I can't figure out what is different about the e-mails that
some are recognized as HTML and some are not.
I have tried to use "If smsg.bodyformat = olFormatHTML Then" before
the saveas, but this does not work either.
Any suggestions?
Here is the Code:
Sub ExportOutlookMessagesToDisk()
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim Prop As Outlook.UserProperty
Dim sMsg As Outlook.MailItem
Dim oAtt As Outlook.Attachment
Dim iMsgCnt As Integer
Dim iAttachCnt As Integer
Dim iRnd As Long
Set olns = ol.GetNamespace("MAPI")
Set cf = ActiveExplorer.CurrentFolder ' current folder)
On Error Resume Next
Randomize
iMsgCnt = 0
For Each sMsg In cf.Items
sMsg.SaveAs "C:\Documents and Settings\jaflint\My Documents
\email\" & StripChars(sMsg.Subject) & ".HTML", olHTML
'sMsg.Subject
'With sMsg.Attachments
' iAttachCnt = sMsg.Attachments.Count
' If iAttachCnt > 0 Then
' For Each oAtt In sMsg.Attachments
' oAtt.SaveAsFile "C:\hold\Attachments\" &
Mid(CStr(Rnd), 3) & "_" & oAtt.FileName
' Next
' End If
iMsgCnt = iMsgCnt + 1
Next
End Sub
Public Function StripChars(ByVal sStr) As String
sStr = Replace(sStr, """", "")
sStr = Replace(sStr, "'", "")
sStr = Replace(sStr, ":", "")
StripChars = sStr
End Function
Thanks,
Jason
export emails that are HTML format to a location on my hard drive.
The code that I have (below) saves some of the HTML files, but not all
of them. I can't figure out what is different about the e-mails that
some are recognized as HTML and some are not.
I have tried to use "If smsg.bodyformat = olFormatHTML Then" before
the saveas, but this does not work either.
Any suggestions?
Here is the Code:
Sub ExportOutlookMessagesToDisk()
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim Prop As Outlook.UserProperty
Dim sMsg As Outlook.MailItem
Dim oAtt As Outlook.Attachment
Dim iMsgCnt As Integer
Dim iAttachCnt As Integer
Dim iRnd As Long
Set olns = ol.GetNamespace("MAPI")
Set cf = ActiveExplorer.CurrentFolder ' current folder)
On Error Resume Next
Randomize
iMsgCnt = 0
For Each sMsg In cf.Items
sMsg.SaveAs "C:\Documents and Settings\jaflint\My Documents
\email\" & StripChars(sMsg.Subject) & ".HTML", olHTML
'sMsg.Subject
'With sMsg.Attachments
' iAttachCnt = sMsg.Attachments.Count
' If iAttachCnt > 0 Then
' For Each oAtt In sMsg.Attachments
' oAtt.SaveAsFile "C:\hold\Attachments\" &
Mid(CStr(Rnd), 3) & "_" & oAtt.FileName
' Next
' End If
iMsgCnt = iMsgCnt + 1
Next
End Sub
Public Function StripChars(ByVal sStr) As String
sStr = Replace(sStr, """", "")
sStr = Replace(sStr, "'", "")
sStr = Replace(sStr, ":", "")
StripChars = sStr
End Function
Thanks,
Jason