CDO Saving Attachment from message file Zero Bytes (SaveToFile)

[RogofLap]

All,

I am trying to save attachments of outlook messages that
were saved to a folder. This routine works, except I get
a file with Zero bytes??????

What am I doing wrong? The code is what I am using...

Private Sub SaveAttachments()
Dim sFile As String
Dim msg As CDO.Message
'Dim oBodyPart As CDO.IBodyPart
Dim sPath As String
Dim sSavePath As String
Dim i As Integer
sPath = "C:\Roger\BundlePackage\"
sSavePath = "C:\Roger\BundlePackage\SavedAttachments\"
sFile = Dir(sPath & "*.msg")
Do While sFile <> ""
Set msg = LoadMessageFromFile(sPath & sFile)
With msg
If .Attachments.Count > 0 Then
For i = 1 To .Attachments.Count
Set oBodyPart = msg.Attachments(i)
oBodyPart.SaveToFile sSavePath &
oBodyPart.Filename
Next
End If
End With
Set msg = Nothing
sFile = Dir
Loop
End Sub

' Reference to Microsoft ActiveX Data Objects 2.5 Library
' Reference to Microsoft CDO for Windows 2000 Library
Function LoadMessageFromFile(Path As String) As Message
Dim Stm As New Stream
Stm.Open
Stm.LoadFromFile Path
Dim iMsg As New CDO.Message
Dim iDsrc As IDataSource
Set iDsrc = iMsg
iDsrc.OpenObject Stm, "_Stream"
Set LoadMessageFromFile = iMsg
End Function

..

 

[Rog]

Could not figure out how to do it with CDO, so just used
Outlook object and got it to work. Here is the code...
Works like a charm.



Dim myOlapp As Outlook.Application
Dim myoMsg As Outlook.MailItem
Set myOlapp = CreateObject("Outlook.Application")
Set myoMsg = myOlapp.CreateItem(olMailItem)
'sPath = "C:\Roger\BundlePackage\"
sPath = "\\eve\tmpoll\3114\HSIA Data\"
'sSavePath
= "C:\Roger\BundlePackage\SavedAttachments\"
sSavePath = "\\eve\tmpoll\3114\HSIA
Data\SavedAttachments\"
sFile = Dir(sPath & "*.msg")
Do While sFile <> ""
Set myoMsg = myOlapp.CreateItemFromTemplate(sPath
& sFile)
For i = 1 To myoMsg.Attachments.Count
myoMsg.Attachments.Item(i).SaveAsFile
sSavePath & myoMsg.Attachments(i).Filename
Next
sFile = Dir()
loop