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

--
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

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.

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

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:

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

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.

"Michael Bauer [MVP - Outlook]" wrote:

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.

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
...



--
Wilfried Hennings
please reply in the newsgroup, the e-mail address is invalid