here's some sample code -- i have the first part working in which I can strip out the attachment and save it to another location... what I am trying to do next, is once the attachment has been stripped -- move the message to another folder... -- the moving to another folder is not working, any ideas on how I can get this done...
Public Function SaveAttachments(Optional PathName As String) As Boolean
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer
Dim objFolder As Outlook.MAPIFolder
'On Error GoTo ErrHandler
If PathName = "" Then
sPathName = GetTempDir
Else
sPathName = PathName
End If
If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
If Dir(sPathName, vbDirectory) = "" Then Exit Function
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Set objFolder = oOutlook.Session.Folders.Item(2).Folders.Item(9)
MsgBox oOutlook.Session.Folders.Item(2).Folders.Item(9)
For Each oMessage In oFldr.Items
If oMessage.UnRead = True Then
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile sPathName _
& .Item(iCtr).FileName
Next iCtr
End If
End With
DoEvents
oMessage.UnRead = False
End If
'oMessage.CopyTo objFolder.EntryID
'oMessage.Delete
Next oMessage
SaveAttachments = True
'ErrHandler:
'Set oMessage = Nothing
'Set oFldr = Nothing
'Set oNs = Nothing
'Set oOutlook = Nothing
End Function
Public Function SaveAttachments(Optional PathName As String) As Boolean
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer
Dim objFolder As Outlook.MAPIFolder
'On Error GoTo ErrHandler
If PathName = "" Then
sPathName = GetTempDir
Else
sPathName = PathName
End If
If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
If Dir(sPathName, vbDirectory) = "" Then Exit Function
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Set objFolder = oOutlook.Session.Folders.Item(2).Folders.Item(9)
MsgBox oOutlook.Session.Folders.Item(2).Folders.Item(9)
For Each oMessage In oFldr.Items
If oMessage.UnRead = True Then
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile sPathName _
& .Item(iCtr).FileName
Next iCtr
End If
End With
DoEvents
oMessage.UnRead = False
End If
'oMessage.CopyTo objFolder.EntryID
'oMessage.Delete
Next oMessage
SaveAttachments = True
'ErrHandler:
'Set oMessage = Nothing
'Set oFldr = Nothing
'Set oNs = Nothing
'Set oOutlook = Nothing
End Function