Excel Hints

Results 1 to 5 of 5

Thread: Save and Rename Attachment

  1. #1

    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?

    VB:
    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 
    
    
    Formatting tags added by mark007
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  2. #2
    Replace:
    VB:
    FileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\" & Atmt.FileName 
    
    
    Formatting tags added by mark007
    with:
    VB:
    Dim p As Integer 
    p = InStr(Atmt.fileName, "/") 
    p = InStrRev(Atmt.fileName, " ", p) 
    fileName = "[URL="file://\\AD\MyND_RO\Profile\HomeDrive\LDP"]\\AD\MyND_RO\Profile\HomeDrive\LDP[/URL] DSS\TV DISPLAY\" & Left(Atmt.fileName, p - 1) & ".xlsx" 
    
    
    Formatting tags added by mark007

  3. #3
    I replaced the code and got this error message:

    "An unexpected error has occurred.
    Please note and report the following information.
    Macro Name: GetAttachments
    Error Number: 5
    Error Description: Invalid procedure call or argument"

    Is this because some of the files have a date and some do not?

  4. #4
    Quote Originally Posted by ebrown00
    Is this because some of the files have a date and some do not?
    Yes, probably, though it's difficult to know for certain without seeing the actual file name with which it fails.

    Try this instead (entirely replaces my previous code):
    VB:
    Dim p As Integer 
    fileName = Atmt.fileName 
    p = InStr(fileName, "/") 
    If p > 0 Then 
        p = InStrRev(fileName, " ", p) 
        If p > 0 Then 
            fileName = Left(fileName, p - 1) & ".xlsx" 
        End If 
    End If 
    fileName = "[URL="file://\\AD\MyND_RO\Profile\HomeDrive\LDP"]\\AD\MyND_RO\Profile\HomeDrive\LDP[/URL] DSS\TV DISPLAY\" & fileName 
    
    
    Formatting tags added by mark007
    The code is just a simple string parser based on your described file name format - look at the functions used in the VB help to understand how it works.

    If it still doesn't work, set a breakpoint on a suitable line and debug it in the VB editor.

  5. #5
    Thanks for the help! It didn't quite work, so I'll try to debug it.

Posting Permissions

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