Hello, I have the follwing bit of code which works fine at transferring any excel attatchments in an outlook folder into another folder as excel files.
Two things, when i run this as code within an access db it only transfers 8 of the 13 files but will transfer all when run from oultook?
Secondly, I would like it to transfer only excel files which do not have the term "Old Template" in cell A1 of the excel file.
Any help appreciated.
Option Compare Database
Sub GetAttachments()
On Error GoTo GetAttachments_err
' Declare variables for communicating with Outlook
Dim appOl As New Outlook.Application
Dim nsOl As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
'Dim SubFolder2 As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim strname As String
Dim stremail As String
Dim CC As String
Dim RecTime As String
Dim subject As String
Set nsOl = appOl.GetNamespace("MAPI")
Set Inbox = nsOl.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("DCT Journals")
Set DestFolder = Inbox.Folders("DCT Journals Loaded")
'Set SubFolder2 = SubFolder.Folders("DCT Journals Loaded")
' Declare variables for doing Excel work
Dim FileName As String
Dim TodaysFile As String
Dim objSheet As Worksheet
Dim EmptySheets As Integer
'Declare constant for saving attached files
'Change here to your own preferred path
'Const sFolder As String = "\\Chad-pl05\gim\Systems\Brendan Workings\DCT Late Adjustments\"
Const sFolder As String = "\\group-lmbd-m02\users$\Financial Reporting Risk\Operations & MI Team\Technical\DCTLateAdjustments\"
' These variables are counters to log work done
Dim i As Integer
i = 0
' Check Inbox for messages and check each message for attachments
If SubFolder.Items.Count > 0 Then
For Each Item In SubFolder.Items
strname = Item.SenderName
RecTime = Item.ReceivedTime
subject = Item.subject
stremail = Item.SenderEmailAddress
CC = Item.CC
' Loop through attachments (there may be more than one)
For Each Atmt In Item.Attachments
' If attachment is an Excel file (name ends with "xls") Open the file in Excel
If Right(Atmt.FileName, 3) = "xls" Then
FileName = sFolder & "DCT" & Format(Item.CreationTime, "_yyyymmdd_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Workbooks.Open FileName
FileName = ActiveWorkbook.Name
' Upload data to DCT database
Range("A30").FormulaR1C1 = "Originator:"
Range("A31").FormulaR1C1 = "CC'd"
Range("A32").FormulaR1C1 = "Received Time"
Range("A33").FormulaR1C1 = "Subject"
Range("B30").Value = strname
Range("B31").Value = CC
Range("B32").Value = RecTime
Range("B33").Value = subject
'Call RetrieveAttach
Workbooks(FileName).Close Savechanges:=True
End If
Next Atmt
'Item.subject = "Processed"
'Item.Move SubFolder.Folders("DCT Journals Loaded")
Item.Move DestFolder
Next Item
End If
' Restore screen updating and show summary message. Throw away
' new workbook if nothing was found
DoCmd.OpenForm "Switchboard", acNormal, "", "", , acNormal
If i > 0 Then
MsgBox "I found " & i & " Journal Attachments." _
& vbCrLf & "I have uploaded the journals into the database for authorisation" _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any Excel files in your mail.", _
vbInformation, "Finished!"
TodaysFileWb.Close False
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set nsOl = Nothing
Set appOl = Nothing
Exit Sub
Error handler
GetAttachments_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!"
'Application.StatusBar = False
Resume GetAttachments_exit
End Sub
Reply With Quote