how to disable security message in save attachments macro "A programis trying to access e-mail addre

  • Thread starter Thread starter stv.nelson1
  • Start date Start date
S

stv.nelson1

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
 
Try replacing this statement:

Dim myOlApp As New Outlook.Application

with

Set myOlApp = Application
 
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
Click to expand...

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
 
You could use the Dir function and see whether a given filename already
exists; if so, add a number and search again for an existing file with the
same name; loop until you have found a 'free' file name.

--
Best regards
Michael Bauer - MVP Outlook

: Outlook Categories? Category Manager Is Your Tool
: VBOffice Reporter for Data Analysis & Reporting
: <http://www.vboffice.net/product.html?pub=6&lang=en>


Am Wed, 3 Jun 2009 04:25:37 -0700 (PDT) schrieb RC:
 
Am Wed, 3 Jun 2009 04:25:37 -0700 (PDT) schrieb RC:
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.
Click to expand...

Michael Bauer said:
You could use the Dir function and see whether a given filename already
exists; if so, add a number and search again for an existing file with the
same name; loop until you have found a 'free' file name.
Click to expand...

or you can use the following code:

For i = 1 To myAttachments.Count
myFID = myOrt & myAttachments.Item(i).DisplayName
While myFS.FileExists(myFID)
strPrompt = myFID
myFID = InputBox("File already exists. Please enter new file name.", _
"SaveAttachment", strPrompt)
Wend
myAttachments.Item(i).SaveAsFile myFID
...
 
Back
Top