Saving Attachment as RTF vs Outlook Save As... RTF - VB6 MAPI & Outlook 2003

[rmsmiami]

The VB 6.0 code below illustrates how one would link to
an Outlook folder and inspect each mail item for
attachments; saving to a disk file, as an RTF, any
attachment found.

The file saved by running this code is different from one
saved within the Outlook client by opening the mail item,
opening its attachment and selecting 'Save As.' on
the 'File' drop-down and specifying 'Save as type: Rich
Text Format (*.rtf)'.

Performing the 'Save as type: Rich Text Format (*.rtf)'
gives the desired disk file needed.

How can one achieve this result programmatically?

Thanks for any help on this.

Option Explicit
Const sTargetFileFolder = "Mailbox - TESTBOX\Inbox\Test"
Const sTargetFile = "C:\Test\MailAttach.rtf"
Global oApp As Application
Global olNspace As Outlook.NameSpace
Global oCurrentFolder As Object
Global sToken As String
Global oTestFolder As Object
Global oItems As Object
Global oMessage As Object
Global oAttachment As Object

Public Sub LoginAndSaveAttachments()
On Error GoTo Err_LoginAndSaveAttachments

'Initialize Outlook as standalone
Set oApp = CreateObject("Outlook.Application")
Set olNspace = oApp.GetNamespace("MAPI")
olNspace.Logon , , False, False

Set oTestFolder = GetFolder(sTargetFileFolder) 'Set
folder
Set oItems = oTestFolder.Items 'Set
items collection
For Each oMessage In oItems 'Loop
thru each mail item
If oMessage.Attachments.Count > 0 Then 'Check
for attachments
For Each oAttachment In oMessage.Attachments 'Loop
thru each attachment
If oAttachment.Type = 5 Then 'Check
for TYPE ".msg"
oAttachment.SaveAsFile sTargetFile 'Save
attachment - overwrite target.rtf
End If
Next
End If
Next
'=== release objects ===
Set oTestFolder = Nothing
Set oCurrentFolder = Nothing
Set oItems = Nothing
Set oMessage = Nothing
Set oApp = Nothing
Set olNspace = Nothing

Exit_LoginAndSaveAttachments:
Exit Sub
Err_LoginAndSaveAttachments:
Select Case Err.Number
Case 0 'Resume?
Case Else
MsgBox "Error " & Err.Number & vbCr & Err.Description
End Select
Resume Exit_LoginAndSaveAttachments
End Sub
Function GetFolder(FolderPath)
Dim CurrentFolder As String
On Error GoTo Err_GetFolder

Set oCurrentFolder = olNspace.Folders(GetField
(FolderPath, "\"))
FolderPath = sToken
While FolderPath <> ""
CurrentFolder = GetField(FolderPath, "\")
Set oCurrentFolder = oCurrentFolder.Folders
(CurrentFolder)
FolderPath = sToken
Wend
Set GetFolder = oCurrentFolder

Exit_GetFolder:
Exit Function
Err_GetFolder:
Select Case Err.Number
Case 0 'Resume?
Case Else
MsgBox "Error " & Err.Number & vbCr & Err.Description
End Select
Resume Exit_GetFolder
End Function
Function GetField(Path, Delimiter)
If InStr(Path, Delimiter) = 0 Then
GetField = Path
sToken = ""
Exit Function
End If
GetField = Left(Path, InStr(Path, Delimiter) - 1)
sToken = Right(Path, Len(Path) - InStr(Path,
Delimiter) - Len(Delimiter) + 1)
End Function

 

[Eric Legault [MVP - Outlook]]

I don't think there's a way to do this. I tried saving any attachments that
are .msg files to the file system, and then opened them up using the Shell
command and the outlook.exe /f <msg file> switch. Unfortunately, items
opened this way are not handled by the Inspectors_NewInspector event. I was
hoping to use that to retrieve the MailItem object from the new Inspector
and use SaveAs with the .rtf parameter. No luck.

Note that there's nothing stopping you from saving .msg attachments as .rtf
files - but they become unreadable.