#1
|
|||
|
|||
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 |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
VBA extract attachments | gazmoz17 | Outlook | 0 | 10-03-2019 07:36 AM |
How to extract text between <> | LearnerExcel | Excel | 4 | 02-07-2018 06:11 AM |
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 |