On May 27, 2:18*pm, "Sue Mosher [MVP]" wrote:
Try replacing this statement:

* * Dim myOlApp As New Outlook.Application

with

* * Set myOlApp = Application

--
Sue Mosher, Outlook MVP
* *Author of Microsoft Outlook 2007 Programming:
* * *Jumpstart for Power Users and Administrators
* *http://www.outlookcode.com/article.aspx?id=54

wrote in message

...



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- Hide quoted text -

- Show quoted text -

Thank You! That works great! I really appreciate your help.