Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-05-2019, 12:51 PM
abenitez77 abenitez77 is offline Extract attachments Windows 10 Extract attachments Office 2016
Novice
Extract attachments
 
Join Date: Apr 2019
Posts: 9
abenitez77 is on a distinguished road
Arrow Extract attachments

I am running this in outlook to extract all excel attachments, but It is not extracting all excel files. It is randomly skipping some. Can you see anything in the code that would cause that?



Code:
Sub SaveAttach_OnlyXLS() '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.
    Dim myExt               As String
    
    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0
    xlsCount = 0
    
    On Error Resume Next
    
    strFolderPath = "U:\Larryj\EmailExcelTest2\"
    
    Set selItems = ActiveExplorer.Selection
    SelCount = selItems.Count
    
    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 strFolderPath = "" Then
            '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
                            
                            '---------------------------------------------------------------
                            myExt = Mid(strAtmtFullName, InStrRev(strAtmtFullName, ".") + 1)
                            
                            'Only save files with named extensions
                            Select Case myExt
                                Case "xls", "xlsm", "xlsx", "xlsb"
                                    strFile = strFolderPath & objItem.EntryID & "__" & strAtmtFullName
                                    atmt.SaveAsFile strFile
                                    xlsCount = xlsCount + 1
                                Case Else
                                    'do nothing
                            End Select


                        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:
    'SaveAttach_OnlyXLS = lCountAllItems
    
    MsgBox "Processed: " & Trim(Str(SelCount)) & " Selected Email Msg's" & vbCrLf & _
            "Total # of Attachments: " & Trim(Str(lCountAllItems)) & vbCrLf & _
            "Extracted: " & Trim(Str(xlsCount)) & " Excel Attachments"
    
    ' /* 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 Sub
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
VBA extract attachments gazmoz17 Outlook 0 10-03-2019 07:36 AM
Extract attachments How to extract text between <> LearnerExcel Excel 4 02-07-2018 06:11 AM
Extract attachments Extract Between the Parens ChrisOK Word VBA 18 11-16-2017 12:59 PM
Extract name and address. donlincolnmsof Word VBA 1 11-10-2017 12:59 PM
Extract Photographs The Gap PowerPoint 4 04-22-2010 07:00 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 07:58 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft