Consulting

Results 1 to 5 of 5

Thread: Save and Rename Attachment

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Newbie
    Joined
    Apr 2012
    Posts
    3
    Location

    Lightbulb Save and Rename Attachment

    Hello,

    Using VBA in Outlook, I am trying to save attachments from a handful of daily emails and rename the files using the SAME name each day, essentially replacing the set of files each day. I have the code to save the attachments, but I'm stumped when it comes to renaming the files. The email subject lines and the files have the date in them, and I would like to save the files without the date (Example, if the email subject line reads "Weekly Dashboard 3/25/12 - 3/31/12", the file is "Weekly Dashboard 3/25/12 - 3/31/12.xlsx". I need the file to be renamed "Weekly Dashboard.xlsx".

    Here is the code I have so far (I also attached it for easier viewing). Can someone help me out?

    [vba]Sub GetAttachments()
    On Error GoTo SaveAttachmentsToFolder_err
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Reports")
    Dim objAtt As Outlook.Attachment
    If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the Reports folder.", vbInformation, _
    "Nothing Found"
    Exit Sub
    End If
    For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
    If Right(Atmt.FileName, 4) = "xlsx" Then
    FileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\" & Atmt.FileName
    Atmt.SaveAsFile FileName
    i = i + 1
    End If
    Next Atmt
    Next Item
    If i > 0 Then
    varResponse = MsgBox("I found " & i & " attached files." _
    & vbCrLf & "I have saved them into \\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY." _
    & vbCrLf & vbCrLf & "Would you like to view the files now?" _
    , vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
    Shell "Explorer.exe /e,\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\", vbNormalFocus
    End If
    Else
    MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
    SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
    SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
    End Sub[/vba]
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •