Save Outlook item as *.Msg object

[checkOut]

Code below I find on the forum here, I rewrite a bit and use the code often for sending email without outlook.
But now I need a way to save the send message as object in a mapping like C:\Project\subj_110303.msg

Anyone has an idea?
Thanx in advance,
Gerard

Public Function fctnOutlook1(Optional FromAddr, Optional Addr, Optional cc, Optional BCC, _
Optional Subject, Optional MessageText, Optional AttachmentPath, Optional Vote As String = vbNullString, _
Optional Urgency As Byte = 1, Optional EditMessage As Boolean = True, Optional Reply, _
Optional blnDeliver As Boolean = False, Optional blnRead As Boolean = False, _
Optional intUrgency As Integer = 1)
On Error GoTo errHandler

Dim objSession As MAPI.Session
Dim objFolder As MAPI.Folder
Dim objMsgs As MAPI.Messages
Dim objMsg As MAPI.Message
Dim strProfile As String, testEmail As Variant, testPath As Variant
Dim I As Integer
Dim objFields, objRecipient, objAttachment
'strProfile = fGetDefaultProfile
Set objSession = CreateObject("MAPI.Session")
With objSession
strProfile = "MAASDAMGROEPDC1" & vbLf & Nz(DLookup("strMailbox", "gebruiker", _
"initialen = '" & Haalgebruiker & "'"), "")
.Logon , , , False, , True, strProfile
'.Logon ShowDialog:=False, NewSession:=False
'General way to get any default folder
' Create a new message
End With
Set objMsg = objSession.Outbox.Messages.Add
With objMsg
'If Not IsMissing(FromAddr) Then
' .Sender = FromAddr
'End If
If Not IsMissing(Addr) Then
testEmail = Split(Addr, ";")
For I = 0 To UBound(testEmail)
Set objRecipient = objMsg.Recipients.Add
objRecipient.Name = testEmail(I)
objRecipient.Address = "SMTP:" & testEmail(I)
objRecipient.type = 1
objRecipient.Resolve
Next I
End If

If Not IsMissing(cc) Then
testEmail = Split(cc, ";")
For I = 0 To UBound(testEmail)
Set objRecipient = objMsg.Recipients.Add
objRecipient.Name = testEmail(I)
objRecipient.Address = "SMTP:" & testEmail(I)
objRecipient.type = 2
objRecipient.Resolve
Next I
End If

If Not IsMissing(BCC) Then
testEmail = Split(BCC, ";")
For I = 0 To UBound(testEmail)
Set objRecipient = objMsg.Recipients.Add
objRecipient.Name = testEmail(I)
objRecipient.Address = "SMTP:" & testEmail(I)
objRecipient.type = 3
objRecipient.Resolve
Next I
End If
If Not IsMissing(Subject) Then
.Subject = Subject
End If
If Not IsMissing(MessageText) Then
.Text = MessageText
End If
.Importance = intUrgency
If Not IsMissing(AttachmentPath) Then
testPath = Split(AttachmentPath, ";")

For I = 0 To UBound(testPath)
Set objAttachment = .Attachments.Add
' Setting the position where the attachment should be placed
' In this case at the beginning of the message, use -1 to place the
' attachment at the end of the message body. Note that this is only
' necessary for RTF enabled messages.
objAttachment.Position = -1
' Setting the attachment type and add it as a file
' Note that a list of possible attachment types is shown in the table below
objAttachment.type = CdoFileData
objAttachment.ReadFromFile testPath(I)
objAttachment.Source = testPath(I)
Next I
End If

'If Not IsMissing(Reply) Then
' .ReplyTo = Reply
'Else
' .ReplyTo = HaalEmail(Haalgebruiker)
'End If
If blnRead Then
.ReadReceipt = True
Else
.ReadReceipt = False
End If
If blnDeliver Then
.DeliveryReceipt = True
Else
.DeliveryReceipt = False
End If
.Update
.Send
End With
ExitSub:
objSession.Logoff
Set objMsg = Nothing
Set objMsgs = Nothing
Set objFolder = Nothing
Set objSession = Nothing
Exit Function
errHandler:
MsgBox Err.Description & Err.Number
GoTo ExitSub
End Function

 

[checkOut]

anyone knows a solution for this?

Many thanx in advance,

Gerard

 

[PHV]

An Outlook.MailItem object has the SaveAs method.
Don't know for the MAPI.Message object.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886