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

  • Thread starter stv.nelson1@gmail.com
  • Start date
Status
Not open for further replies.
S

stv.nelson1@gmail.com

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
 
Re: how to disable security message in save attachments macro "A program is trying to access e-mail addresses . ."

Try replacing this statement:

Dim myOlApp As New Outlook.Application

with

Set myOlApp = Application

Sue Mosher

<stv.nelson1@gmail.com> wrote in message

news:7fa07fe0-97ba-4708-8cae-694224295cd2@u8g2000yqn.googlegroups.com...
> 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
 
Re: how to disable security message in save attachments macro "Aprogram is trying to access e-mail addresses . ."

On May 27, 2:18 pm, "Sue Mosher [MVP]" <sue...@turtleflock.com> wrote:
> Try replacing this statement:

>     Dim myOlApp As New Outlook.Application

> with

>     Set myOlApp = Application

> > Sue Mosher
>    >      >    
> <stv.nels...@gmail.com> wrote in message

> news:7fa07fe0-97ba-4708-8cae-694224295cd2@u8g2000yqn.googlegroups.com...

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




Thank You! That works great! I really appreciate your help.
 
save attachments macro - multiple attachments with the same file name

On May 27, 2:18 pm, "Sue Mosher [MVP]" <sue...@turtleflock.com> wrote:
> Try replacing this statement:

>     Dim myOlApp As New Outlook.Application

> with

>     Set myOlApp = Application

> > Sue Mosher
>    >      >    
> <stv.nels...@gmail.com> wrote in message

> news:7fa07fe0-97ba-4708-8cae-694224295cd2@u8g2000yqn.googlegroups.com...

>
> > 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
 
Re: save attachments macro - multiple attachments with the same file name

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

Am Wed, 3 Jun 2009 04:25:37 -0700 (PDT) schrieb RC:


> On May 27, 2:18 pm, "Sue Mosher [MVP]" <sue...@turtleflock.com> wrote:
> > Try replacing this statement:
>

>>     Dim myOlApp As New Outlook.Application
>

>> with
>

>>     Set myOlApp = Application
>

>> > > Sue Mosher
> >    >>      >>    >
>> <stv.nels...@gmail.com> wrote in message
>

>> news:7fa07fe0-97ba-4708-8cae-694224295cd2@u8g2000yqn.googlegroups.com...
>

>
>>
> >> 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
 
Re: save attachments macro - multiple attachments with the same file name

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 " <mb@mvps.org> 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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
C how to disable outlook security messages Outlook VBA and Custom Forms 1
J disable Alt+S shortcut Using Outlook 21
J Hide/disable "Groups", "Shared Calendars" Using Outlook 2
G To enable/disable Allow New Time proposals Outlook VBA and Custom Forms 1
Y Disable Microsoft Outlook Test Message Using Outlook 4
J How do you disable address search box when typing @ in body of email? Using Outlook 0
L Is there a way to completely disable the "archive" box? Using Outlook 1
M Disable Contact Card Results when using "Search People" in Outlook Ribbon Using Outlook 7
U Disable "Always ask before opening" Dialog Using Outlook 3
J How do I disable advertising in Outlook 2019? Using Outlook 15
GregS Outlook 2016 Can I disable the Outlook Outbox? Using Outlook 2
R Disable conversation thread from replying of recipients in the same subject. Please help Using Outlook 0
N Disable Auto Read Receipts sent after using Advanced Find Using Outlook 4
N How to disable shortcuts for Pilcrow in Outlook (Show or hide paragraph marks) Using Outlook 0
N How to disable shortcuts for Pilcrow in Outlook Using Outlook 0
M Making Subject field writable (disable Read Only) Outlook VBA and Custom Forms 2
D Disable or hide "reply" and "reply to all" and "forward" in email from access vba Outlook VBA and Custom Forms 1
P Disable Spam Notifications & Sounds Using Outlook 3
O Outlook Web Access - how to disable spam filter Using Outlook 6
Diane Poremsky Disable Protected View for Outlook Attachments Using Outlook 0
E Outlook 2010 disable date auto-complete Using Outlook 2
Diane Poremsky Disable Outlook Add-ins (Apps) Using Outlook 0
J Using VBA to disable alerts / warnings Using Outlook 2
Diane Poremsky Disable the Unsafe Hyperlink Warning when Opening Attachments Using Outlook 0
N How to disable user defined fields in BCM forms Using Outlook 2
Diane Poremsky Disable Live Preview in Outlook and Word Using Outlook 0
D Preventing users to disable an Outlook Add-in Using Outlook.com accounts in Outlook 5
F Disable "Find related messages" Using Outlook 1
davecazz Anyway to disable the peek rollovers? Using Outlook 1
L Reading Pane - COMPLETELY DISABLE? Using Outlook 10
M trying to disable junk email filter. completely. Using Outlook 4
Z OL2007 - is there a way to disable the "feature" that cripples mails that are in the "junk" folder? Using Outlook 37
B How do I REALLY disable Outlook Junk E-mail sorting in OL2010 and/or 2013? Using Outlook 1
R Outlook Cache Mode Terminalserver disable through Registry Using Outlook 1
S Cannot disable OWA light Exchange Server Administration 5
A How to disable the pop-up “Reponses to this meeting will not be tallied." Using Outlook 0
D Show this folder as an e-mail Address Book is enabled but I want to disable Using Outlook 2
Rupert Dragwater how to disable billingual dictionary in outlook 2010 Using Outlook 9
J How to disable syncing folder views/layouts Using Outlook 5
A Disable hotmail from Outlook email account Using Outlook 1
R Disable request to share a calendar Using Outlook 1
T Disable the To-Do Bar permanently Using Outlook 15
J Outlook's auto time zone update for meeting requestsHow to REMOVE or DISABLE? Using Outlook 1
D Disable Junk Email in the Registry? Using Outlook 8
A How to disable bcc option in GAL - Address Book - Exchange 2007 Exchange Server Administration 4
P disable image compression Using Outlook 5
J Disable outlook 2010 no-subject warning Using Outlook 4
E Disable outlook 2010 no-subject warning Using Outlook 9
C Disable printing Outlook VBA and Custom Forms 1
A disable a menu in active inspector Outlook VBA and Custom Forms 1

Similar threads

Back
Top