+ Reply to Thread
Results 1 to 5 of 5

Attachments : Save and Rename using Sublect string or File name string

  1. #1
    Registered User
    Join Date
    12-13-2012
    Location
    Pune, India
    MS-Off Ver
    Excel 2013
    Posts
    3

    Attachments : Save and Rename using Sublect string or File name string

    Morning Experts,

    I have a requirement to save outlook attachments and rename them using a set of numbers availabe in the file name/subject line. for example if the pdf file name is "SAM 12345678910.pdf" then the attachment should be renamed "12345678910.pdf"; the same number is available on the subject line - "Samir Invoice number 12345678910".

    I am not a macro expert to write codes. I have got thr below mentioned macro extract the attachments, however need help in renaming structure.

    _________________________________________________________________
    Option Explicit

    ' *****************
    ' For Outlook 2010.
    ' *****************
    #If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr

    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

    ' *****************************************
    ' For the previous version of Outlook 2010.
    ' *****************************************
    #Else
    ' The window handle of Outlook.
    Private lHwnd As Long

    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
    #End If

    ' The class name of Outlook window.
    Private Const olAppCLSN As String = "rctrl_renwnd32"
    ' Windows desktop - the virtual folder that is the root of the namespace.
    Private Const CSIDL_DESKTOP = &H0
    ' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
    Private Const BIF_RETURNONLYFSDIRS = &H1
    ' Do not include network folders below the domain level in the dialog box's tree view control.
    Private Const BIF_DONTGOBELOWDOMAIN = &H2
    ' The maximum length for a path is 260 characters.
    Private Const MAX_PATH = 260

    ' ######################################################
    ' Returns the number of attachements in the selection.
    ' ######################################################
    Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO As Object ' Computer's file system object.
    Dim objShell As Object ' Windows Shell application object.
    Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
    Dim objItem As Object ' A specific member of a Collection object either by position or by key.
    Dim selItems As Selection ' A collection of Outlook item objects in a folder.
    Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath As String ' The full saving path of the attachment.
    Dim strAtmtFullName As String ' The full name of an attachment.
    Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
    Dim intDotPosition As Integer ' The dot position in an attachment name.
    Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
    Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
    Dim strFolderPath As String ' The selected folder path.
    Dim blnIsEnd As Boolean ' End all code execution.
    Dim blnIsSave As Boolean ' Consider if it is need to save.

    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

    ' Get the handle of Outlook window.
    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

    ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
    Set objShell = CreateObject("Shell.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
    BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

    ' /* Failed to create the Shell application. */
    If Err.Number <> 0 Then
    MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
    Err.Description & ".", vbCritical, "Error from Attachment Saver"
    blnIsEnd = True
    GoTo PROC_EXIT
    End If

    If objFolder Is Nothing Then
    strFolderPath = ""
    blnIsEnd = True
    GoTo PROC_EXIT
    Else
    strFolderPath = CGPath(objFolder.Self.Path)

    ' /* Go through each item in the selection. */
    For Each objItem In selItems
    lCountEachItem = objItem.Attachments.Count

    ' /* If the current item contains attachments. */
    If lCountEachItem > 0 Then
    Set atmts = objItem.Attachments

    ' /* Go through each attachment in the current item. */
    For Each atmt In atmts

    ' Get the full name of the current attachment.
    strAtmtFullName = atmt.FileName

    ' Find the dot postion in atmtFullName.
    intDotPosition = InStrRev(strAtmtFullName, ".")

    ' Get the name.
    strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 11)
    ' Get the file extension.
    strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
    ' Get the full saving path of the current attachment.
    strAtmtPath = strFolderPath & atmt.FileName

    ' /* If the length of the saving path is not larger than 260 characters.*/
    If Len(strAtmtPath) <= MAX_PATH Then
    ' True: This attachment can be saved.
    blnIsSave = True

    ' /* Loop until getting the file name which does not exist in the folder. */
    Do While objFSO.FileExists(strAtmtPath)
    strAtmtNameTemp = strAtmtName(0) & _
    Format(Now, "_mmddhhmmss") & _
    Format(Timer * 1000 Mod 1000, "000")
    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

    ' /* If the length of the saving path is over 260 characters.*/
    If Len(strAtmtPath) > MAX_PATH Then
    lCountEachItem = lCountEachItem - 1
    ' False: This attachment cannot be saved.
    blnIsSave = False
    Exit Do
    End If
    Loop

    ' /* Save the current attachment if it is a valid file name. */
    If blnIsSave Then atmt.SaveAsFile strAtmtPath
    Else
    lCountEachItem = lCountEachItem - 1
    End If
    Next
    End If

    ' Count the number of attachments in all Outlook items.
    lCountAllItems = lCountAllItems + lCountEachItem
    Next
    End If
    Else
    MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
    blnIsEnd = True
    GoTo PROC_EXIT
    End If

    ' /* For run-time error:
    ' The Explorer has been closed and cannot be used for further operations.
    ' Review your code and restart Outlook. */
    Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
    End If

    PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
    End Function

    ' #####################
    ' Convert general path.
    ' #####################
    Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
    End Function

    ' ######################################
    ' Run this macro for saving attachments.
    ' ######################################
    Public Sub ExecuteSaving()
    Dim lNum As Long

    lNum = SaveAttachmentsFromSelection

    If lNum > 0 Then
    MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
    MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
    End Sub
    __________________________________________________________________

    Thanks,
    Samir

  2. #2
    Forum Contributor
    Join Date
    08-27-2006
    Posts
    136

    Re: Attachments : Save and Rename using Sublect string or File name string

    It looks like

    Please Login or Register  to view this content.
    should be

    Please Login or Register  to view this content.
    To mark "Solved" go to Thread Tools.

  3. #3
    Registered User
    Join Date
    12-13-2012
    Location
    Pune, India
    MS-Off Ver
    Excel 2013
    Posts
    3

    Re: Attachments : Save and Rename using Sublect string or File name string

    Hi skatonni,

    Thank you for looking into the matter, however it is not working for me. I am currently using the below excel macro to get it done. Can it bemerget with outlook macro?


    _________________________________________________________________________________
    Sub snb_renamefiles()

    For Each fl In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\samir.m\Desktop\08.11.2014").Files
    Name fl.Path As Replace(fl.Path, "TML-PO ", "")
    Next
    End Sub
    _________________________________________________________________________________

    Thanks,
    Samir

  4. #4
    Forum Contributor
    Join Date
    08-27-2006
    Posts
    136

    Re: Attachments : Save and Rename using Sublect string or File name string

    Try this

    Please Login or Register  to view this content.

  5. #5
    Registered User
    Join Date
    12-13-2012
    Location
    Pune, India
    MS-Off Ver
    Excel 2013
    Posts
    3

    Re: Attachments : Save and Rename using Sublect string or File name string

    Quote Originally Posted by skatonni View Post
    Try this

    Please Login or Register  to view this content.
    Hi SKAtonni,

    Thank you very much for this code. It is workin fine. A great help idneed.
    Much apreciated and closing the thread.

    Many Thanks,
    Samir

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. save file path as string variable
    By schzuki in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 02-20-2014, 06:02 AM
  2. Excel VBA find and replace string in non text file and rename file
    By razzack in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 07-01-2013, 02:43 PM
  3. Find string and save...insert another string
    By twckfa16 in forum Excel Programming / VBA / Macros
    Replies: 6
    Last Post: 02-21-2013, 04:48 PM
  4. Replies: 1
    Last Post: 08-04-2009, 06:42 AM
  5. how to convert IXMLDOMNodeList to string or save as XMl file
    By Ranjani in forum Excel Formulas & Functions
    Replies: 0
    Last Post: 03-18-2009, 05:37 AM

Tags for this Thread

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1