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
189 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
  • 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
Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

 
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

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

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

Outlook Free & Paid Tools
Having trouble getting your hands on Dynamics 365 Field Service or Project Service trial? Worry No More!!!
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

813 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now