Thread: how to disable security message in save attachments macro "A programis trying to access e-mail addresses . ."
View Single Post
  #4  
Old June 3rd 09, 12:25 PM posted to microsoft.public.outlook.program_vba
RC[_2_]
external usenet poster
  
Posts: 1
Default save attachments macro - multiple attachments with the same file name
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

The following code works great, except some emails have multiple
attachments which have the same file name. For example, you take some
pictures with you digital camera and the camera names them,
image01.jpg, image02.jpg, you save the pictures in a folder on your
computer, erase the memory stick in the camera, take some more
pictures, again the camera names them, image01.jpg, image02.jpg,
etc., you save them in a different folder on your computer and then
attach all the photos to an email.

When the code below runs all the duplicate files are deleted without
warning.

Any ideas for coding a change to fix this would really be
appreciated. Thanks in advance.
===================== CODE BELOW ==============
Sub SaveAttachment()

'Declaration
Dim myItems, myAttachments, myAttachment As Object
Dim myItem As Outlook.MailItem
Dim myOrt As String
Set myOlApp = 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


'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
myItem.Body = "The following Attachments were removed from
this email and placed in the folder shown: " _
& myOrt & myAttachments(i).DisplayName & vbCrLf & vbCrLf &
myItem.Body

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
Ads