How to verify a mail from today exist? - vba

I want to see if an email exists in a particular Outlook folder, using Excel VBA.
Sub Get_Calls_MTD_Data()
'making sure windows not jumping forth and back
Application.ScreenUpdating = False
Dim getCalls As Workbook
Dim releaseCalls As Workbook
Dim fPat As String
fPat = ThisWorkbook.Path
Dim SNDate As String
'The sheetname gets the date for the day name, so using variable for that
SNDate = Date
'-------------------
'Error handling doesn't work
'this dosent work any longer?
'If Dir(fPat & "\Outlookdata\calls mtd\" & Date & "." & "***") = "" Then
'
' MsgBox "does not find mail"
'
'Else
' making sure the windows dosen jump forth and back and no alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---------------------------
Set getCalls = Workbooks.Open(fPat & "\Outlookdata\Calls mtd\" & Date & "." & "*")
Set releaseCalls = Workbooks.Open(fPat & "\" & ThisWorkbook.Name)
getCalls.Activate
If Not IsEmpty(Range("G2").Value) = True Then
'finding last row
mylastagent = getCalls.Sheets(SNDate).Cells(Rows.Count, "G").End(xlUp).Row
getCalls.Sheets(SNDate).Range("G2:H" & mylastagent).Copy
releaseCalls.Activate
releaseCalls.Sheets("calls").Range("A1").PasteSpecial xlPasteValues
End If
getCalls.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("M3").Select
Update_Day_When_Calls_Updates
'Just the end if for the faulty error handling in the top
' End If
End Sub
Do I have to loop through the folder to find an email from today?
Also I started to get the prompt "clipboard has too much information, do you want to save it" in the end. Tried here for instance:
Disable clipboard prompt in Excel VBA on workbook close

Don't use strict date checks in Outlook. Instead, you need to use the Find/FindNext or Restrict methods of the Items class that allows getting only items that correspond to the search criteria. In the search criteria I'd recommend using less or greater conditions for dates.
Outlook evaluates date-time values according to the time format, short date format, and long date format settings in the Regional and Language Options applet in the Windows Control Panel. In particular, Outlook evaluates time according to that specified time format without seconds. If you specify seconds in the date-time comparison string, the filter will not operate as expected.
Although dates and times are typically stored with a date format, filters using the Jet and DAV Searching and Locating (DASL) syntax require that the date-time value to be converted to a string representation. In Jet syntax, the date-time comparison string should be enclosed in either double quotes or single quotes. In DASL syntax, the date-time comparison string should be enclosed in single quotes.
To make sure that the date-time comparison string is formatted as Microsoft Outlook expects, use the Visual Basic for Applications Format function (or its equivalent in your programming language).
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.
Read more about the Find/FindNext and Restrict methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
If you need to search for items in multiple folders you may consider using the AdvancedSearch method of the Application class, see Advanced search in Outlook programmatically: C#, VB.NET.

In the case of "today's mail", if processing time is noticeable, you can .Sort then stop processing once older mail is found.
Option Explicit
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
' Where code is not in Outlook
' Reference Microsoft Outlook nn.n Object Library
Dim ol As Outlook.Application
Dim fol As Outlook.Folder
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set fol = Session.Folders("Random#Email.com")
Set fol = fol.Folders("OutlookData")
Set fol = fol.Folders("Calls Daily")
Dim folItems As Items
Set folItems = fol.Items
folItems.Sort "[ReceivedTime]", True
Dim j As Long
For j = 1 To folItems.Count
If folItems(j).Class = olMail Then
Set mi = folItems(j)
If mi.Attachments.count > 1 Then
If Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
Debug.Print mi.Subject
Debug.Print " " & Format(mi.ReceivedTime, "yyyy-mm-dd")
Else
'Older mail
Exit For
End If
End If
End If
Next
End Sub
.Restrict and .Find could be applied to all cases.

I managed to do it like this, probably not the best way, no certainly not the best way, but i solved it for my needs :) Thanks Niton.
Public RecivedToday As String
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("Random#Email.com").Folders("OutlookData").Folders("Calls Daily")
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 1 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
'Debug.Print Format(mi.ReceivedTime, "yyyy-mm-dd")
RecivedToday = Format(Date, "yyyy-mm-dd")
'Debug.Print RecivedToday
End If
End If
Next i
End Sub

Related

430 Error on Date - itm.ReceivedTime in a subfolder

I get a 430 error running code on a subfolder of a shared inbox.
Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 34
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String
mailboxName = "mailboxname"
inboxName = "Inbox"
subfolderName = "subfoldername"
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder not found!", vbExclamation, _
"Problem with export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then 'check it's a mail item (not appointment, etc)
If Date - itm.ReceivedTime <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150) 'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ") 'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
End If
Next itm
MsgBox "Outlook Mails Extracted to Excel"
End Sub
I tried changing "itm" to "item". It works on the regular inbox. The issue happens when I try to pull from a subfolder.
I tried Debug Print. I don't know if I'm putting it in the right place.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
If I try to pull 30 days worth of data, it will only pull like the last seven days. So it works but it is limited.
First of all, the Sort method deals with non-existsing property:
Folder.Items.Sort "Received"
You need to use the ReceivedTime property instead.
Second, the sorted collection is lost and you continue dealing with unsorted one.
Folder.Items.Sort "Received"
For Each itm In Folder.Items
Asking each time the Items property returns a new Items instance. So, you need to get an instance once and then re-use in the code. Only by following this way you will preserve the sorting order.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
The error code indicates that Class doesn't support Automation (Error 430) which don't tell us anything meaningful.
Anyway, calculating dates that way to get items for specific dates in Outlook is not the best and proper way. Instead, you need to consider using the Find/FindNext or Restrict methods of the Items class which allows getting/dealing with items that correspond to your conditions only. Read more about these methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
For example, you could use the following search criteria to get items for a specific timeframe:
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.

