How can I extract attachments from Outlook, save as subject line and remove invalid characters?

2
votes

I am working on a project that requires me to save large numbers of attachments to a folder and filter them.

I can currently save the attachments with the subject of the email as the filename. If there is more than 1 attachment then it saves as the subject line with a (1) or (2) and so on.

I currently have a script that will do most of what I need (Thanks to the help from 0m3r in the replys below)

The last thing I need to complete this script is something that will omit special caracters from the subject line before it uses the subject line as the file name. The problem I am running into is the program does not save files correctly if the subject is a Forward (FW:) or a Reply (RE:) I suspect the ":" is what is breaking the save file. For example if the Subject reads "FW: Here is the file you requested 2017" what I am getting is a file saved as "FW" without a file extensions. What I need is to remove the ":" or the "FW:" so this does not happen.

Can someone provide me with the correction I need to remove special characters from the subject as its converted to the save file name?

I think an Array will be needed to accomplish this but I am not sure how to implament it and what part of the script to add it into.

Something like Array("<", ">", "|", "/", "*", "\", "?", """", "'", ":")

Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object       
Dim objShell            As Object       
Dim objFolder           As Object       
Dim objItem             As Object       
Dim selItems            As Selection    
Dim atmt                As Attachment   
Dim strAtmtPath         As String       
Dim strAtmtFullName     As String       
Dim strAtmtName         As String       
Dim strAtmtNameTemp     As String       
Dim intDotPosition      As Integer      
Dim atmts               As Attachments  
Dim lCountEachItem      As Long         
Dim lCountAllItems      As Long         
Dim strFolderPath       As String       
Dim blnIsEnd            As Boolean      
Dim blnIsSave           As Boolean      

blnIsEnd = False
blnIsSave = False
lCountAllItems = 0

On Error Resume Next

Set selItems = ActiveExplorer.Selection

If Err.Number = 0 Then

    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

        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)

        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)

            For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count

                If lCountEachItem > 0 Then
                    Set atmts = objItem.Attachments

                    For Each atmt In atmts
                        strAtmtFullName = atmt.FileName
                        intDotPosition = InStrRev(strAtmtFullName, ".")
                        strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                        strAtmtPath = strFolderPath & objItem.subject & Chr(46) & strAtmtName

                        Dim lngF As Long
                        lngF = 1

                        If Len(strAtmtPath) <= MAX_PATH Then
                            blnIsSave = True
                            Do While objFSO.FileExists(strAtmtPath)

                                strAtmtNameTemp = objItem.subject & "(" & lngF & ")"

                                strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName

                                If Len(strAtmtPath) > MAX_PATH Then
                                    lCountEachItem = lCountEachItem - 1
                                    blnIsSave = False
                                    Exit Do
                                End If

                            lngF = lngF + 1
                            Loop

                            If blnIsSave Then atmt.SaveAsFile strAtmtPath
                        Else
                            lCountEachItem = lCountEachItem - 1
                        End If
                    Next
                End If

                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

Else
    MsgBox "Please select an Outlook item at least.",  vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If

PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems

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

If blnIsEnd Then End
End Function

Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function

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
2
vbaoutlookspecial-charactersattachment
Hello and welcome to SO. Please take some time to read the help page, including What topics can I ask about here? and What types of questions should I avoid asking?. Also Note that SO is NOT a code writing service...we are programmers trying to help other programmers through specific questions or errors. If you don't include the code you are working with and a detailed explanation of any errors or expectations vs reality...we can't help much. Use code formatted in MCVE – Rdster
I do not understand your problem. You say you have found code that saves attachments. That will include a statement something like ItemCrnt.Attachment(InxA) Path & FileName. Typically FileName will be the attachment's DisplayName. Firstly, You need to extract the extension with preceding period from DisplayName. Secondly replace the save statement with: ItemCrnt.Attachment(InxA) Path & ItemCrnt.Subject & " (" & InxA & ")" & Extn – Tony Dallimore
Can you post your code so we can help you fix it? – 0m3r
I added the script I am using now and added a little more detail to my request. Thanks a bunch for you time :) – Mike - SMT

2 Answers

2
votes

After some digging aroung looking at several posible options for omiting special characters from the subject line and some toying aroung with the macro I have come up with what seams to work perfectly for what I need.

Thank you 0m3r for your inital assistance in getting this taken care of.

The code below:

  1. selcet the folder to save all attachments to.
  2. It then pulls the subject line of each email
  3. Replaces any special characters I define with "_"
  4. Saves the file as the modified subject line.
  5. Repeates process for every selected email.

Paste:

Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object
Dim objShell            As Object
Dim objFolder           As Object
Dim objItem             As Outlook.MailItem
Dim selItems            As Selection
Dim atmt                As Attachment
Dim strAtmtPath         As String
Dim strAtmtFullName     As String
Dim strAtmtName         As String
Dim strAtmtNameTemp     As String
Dim intDotPosition      As Integer
Dim atmts               As Attachments
Dim lCountEachItem      As Long
Dim lCountAllItems      As Long
Dim strFolderPath       As String
Dim blnIsEnd            As Boolean
Dim blnIsSave           As Boolean
Dim strPrompt           As String, strname As String
Dim sreplace            As String, mychar As Variant
 blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
    lHwnd = FindWindow(olAppCLSN, vbNullString)
    If lHwnd <> 0 Then
        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)
        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)
            For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count
                If lCountEachItem > 0 Then
                    Set atmts = objItem.Attachments

                    If objItem.Class = olMail Then
                        If objItem.subject <> vbNullString Then
                            strname = objItem.subject
                        Else
                            strname = "No_Subject"
                        End If
                    sreplace = "_"
                    For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
                    'do the replacement for each character that's illegal
                        strname = Replace(strname, mychar, sreplace)
                    Next mychar
                    End If
                    For Each atmt In atmts
                        strAtmtFullName = atmt.FileName
                        intDotPosition = InStrRev(strAtmtFullName, ".")
                        strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                        strAtmtPath = strFolderPath & strname & Chr(46) & strAtmtName
                        Dim lngF As Long
                        lngF = 1
                        If Len(strAtmtPath) <= MAX_PATH Then
                            blnIsSave = True
                            Do While objFSO.FileExists(strAtmtPath)
                                strAtmtNameTemp = strname & "(" & lngF & ")"
                                strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName
                                If Len(strAtmtPath) > MAX_PATH Then
                                    lCountEachItem = lCountEachItem - 1
                                    blnIsSave = False
                                    Exit Do
                                End If
                            lngF = lngF + 1
                            Loop
                            If blnIsSave Then atmt.SaveAsFile strAtmtPath
                        Else
                            lCountEachItem = lCountEachItem - 1
                        End If
                    Next
                End If
                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   
Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
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
If blnIsEnd Then End
End Function
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
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

Edit:

Section of script used for API declarations that are needed to make this script work in outlooks VBA. This section of code goes before you declare all your variables above the line Public Function SaveAttachmentsFromSelection() As Long

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
1
votes

You need to modify your For Each loop, Try this...

Change this 

Dim strAtmtName(1)      As String

To this

Dim strAtmtName         As String

And then modify your For Each loop like this

For Each Atmt In atmts
    strAtmtFullName = Atmt.FileName
    intDotPosition = InStrRev(strAtmtFullName, ".")
    strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
    strAtmtPath = strFolderPath & objItem.Subject & Chr(46) & strAtmtName

    Dim lngF As Long
    lngF = 1

    If Len(strAtmtPath) <= MAX_PATH Then
        blnIsSave = True
        Do While objFSO.FileExists(strAtmtPath)

            strAtmtNameTemp = objItem.Subject & "(" & lngF & ")"

            strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName

            If Len(strAtmtPath) > MAX_PATH Then
                lCountEachItem = lCountEachItem - 1
                blnIsSave = False
                Exit Do
            End If

            lngF = lngF + 1
        Loop