Solved

Have emails with both PDF and TXT files attached - need to just pull the TXT files and Save to Network Folder

Posted on 2011-03-08
9
192 Views
Last Modified: 2012-05-11
I have emails that I receive that have both PDF and TXT files attached.  I need to just pull the TXT file attachments from the email and save to a folder on the network.

I have the following code (see attached code), but it is pulling both the PDF and TXT files, and as mentioned above I just want to save the TXT attachments.

What do I need to change/add in my existing code to do this?

Thanks,

gdunn59
Sub SaveOutlookAttachments(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Path for where to save attachments
    strRootFolderPath = "X:\sh_fox\FIR_TBT\2011\2011_ExceptionReports\2011_March\3-7-2011\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.Count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.FileName
            intCount = 0
            Do While True
                If objFSO.FileExists(strRootFolderPath & strFilename) Then
                    intCount = intCount + 1
                    strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strRootFolderPath & strFilename
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
Comment
Question by:gdunn59
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 4
9 Comments
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 250 total points
ID: 35071913
Try the following:

Chris
Sub SaveOutlookAttachments(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Path for where to save attachments
    strRootFolderPath = "X:\sh_fox\FIR_TBT\2011\2011_ExceptionReports\2011_March\3-7-2011\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.filename
            If LCase(Right(strFilename, 4)) = ".txt" Then
                intCount = 0
                Do While True
                    If objFSO.FileExists(strRootFolderPath & strFilename) Then
                        intCount = intCount + 1
                        strFilename = "Copy (" & intCount & ") of " & olkAttachment.filename
                    Else
                        Exit Do
                    End If
                Loop
                olkAttachment.SaveAsFile strRootFolderPath & strFilename
            End If
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
 
LVL 1

Author Comment

by:gdunn59
ID: 35072024
Chris,

I tried your code, but nothing happens at all.  It doesn't even run.

Thanks,
gdunn59
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35072532
Since the change is trivial perhaps one of the attachments filename is shorter than 4 chars.

Chris
Sub SaveOutlookAttachments(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Path for where to save attachments
    strRootFolderPath = "X:\sh_fox\FIR_TBT\2011\2011_ExceptionReports\2011_March\3-7-2011\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.filename
            if len(strfilename) > 4 then 
                If LCase(Right(strFilename, 4)) = ".txt" Then
                    intCount = 0
                    Do While True
                        If objFSO.FileExists(strRootFolderPath & strFilename) Then
                            intCount = intCount + 1
                            strFilename = "Copy (" & intCount & ") of " & olkAttachment.filename
                        Else
                            Exit Do
                        End If
                    Loop
                    olkAttachment.SaveAsFile strRootFolderPath & strFilename
                end if
            End If
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 1

Author Comment

by:gdunn59
ID: 35072637
Sorry, I think it may be something with the Rule that I'm using.  But it was working fine until I pasted in the new code.

I have to jump on something else right now, and will try to get back to it this afternoon.

I will keep you posted as to the status.

Thanks,
gdunn59
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35073033
OK ... may be the morning till I pick it back up though.

Chris
0
 
LVL 1

Author Comment

by:gdunn59
ID: 35073648
Ok.  Thanks!
0
 
LVL 1

Author Comment

by:gdunn59
ID: 35125765
There was a problem with the macro security settings and the email security Digital ID.
0
 
LVL 1

Author Closing Comment

by:gdunn59
ID: 35125768
Thank you very much for your assistance.

gdunn59
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35125798
I used to have issues with secured messages and found the only solution was to skip them.  But it makes for dirty code so not something I routinely add ... and difficult to test now as I use a Mac so no VBA!

Chris
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
This article describes a serious pitfall that can happen when deleting shapes using VBA.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

690 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question