How can I look at emails after a certain date?

This Outlook VBA code searches all emails in my Outlook subfolder, and then pulls the "Subject", "Date", "Creation Time", and "Body" of the email into an Excel file.
How can I implement some code that will look at emails after a certain date (e.g. 10/1/2022)?
My current code:
Sub List_Email_Info()
'Create excel object variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Long 'Row Tracker
Dim arrHeader As Variant
'Create outlook object variables
Dim olNS As NameSpace
Dim olInboxFolder As MAPIFolder
Dim olItems As Items
Dim olMailItem As MailItem
'store header names
arrHeader = Array("Date Created", "Subject", "Sender's Name", "Body")
'Create excel object's isntance
Set xlApp = CreateObject("excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set outlook variables
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Law360 Alerts")
Set olItems = olInboxFolder.Items
'Assign role value to i variable
i = 1
On Error Resume Next
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
'iteriate each item from the olItems object
For Each olMailItem In olItems
xlWB.Worksheets(1).Cells(i + 1, "A").Value = olItems(i).CreationTime
xlWB.Worksheets(1).Cells(i + 1, "B").Value = olItems(i).Subject
xlWB.Worksheets(1).Cells(i + 1, "C").Value = olItems(i).SenderName
xlWB.Worksheets(1).Cells(i + 1, "D").Value = olItems(i).Body
i = i + 1
Next olMailItem
'Autofit columns
xlWB.Worksheets(1).Cells.EntireColumn.AutoFit
'Display a messagebox when complete
MsgBox "Export Complete.", vbInformation
'Empty out the objects
Set xlWB = Nothing
Set xlApp = Nothing
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
Iterating over all items in the folder is not really a good idea:
'iteriate each item from the olItems object
For Each olMailItem In olItems
how to implement some code that will only look at emails after a certain date (e.g. 10/1/2022).
You need to use the Find/FindNext or Restrict methods of the Items class that allows getting only items that correspond to the search criteria. Here is an example of possible search criteria:
'All three filters shown below will return the same results
'This filter uses DASL date macro for today
strFilter = "%today(" _
& AddQuotes("urn:schemas:httpmail:datereceived") & ")%"
or
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
Outlook evaluates date-time values according to the time format, short date format, and long date format settings in the Regional and Language Options applet in the Windows Control Panel. In particular, Outlook evaluates time according to that specified time format without seconds. If you specify seconds in the date-time comparison string, the filter will not operate as expected.
Although dates and times are typically stored with a date format, filters using the Jet and DAV Searching and Locating (DASL) syntax require that the date-time value to be converted to a string representation. In Jet syntax, the date-time comparison string should be enclosed in either double quotes or single quotes. In DASL syntax, the date-time comparison string should be enclosed in single quotes.
To make sure that the date-time comparison string is formatted as Microsoft Outlook expects, use the Visual Basic for Applications Format function (or its equivalent in your programming language).
See Filtering Items Using a Date-time Comparison for more information.
Read more about the Find/FindNext and Restrict methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
If you need to search for items in multiple folders you may consider using the AdvancedSearch method of the Application class, see Advanced search in Outlook programmatically: C#, VB.NET.

Move specific mails from one folder to another

in Outlook I would like to have a FollowUp-Solution that checks a specific folder (Source Folder) if there are mails older than 1 days and moves them in another specific folder (Target Folder).
My problem is that it seems as my code isn't looping the SourceFolder properly. Some mails are moved but some old mails are still in the SourceFolder.
When I restart the Code some of the remaining mails are moved now but still some remain in the SourceFolder.
I tried to loop the Items in other ways (with; for each; do) but I guess my vba understanding is too bad to get a working solution.
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim Item As Object
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Set FolderItems = FolderSource.Items
For Each Item In FolderItems
If Item.ReceivedTime < Date - 1 Then '
Item.Move FolderTarget
End If
Next
End Sub
Does anyone know how to handle the propper looping?
For Each Loop is a great but When moving/deleting items Loop Through in Reverse Order you know count down (ie 3,2,1). In order to do this, you can incorporate Step -1 into your loop statement.
Also to improve your loop try using Items.Restrict Method (Outlook) on your date filter
Example
Option Explicit
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " <= 'Date - 1' "
Set FolderItems = FolderSource.Items.Restrict(Filter)
Debug.Print FolderItems.Count
Dim i As Long
For i = FolderItems.Count To 1 Step -1
Debug.Print FolderItems(i) 'Immediate Window
' FolderItems(i).Move FolderTarget
Next
End Sub

Outlook Forms: Importing / VLOOKUP Data from Excel?

I am a bit new to Outlook forms, but not to VBA overall - nor HTML/Web design of forms. However, my problem is finding a way to combine the two.
I am trying to design a form for users to fill out, and based on what they fill out in drop-down box's, it will then tell them what we want them to attach in the email. Currently we have this done in Excel, based on dropbox's it then VLOOKUPS to the 2nd Spreadsheet that contains the forms required.
Is there anyway I can bring in the Excel with the VLOOKUP behind the scenes in my VBA Outlook Form so that it can look-up what attachments we want the user to do? Otherwise, it would be a TON of SELECT CASE statements in VBA =/
This seems to the do the trick for me.
Some of it I have cobbled together from sites like this, the rest has been created by myself from scratch.
When I click my button:
An input box appears, which is the value that will be looked up in the spreadsheet.
it looks in the range (specified in the code), for a match
returns the value, two columns to the left of it.
when it finds a match it puts it in the Subject line in Outlook.
Dim jobno As String
Dim Proj As String
Sub Test()
jobno = InputBox("Job Number?", "Test")
GetNameFromXL
If jobno <> "" Then
Set myItem = Application.CreateItem(0)
If Proj <> "" Then
myItem.Subject = jobno & " - " & Proj & " - " & Format(Date, "dd.mm.yy")
Else
myItem.Subject = jobno & " - " & Format(Date, "dd.mm.yy")
End If
myItem.Display
Else
Exit Sub
End If
End Sub
Sub GetNameFromXL()
'Late binding. No reference to Excel Object required.
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Set xlApp = CreateObject("Excel.Application")
'Open the spreadsheet to get data
Set xlWB = xlApp.Workbooks.Open("X:\...\FILENAME.xlsx") ' <-- Put your file path and name here
Set xlWS = xlWB.Worksheets(1) ' <-- Looks in the 1st Worksheet
Debug.Print "-----Start of 'For Each' loop"
For Each c In xlWS.Range("A6:A100") 'Change range to value you want to 'VLookUp'
Proj = c.Offset(0, 2).Value 'This looks at the 2nd column after the range above
Debug.Print c & Proj
If jobno = c Then
Debug.Print "-----Match Found: " & jobno & " = " & Proj
GoTo lbl_Exit
Else
End If
Next c
Debug.Print "-----End of For Each loop"
MsgBox jobno & " not found in WorkBook."
'Clean up
Set xlWS = Nothing
Set xlWB = Nothing
Set c = Nothing
Proj = ""
xlApp.Quit
Set xlApp = Nothing
lbl_Exit:
Exit Sub
End Sub

Creating a Windows application which reads and writes excel spreadsheets + reads and writes emails

I'm an intern in Europe working at a hospital. My daily job is to find replacements for a nurse or doctor or surgeon when one is needed. To do this, I receive a request from a certain department, in the form of an excel spreadsheet with 4 different attributes which determines the time, department and specific type of personnel required.
From that info I look into a fixed database which is also based in an excel spreadsheet, for someone who matches the requirements.
After I send an email/sms or call the department head to get an approval, in which the reply is almost always yes.
Once I get the confirmation, I send the replacement's information to the department which requires the replacement and then my job is done. I do about 150 of these requests a day and if I can write a program for this, I would be able to save the hospital a lot of tax payers money, as they employ 3 other people to do this job.
Therefore, my question:
What is the best language to write this program in?
Would you recommend a scripting language which may make it easier to access files and send emails? or would that we too weak for this task?
The requirements for the language are to do the following:
Access excel spreadsheets
Read the spreadsheet and copy the values from an array of cells
Find a value in the spreadsheet
send emails with the values I obtained in my excel spreadsheet search?
read an email and if value is = to YES, do ... else do ...
finally, send an email with xxxxx information to xxx person
If I were using my mac, I would have gone to a scripting language like applescript combined with automator to access and read the excel files and send emails/sms's.
Thanks for you help in advance.
The code below is a long way from a complete solution. Its purpose is to start you thinking about how your system will function.
Looking to the future, I envisage the need for a text file which I have named HumanActionRequired.txt. The tenth line of code is a constant that specifies the folder in which this file will be created. You must replace "C:\DataArea\Play" with the name of a folder on your system. You may wish to rename the file: see sixth line.
Although I envisage this file to be the destination of error messages, I have used it here to list details of the messages in InBox. I have only output a small selection of the available properties but it should get you thinking about what is possible.
The code below belongs in a Module within OutLook:
Open Outlook.
Select Tools, Macro and Security. You will need to set the security level to Medium. Later you can discuss getting trusted status for your macro with your IT department but this will do for now.
Select Tools, Macro and Visual Basic Editor or click Alt+F11.
You will probably see the Project Explorer down the left (Control+R to display if not). If you have never created an Outlook macro, the area to the right will be grey.
Select Insert, Module. The grey area will go white with the code area above and the Immediate window below.
Copy the code below into the code area.
Position the cursor within the macro LocateInterestingEmails() and click F5. You will be warned that a macro is trying to access your emails. Tick Allow access for and select a time limit then click Yes. The macro will write selected properties of the emails in Inbox to the file HumanActionRequired.txt.
Option Explicit
Sub LocateInterestingEmails()
Dim ErrorDescription As String
Dim ErrorNumber As Long
Static ErrorCount As Integer
Const FileCrnt As String = "HumanActionRequired.txt"
Dim FolderTgt As MAPIFolder
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim OutputFileNum As Long
Const PathCrnt As String = "C:\DataArea\Play"
ErrorCount = 0
OutputFileNum = 0
Restart:
' On Error GoTo CloseDown
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileCrnt For Append Lock Write As #OutputFileNum
For InxItemCrnt = 1 To FolderTgt.Items.Count
With FolderTgt.Items.Item(InxItemCrnt)
If .Class = olMail Then
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Subject: " & .Subject
Print #OutputFileNum, "Sender: " & .SenderEmailAddress
Print #OutputFileNum, "Recipient: " & .To
Print #OutputFileNum, "Date sent: " & .SentOn
If .Attachments.Count > 0 Then
Print #OutputFileNum, "Attachments:"
For InxAttachCrnt = 1 To .Attachments.Count
Print #OutputFileNum, " " & .Attachments(InxAttachCrnt).DisplayName
Next
End If
End If
End With
Next
CloseDown:
ErrorNumber = Err.Number
ErrorDescription = Err.Description
Err.Clear
Set FolderTgt = Nothing
If ErrorNumber <> 0 Then
' Here because of an error
If OutputFileNum = 0 Then
' Output file not open
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileCrnt For Append Lock Write As #OutputFileNum
End If
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Error at " & Now()
Print #OutputFileNum, "Error number = " & ErrorNumber & _
" description = " & ErrorDescription
End If
If OutputFileNum <> 0 Then
' File open
Close OutputFileNum
OutputFileNum = 0
End If
End Sub
Version 2
This version includes the code in the first version plus:
It opens an existing workbook to which it saves information about the Excel attachments found.
It identifies attachments with an extension of xls? and saves them to disc with a name based on the date/time received and the sender's name.
It opens each saved attachment. For each worksheet in a saved attachment, it creates a row in the existing workbook containing filenames, sender name and email address, sheet name and the value of cell A1.
I do not think this code will be directly useful but it shows how to save attachments and open workbooks to read from or write to then which I believe you will need.
The only code I know to be missing is:
Move processed email to save folder.
Generate reply email.
However, more code may be necessary depending on how you want to automate the entire process.
The code below is not as neat as I would like. I do not want to add any more until you have fully understood it. I would also like a better understanding of the emails you plan to send and the desired automation of the total process.
Come back with questions on any part of the code you do not understand.
Option Explicit
Sub LocateInterestingEmails()
' I use constants to indentify columns in worksbooks because if I move the
' column I only need to update the constant to update the code. I said the
' same in a previous answer and some one responded that they preferred
' Enumerations. I use Enumerations a lot but I still prefer to use constants
' for column numbers.
Const ColSumFileNameSaved As String = "A"
Const ColSumFileNameOriginal As String = "B"
Const ColSumSenderName As String = "C"
Const ColSumSenderEmail As String = "D"
Const ColSumSheet As String = "E"
Const ColSumCellA1 As String = "F"
' You must change the value of this constant to the name of a folder on your
' computer. All file created by this macro are written to this folder.
Const PathCrnt As String = "C:\DataArea\Play"
' I suggest you change the values of these constants to
' something that you find helpful.
Const FileNameHAR As String = "HumanActionRequired.txt"
Const FileNameSummary As String = "Paolo.xls"
Dim CellValueA1 As Variant
Dim ErrorDescription As String
Dim ErrorNumber As Long
Dim FileNameReqDisplay As String
Dim FileNameReqSaved As String
Dim FolderTgt As MAPIFolder
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim InxSheet As Long
Dim OutputFileNum As Long
Dim Pos As Long
Dim ReceivedTime As Date
Dim RowSummary As Long
Dim SenderName As String
Dim SenderEmail As String
Dim SheetName As String
Dim XlApp As Excel.Application
Dim XlWkBkRequest As Excel.Workbook
Dim XlWkBkSummary As Excel.Workbook
' Ensure resource controls are null before macro does anything that can cause
' an error so error handler knows if the resource is to be released.
OutputFileNum = 0
Set XlApp = Nothing
Set XlWkBkRequest = Nothing
Set XlWkBkSummary = Nothing
' Open own copy of Excel
Set XlApp = Application.CreateObject("Excel.Application")
With XlApp
.Visible = True ' This slows your macro but helps during debugging
' Open workbook to which a summary of workbooks extracted will be written
Set XlWkBkSummary = .Workbooks.Open(PathCrnt & "\" & FileNameSummary)
With XlWkBkSummary.Worksheets("Summary")
' Set RowSummary to one more than the last currently used row
RowSummary = .Cells(.Rows.Count, ColSumFileNameSaved).End(xlUp).Row + 1
End With
End With
Restart:
' I prefer to have my error handler switched off during development so the
' macro stops on the faulty statement. If you remove the comment mark from
' the On Error statement then any error will cause the code to junp to label
' CloseDown which is at the bottom of this routine.
' On Error GoTo CloseDown
' Gain access to InBox
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' Open text file for output. I envisage this file being used for error
' messages but for this version of the macro I write a summary of the
' contents of the InBox to it.
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileNameHAR For Output Lock Write As #OutputFileNum
For InxItemCrnt = 1 To FolderTgt.Items.Count
With FolderTgt.Items.Item(InxItemCrnt)
If .Class = olMail Then
' Only interested in mail items. Most of the other items will be
' meeting requests.
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Subject: " & .Subject
' Currently we are within With FolderTgt.Items.Item(InxItemCrnt).
' Values from this mail item are to be written to a workbook
' for which another With will be required. Copy values to
' variables for they are accessable.
' Note: XlApp.XlWkBkSummary.Worksheets("Summary")
' .Cells(RowSummary, ColSumFileNameOriginal).Value = _
' FolderTgt.Items.Item(InxItemCrnt).Attachments(InxAttachCrnt) _
' .DisplayName
' is legal but is not very clear. Code is much clearer will full use
' of With stateents even if it means values must be copied to variable.
SenderName = .SenderName
SenderEmail = .SenderEmailAddress
ReceivedTime = .ReceivedTime
Print #OutputFileNum, "SenderName: " & SenderName
Print #OutputFileNum, "SenderAddr: " & SenderEmail
Print #OutputFileNum, "Received: " & ReceivedTime
Print #OutputFileNum, "Date sent: " & .SentOn
If .Attachments.Count > 0 Then
Print #OutputFileNum, "Attachments:"
For InxAttachCrnt = 1 To .Attachments.Count
With .Attachments(InxAttachCrnt)
' I cannot find an example for which the
' DisplayName and FileName are different
FileNameReqDisplay = .DisplayName
Print #OutputFileNum, " " & FileNameReqDisplay & "|" & .FileName
Pos = InStrRev(FileNameReqDisplay, ".")
' With ... End With and If ... End If must be properly nested.
' Within the If below I want access to the attachment and to the
' workbook. Hence the need to terminate the current With and then
' immediately start it again within the If ... End If block.
End With
If LCase(Mid(FileNameReqDisplay, Pos + 1, 3)) = "xls" Then
With .Attachments(InxAttachCrnt)
' Save the attachment with a unique name. Note this will only be
' unique if you do not save the same attachment again.
FileNameReqSaved = _
Format(ReceivedTime, "yyyymmddhhmmss") & " " & SenderName
.SaveAsFile PathCrnt & "\" & FileNameReqSaved
End With
' Open the saved attachment
Set XlWkBkRequest = _
XlApp.Workbooks.Open(PathCrnt & "\" & FileNameReqSaved)
With XlWkBkRequest
'Examine every worksheet in workbook
For InxSheet = 1 To .Worksheets.Count
With .Worksheets(InxSheet)
' Save sheet name and a sample value
SheetName = .Name
CellValueA1 = .Cells(1, 1).Value
End With
' Save information about this sheet and its workbook
With XlWkBkSummary.Worksheets("Summary")
.Cells(RowSummary, ColSumFileNameSaved).Value = _
FileNameReqSaved
.Cells(RowSummary, ColSumFileNameOriginal).Value = _
FileNameReqDisplay
.Cells(RowSummary, ColSumSenderName).Value = SenderName
.Cells(RowSummary, ColSumSenderEmail).Value = SenderEmail
.Cells(RowSummary, ColSumSheet).Value = SheetName
.Cells(RowSummary, ColSumCellA1).Value = CellValueA1
RowSummary = RowSummary + 1
End With ' XlWkBkSummary.Worksheets("Summary")
Next InxSheet
.Close SaveChanges:=False
Set XlWkBkRequest = Nothing
End With ' XlWkBkRequest
End If
Next
End If
End If
End With
Next
CloseDown:
ErrorNumber = Err.Number
ErrorDescription = Err.Description
Err.Clear
Set FolderTgt = Nothing
If ErrorNumber <> 0 Then
' Have reached here because of an error
If OutputFileNum = 0 Then
' Output file not open
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileNameHAR For Append Lock Write As #OutputFileNum
End If
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Error at " & Now()
Print #OutputFileNum, "Error number = " & ErrorNumber & _
" description = " & ErrorDescription
End If
' Release resources
If OutputFileNum <> 0 Then
' File open
Close OutputFileNum
OutputFileNum = 0
End If
If Not (XlWkBkRequest Is Nothing) Then
XlWkBkRequest.Close SaveChanges:=False
Set XlWkBkRequest = Nothing
End If
If Not (XlWkBkSummary Is Nothing) Then
XlWkBkSummary.Close SaveChanges:=True
Set XlWkBkSummary = Nothing
End If
If Not (XlApp Is Nothing) Then
XlApp.Quit
Set XlApp = Nothing
End If
End Sub