The following code saves the attachments in the selected email. It
lets the user browse to select which folder to save the attachements
in. It works fine except for the following security warning, "A
program is trying to access e-mail addresses you have stored in
Outlook".

I have read that the security warning can be stopped by using the
existing instance of Outlook instead of initiating a new Outlook
session in memory. I tried removing the word "New" in the following
code but the While-Wend code just kept cycling and the
attachments.count showed up as zero, (code: Dim myOlApp As New
Outlook.Application)

I also read the I can use Redemption, but I don't understand what
changes to make to the code to use Redemption.

I am using Outlook 2003.

I really appreciate any help -- Thanks
================= CODE BELOW ==========================
Sub SaveAttachment()

'Declaration
Dim myItems, myAttachments, myAttachment As Object
Dim myItem As Outlook.MailItem
Dim myOrt As String
' I TRIED REMOVING THE WORD "NEW", BELOW, TO STOP ERROR MESSAGES
' BUT IT DIDN'T WORK
'Dim myOlApp As Outlook.Application
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection

'Ask for destination folder
Dim oShell As Object
Dim oFolderDlg As Object
Set oShell = CreateObject("Shell.Application")

Dim ShellApp As Object
Dim BrowseForFolder As String

Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please select the folder where you want to
save the attachments. ", 0, "C:\")

''' Set ShellApp = CreateObject("Shell.Application"). _
''' BrowseForFolder(0, "Please select the folder where you want to
save the attachments. ", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Select Case Mid(BrowseForFolder, 2, 1)

Case Is = ""
If BrowseForFolder = "" Then
Exit Sub
End If

Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select

'''ExitFunction:

Set ShellApp = Nothing

'Set oFolderDlg = oShell.BrowseForFolder(&H0, "Select the folder where
you want to save the attachments.", &H0, "C:\")

'myOrt = oFolderDlg.self.Path & "\"
myOrt = BrowseForFolder & "\"
On Error Resume Next

'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

'for all items do...
For Each myItem In myOlSel
'point on attachments
Set myAttachments = myItem.Attachments

'if there are some...
If myAttachments.Count 0 Then

'add remark to message text THIS CAUSES ERROR
myItem.Body = myItem.Body & vbCrLf & _
"Removed Attachments:" & vbCrLf

'for all attachments do...
For i = 1 To myAttachments.Count

'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName

'add name and destination to message text
' THE CODE BELOW GENERATES THE ERROR MESSSAGE
myItem.Body = myItem.Body & _
"File: " & myOrt & _
myAttachments(i).DisplayName & vbCrLf

Next i

'for all attachments do...
While myAttachments.Count 0
'remove it (use this method in Outlook XP)
myAttachments.Remove 1

'remove it (use this method in Outlook 2000)
' myAttachments(1).Delete

Wend

'save item without attachments
myItem.Save
End If

Next

'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing

End Sub