UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> VBA To Remove/save Attachment Saves All Attachments, Office 2010    
 
   
bakersburg9
post Feb 12 2018, 02:46 PM
Post#1



Posts: 5,038
Joined: 2-November 04
From: Downey, CA


I have a nifty macro (probably got it in UA) that I run to save e-mail attachments - the objective is to remove the attached Excel file and write where it was sent. The problem is it removes EVERY OBJECT - like company logos, etc. - I JUSTwant the excel file removed.... two questions:

1) Can I have it just remove the excel file ?
2) Is there like a batch file I could run against the destination folder to delete all files that DON'T have an .xlsx extension, or even remove those with a .gif or .png or .jpg extension ?

Any help would be greatly appreciated . . .


CODE
Sub ArchiveAttachments()

'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    


    myOrt = InputBox("Destination", "Save Attachemnts", "\\corp.Acme.com\west\_Legacy\LOSBOHSFILE01\Operations\MyReports\DailyReportsReceived\")
    
    On Error Resume Next
    
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    
    For Each myItem In myOlSel
    
        Set myAttachments = myItem.Attachments
        
        If myAttachments.Count > 0 Then
        
            myItem.Body = myItem.Body & vbCrLf & _
                "Removed Attachments:" & vbCrLf
                
            For i = 1 To myAttachments.Count
            
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName

                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
                    
            Next i
            
            While myAttachments.Count > 0
  
            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
Go to the top of the page
 
cheekybuddha
post Feb 12 2018, 03:17 PM
Post#2


UtterAccess VIP
Posts: 9,497
Joined: 6-December 03
From: Telegraph Hill


Why not just test the filename and remove if it matches what you want?

So you only want to remove Excel files?

try:
CODE
' ...
            For i = 1 To myAttachments.Count
              If Left(Mid(myAttachments(i).DisplayName, InstrRev(myAttachments(i).DisplayName, ".") + 1), 3) = "xls" Then
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
              End If
            Next i
' ...

Untested - it might bomb if any attachments don't have an extension, so you may need to handle errors.

hth,

d

--------------------


Regards,

David Marten
Go to the top of the page
 
bakersburg9
post Feb 12 2018, 06:58 PM
Post#3



Posts: 5,038
Joined: 2-November 04
From: Downey, CA


Thanks, David, but it may be all for nought - I was as happy as a pig in slop, my macro was working, then all of a sudden, Outlook decides it's not going to run my macros - I thought it was 'operator error,' but I did some research on line, and found out this is a common problem where just setting up your macro setting the way you want them doesn't suffice - based on the info I found, I may have to buy (this is for work) something to where my macros can be digitally signed.... I can't figure out why it would work, and now it doesn't !?!?!?!?!?!

I get an error message that the macros in this project have been disabled - I go online, and it recommends I digitally sign my macros ... talks about running selfcert.exe.... I don't have that... Ugh.

confused.gif
Go to the top of the page
 
bakersburg9
post Feb 13 2018, 11:46 AM
Post#4



Posts: 5,038
Joined: 2-November 04
From: Downey, CA


Update - I found the self_cert thing - Yes ! cool.gif - I just don't know what to DO with it :-(

Attached File(s)
Attached File  Self_Cert_exe.png ( 19.25K )Number of downloads: 0
 
Go to the top of the page
 
DanielPineault
post Feb 13 2018, 11:52 AM
Post#5


UtterAccess VIP
Posts: 5,650
Joined: 30-June 11



What about

https://support.office.com/en-us/article/Di...fa-98505ecd1c01

https://www.howto-outlook.com/howto/selfcert.htm



--------------------
Daniel Pineault (2010-2017 Microsoft MVP)
Professional Help: http://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: http://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
bakersburg9
post Feb 13 2018, 04:15 PM
Post#6



Posts: 5,038
Joined: 2-November 04
From: Downey, CA


Daniel,
Thanks for your input - I opened the links, and did everything exactly as laid out - I have Outlook 2013, but I was intrigued by part of the instructions for O2007:

"First, let’s check if your macro security level is still set correctly. You’ll need to do this in the main Outlook window and not from the VBA Editor window" huh ? Why would that matter ? =anyway, I did it every way - this is SO aggravating - and the Help Desk at my company is no help - I'm sure very few people even know you can run macros in MSO

Steve

Go to the top of the page
 


Custom Search
RSSSearch   Top   Lo-Fi    19th February 2018 - 02:42 PM