How To Use Redemption To Save Attachments

[MikeC]

I'm preparing to use Outlook Redemption to save file
attachments, but I'm having difficulty finding
documentation that explains how to do this. The
Redemption website has lots of code fragments and
descriptions of various objects, but I can't seem to find
anything that directly pertains to what I'm trying to do.

To use Redemption, I'm supposed to change how I declare my
Outlook objects and set a the Item property of any
Redemption objects to an Outlook property. Can anyone
tell me how to do this with the below code?

=======================================================
Public Function SaveAttached()
On Error GoTo Err_SaveAttached

Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim myNameSpace As NameSpace

' Get the destination folder.
strFolder = "C:\" 'Test folder

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

Set myNameSpace = objOL.GetNamespace("MAPI")

myNameSpace.Logon "UserName", "Password", False, False

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Check each selected item for attachments.
' If attachments exist, save them to the specified
folder
For Each objMsg In objSelection
' save attachments from mail items.
If objMsg.Class = olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Save attachment from item.
' Get the file name.
strFile = objAttachments.Item
(i).FileName
' Combine with the path to the
Specified folder.
strFile = strFolder & strFile
' Save the attachment if the file name
matches the specified string.
' The characters at the beginning of
the file name are variable.
If Right(strFile, 17)
= "_USD_s_bid_ib.csv" Then
objAttachments.Item(i).SaveAsFile
strFile
End If
Next i
End If
End If
Next

myNameSpace.Logoff

Exit_SaveAttached:
On Error Resume Next
Set objOL = Nothing
Set myNameSpace = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objAttachments = Nothing
Exit Function

Err_SaveAttached:
If Err.Number <> 2501 Then
MsgBox "Module: " & vbTab & vbTab & "Module1" &
vbCrLf _
& "Procedure #: " & vbTab & "1" & vbCrLf _
& "Error #: " & vbTab & vbTab & Err.Number &
vbCrLf _
& "Description: " & vbTab & Err.Description
Else
Resume Exit_SaveAttached
End If

End Function

 

[Dmitry Streblechenko \(MVP\)]

Try something like the following (off the top of my head). See the changes
related to the objSMsg variable ("S" stands for "Safe")

Public Function SaveAttached()
On Error GoTo Err_SaveAttached

Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSMsg As Object
Dim objAttachments As Object
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim myNameSpace As NameSpace

' Get the destination folder.
strFolder = "C:\" 'Test folder

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

Set myNameSpace = objOL.GetNamespace("MAPI")

myNameSpace.Logon "UserName", "Password", False, False

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Check each selected item for attachments.
' If attachments exist, save them to the specified
folder
For Each objMsg In objSelection
' save attachments from mail items.
If objMsg.Class = olMail Then
' Get the Attachments collection of the item.
set objSMsg = CreateObject("Redemption.SafeMailItem")
objSMsg.Item = objMsg
Set objAttachments = objSMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Save attachment from item.
' Get the file name.
strFile = objAttachments.Item
(i).FileName
' Combine with the path to the
Specified folder.
strFile = strFolder & strFile
' Save the attachment if the file name
matches the specified string.
' The characters at the beginning of
the file name are variable.
If Right(strFile, 17)
= "_USD_s_bid_ib.csv" Then
objAttachments.Item(i).SaveAsFile
strFile
End If
Next i
End If
End If
Next

myNameSpace.Logoff

Exit_SaveAttached:
On Error Resume Next
Set objOL = Nothing
Set myNameSpace = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objAttachments = Nothing
Exit Function

Err_SaveAttached:
If Err.Number <> 2501 Then
MsgBox "Module: " & vbTab & vbTab & "Module1" &
vbCrLf _
& "Procedure #: " & vbTab & "1" & vbCrLf _
& "Error #: " & vbTab & vbTab & Err.Number &
vbCrLf _
& "Description: " & vbTab & Err.Description
Else
Resume Exit_SaveAttached
End If

End Function


Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool

 

[MikeC]

Thanks Dimitry. It's working now. No more Outlook
security prompts!