Rename attachments before saving

Question

Rename attachments before saving

Asked 6 years ago

Viewed 151 times

0

Gentlemen, I have the following problem. Every Monday, I receive from a system 12 emails, being them:

SIXTH:

MIPS_1
MIPS_2
MIPS_3
MIPS_4

SATURDAY:

MIPS_1
MIPS_2
MIPS_3
MIPS_4

DOMINGO:

MIPS_1
MIPS_2
MIPS_3
MIPS_4

And I need a way that I save these files to a computer directory, renaming them so that they don’t replace the current file. In some research, I got the following code:

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim f As Long
Dim NewName


'f = f + 1


' Get the path to your My Documents folder
strFolderpath = "C:\Users\brunoco\Desktop\Teste Macro MIPS"
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Attachment folder.
strFolderpath = "C:\Users\brunoco\Desktop\Teste Macro MIPS\"

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then

        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.

        For i = lngCount To 1 Step -1
           For Each objAttachments In objMsg
            f = f + 1


            'If strSubject.Contains("VIDE") Then
            ' Save attachment before deleting from item.
            ' Get the file name.
            'strFile = Left(objAttachments.Item(i).Filename, Len(objAttachments.Item(i).Filename) - 4) + "_" + Right("00" + Trim(Str$(Day(Now))), 2) + "_" + Right("00" + Trim(Str$(Month(Now))), 2) + "_" + Right("0000" + Trim(Str$(Year(Now))), 4) + "_" + Right("00" + Trim(Str$(Hour(Now))), 2) + "_" + Right("00" + Trim(Str$(Minute(Now))), 2) + "_" + Right("00" + Trim(Str$(Second(Now))), 2) + Right((objAttachments.Item(i).Filename), 4)
            strFile = Left(objAttachments.Item(i).Filename, Len(objAttachments.Item(i).Filename) - 4) + "_" + Right((strSubject), 2) + Right((objAttachments.Item(i).Filename), 4)


            'If strSubject.Contains("VIDE") Then
            ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile


            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile

            ' Delete the attachment.
            'objAttachments.Item(i).Delete

            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If

            'Use the MsgBox command to troubleshoot. Remove it from the final code.
            'MsgBox strDeletedFiles
          Next


        Next i

        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
        Else
            objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
        End If
        objMsg.Save
    End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

It does correctly for the first day, but in the following, it replaces the file, invalidating what I need to do. I would like to rename to the following form:

SIXTH:

MIPS_1_SEX
MIPS_2_SEX
MIPS_3_SEX
MIPS_4_SEX

SATURDAY:

MIPS_1_SAB
MIPS_2_SAB
MIPS_3_SAB
MIPS_4_SAB

DOMINGO:

MIPS_1_DOM
MIPS_2_DOM
MIPS_3_DOM
MIPS_4_DOM

Thanks for your help!!!

He’s already using the . Saveas

– Bruno Covre

2018/10/23 at 16:50

1 answer

Browser other questions tagged vba outlook

You are not signed in. Login or sign up in order to post.

by danieltakeshi • **3,960** points · Answer 1 · 2018-10-23T19:18:12+00:00

You can use the following code to perform this string manipulation:

arquivo = objAttachments.Item(i).FileName
nome_arquivo = fso.GetBaseName(arquivo)
extensao_arquivo = Replace(arquivo, nome_arquivo, "")
                    
If arquivo Like ("*MIPS_*") Then
    If j = 3 Then
        k = k + 1
        j = 0
    End If
    strFile = nome_arquivo & "_" & arr(k) & extensao_arquivo
    j = j + 1

Else
    'strFile = arquivo
End If

If the Annex contains the word MIPS_ creates the files in order, otherwise saves only the name of the attached file.

Explanation

arquivo = objAttachments.Item(i).FileName is the name of the attachment, for example: "Filename.txt"
nome_arquivo = fso.GetBaseName(arquivo) is the file name without the extension, e.g.: "Filename"
extensao_arquivo = Replace(arquivo, nome_arquivo, "") is the file extension, e.g.: ". txt"
strFile = nome_arquivo & "_" & arr(k) & extensao_arquivo concatenates the final name of the file that will be saved, with some vector value arr. The index k vector incremented every time 4MIPS_ is saved.

Code

Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem               'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    Dim f As Long
    Dim NewName
    Dim arr As Variant
    Dim j As Long, k As Long
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")


    ' Get the path to your My Documents folder
    'strFolderpath = "C:\Users\brunoco\Desktop\Teste Macro MIPS\"
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    ' Set the Attachment folder.
    strFolderpath = "C:\Users\brunoco\Desktop\Teste Macro MIPS\"

    ' Check each selected item for attachments. If attachments exist,
    ' save them to the strFolderPath folder and strip them from the item.
    For Each objMsg In objSelection

        ' This code only strips attachments from mail items.
        ' If objMsg.class=olMail Then
        ' Get the Attachments collection of the item.
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        strDeletedFiles = ""

        If lngCount > 0 Then

            ' We need to use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.

            For i = lngCount To 1 Step -1
                k = 0
                arr = Array("SEX", "SAB", "DOM")
                For Each objAttachments In objMsg
                    f = f + 1
                   
                    arquivo = objAttachments.Item(i).FileName
                    nome_arquivo = fso.GetBaseName(arquivo)
                    extensao_arquivo = Replace(arquivo, nome_arquivo, "")
                    
                    If arquivo Like ("*MIPS_*") Then
                        If j = 3 Then
                            k = k + 1
                            j = 0
                        End If
                        strFile = nome_arquivo & "_" & arr(k) & extensao_arquivo
                        j = j + 1

                    Else
                        strFile = arquivo
                    End If


                    'If strSubject.Contains("VIDE") Then
                    ' Combine with the path to the Temp folder.
                    strFile = strFolderpath & strFile


                    ' Save the attachment as a file.
                    objAttachments.Item(i).SaveAsFile strFile

                    ' Delete the attachment.
                    'objAttachments.Item(i).Delete

                    'write the save as path to a string to add to the message
                    'check for html and use html tags in link
                    If objMsg.BodyFormat <> olFormatHTML Then
                        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                    Else
                        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                                          strFile & "'>" & strFile & "</a>"
                    End If

                    'Use the MsgBox command to troubleshoot. Remove it from the final code.
                    'MsgBox strDeletedFiles
                Next


            Next i

            ' Adds the filename string to the message body and save it
            ' Check for HTML body
            If objMsg.BodyFormat <> olFormatHTML Then
                objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If
            objMsg.Save
        End If
    Next

ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub