I would like to have a macro that I can hit, it reads the email subject line 03100-001-01 and it then saves in that directory on my computer. I just have no idea where to start.
I have no tried anything at this stage
You can use the Subject property of Outlook items to get the subject string. Then you can use the InStr function which returns a long (number) specifying the position of the first occurrence of one string within another. For example:
Dim SearchString, SearchChar, MyPos
SearchString ="XXpXXpXXPXXP" ' String to search in.
SearchChar = "P" ' Search for "P".
' A textual comparison starting at position 4. Returns 6.
MyPos = Instr(4, SearchString, SearchChar, 1)
' A binary comparison starting at position 1. Returns 9.
MyPos = Instr(1, SearchString, SearchChar, 0)
' Comparison is binary by default (last argument is omitted).
MyPos = Instr(SearchString, SearchChar) ' Returns 9.
MyPos = Instr(1, SearchString, "W") ' Returns 0.
Finally, to save the item you need to use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used.
Sub SaveAsMsg()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
But I'd recommend starting from the following articles to build a basic understanding how VBA macros work:
Getting started with VBA in Office
Using Visual Basic for Applications in Outlook
Related
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.
I am a beginner with Excel VBA and have some questions.
I want to search a specified folder based on user input (a file name). I can get that part to work, however, I want it to search for more than just the one format (.docx), and also include a search of both .pdf and .doc.
Clarification:
The folder under G:\NEWFOLDER\NAMEFOLDER contains files with extensions .doc, .docx, and .pdf and I want to search the entire folder and report back to my spreadsheet on Sheet2.
Dim NAME As String
Dim File_Path As String
NAME = InputBox(" Enter Your NAME (EX: JOHNP) ")
File_Path = "G:\NEWFOLDER\NAMEFOLDER" & NAME & ".docx"
If Dir(File_Path) <> "" Then
ThisWorkbook.Sheets("Sheet2").Activate
Range("D5") = ("Checked")
Range("E5") = NAME
Else
MsgBox "NAME Not found"
End If
End Sub
How do I search the document within?
Clarification:
The above code only tells me if the user input is located inside the coded path. The next step I want to do is to search within that document for keyword and report back to spreadsheet. For example, within JOHNP.doc there is a column of age. I want the code to report back to Sheet2 cell with "22".
Is this even possible with word document search, or is it better if the JOHNP is in excel format?
This should help you a little bit - This will cycle through files in the named folder location (if it exists), and will only target ones that are .doc, .docx or .pdf.
As for your second question - Yes, you can pull that number from your documents, however, you'll need to be more specific as to where that number is. If it's in the same spot each time, then that would be fairly easy - hopefully in a Table, then it would have an explicit reference (like ActiveDocument.Tables(1).Cells(1,1), etc. For now, this code below will go through all the files and when it finds the first match, it'll open the word document for you (then exit the loop).
Sub Test()
Dim NAME As String
Dim File_Path As String
Dim StrFile As String
NAME = InputBox(" Enter Your NAME (EX: JOHNP) ")
File_Path = "G:\NEWFOLDER\NAMEFOLDER\" & NAME & "\"
StrFile = Dir(File_Path)
If Dir(File_Path) <> "" Then
Do While Len(StrFile) > 0
If InStr(StrFile, ".doc") > 0 Or _
InStr(StrFile, ".pdf") > 0 Then
Debug.Print StrFile
'ThisWorkbook.Sheets("Sheet2").Range("D5") = ("Checked")
'ThisWorkbook.Sheets("Sheet2").Range("E5") = NAME
If InStr(StrFile, ".doc") > 0 Then
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open File_Path & StrFile
wordapp.Visible = True
Exit Do
End If
End If
StrFile = Dir
Loop
Else
MsgBox NAME & " Not found"
End If
End Sub
I am having difficulties having a button perform what I want. I have an MS Access db which I input all of the information for a particular project. I also have a contract word document which is mail merged with this db.
So far with the help of some of you I've gotten this far (code below). It works, but if I have 120 records when the button is pressed it creates a long contract with all 120 records. I simply want to have just the current record (the record on my screen at the time) to only make a pdf.
I would also like to name the pdf which is created use a naming convention such as, "Name of product - Name of client". Both are fields in the record.
I want to add I am not a coder by no stretch of the imagination, kudos to you all that do this everyday....you are unsung heros.
Option Compare Database
Option Explicit
Private Sub Command205_Click()
Dim strWordDoc As String
'Path to the word document of the Mail Merge
'###-1 CHANGE THE FOLLOWING LINE TO POINT TO YOUR DOCUMENT!!
strWordDoc = "C:\Users\...\Google Drive\contract.docx"
' Call the code to merge the latest info
startMerge strWordDoc
End Sub
'----------------------------------------------------
' Auto Mail Merge With VBA and Access (Early Binding)
'----------------------------------------------------
' NOTE: To use this code, you must reference
' The Microsoft Word 14.0 (or current version)
' Object Library by clicking menu Tools > References
' Check the box for:
' Microsoft Word 14.0 Object Library in Word 2010
' Microsoft Word 15.0 Object Library in Word 2013
' Click OK
'----------------------------------------------------
Function startMerge(strDocPath As String)
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim wdInputName As String
Dim wdOutputName As String
Dim outFileName As String
' Set Template Path
wdInputName = strDocPath ' was CurrentProject.Path & "\mail_merge.docx"
' Create unique save filename with minutes and seconds to prevent overwrite
outFileName = "[Product Name]_" & Format(Now(), "mmddyyyy")
' Output File Path w/outFileName
wdOutputName = CurrentProject.Path & "\" & outFileName
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(wdInputName)
' Start mail merge
'###-2 CHANGE THE SQLSTATEMENT AS NEEDED
With oWdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [Contract Information]" ' Change the table name or your query"
.Destination = wdSendToNewDocument
.Execute Pause:=False
End With
' Hide Word During Merge
oWord.Visible = False
' Save file as PDF
' Uncomment the line below and comment out
' the line below "Save file as Word Document"
'------------------------------------------------
oWord.ActiveDocument.SaveAs2 wdOutputName & ".pdf", 17
' Save file as Word Document
' ###-3 IF YOU DON'T WANT TO SAVE AS A NEW NAME, COMMENT OUT NEXT LINE
'oWord.ActiveDocument.SaveAs2 wdOutputName & ".docx", 16
' SHOW THE DOCUMENT
oWord.Visible = True
' Close the template file
If oWord.Documents(1).FullName = strDocPath Then
oWord.Documents(1).Close savechanges:=False
ElseIf oWord.Documents(2).FullName = strDocPath Then
oWord.Documents(2).Close savechanges:=False
Else
MsgBox "Well, this should never happen! Only expected two documents to be open"
End If
' Quit Word to Save Memory
'oWord.Quit savechanges:=False
' Clean up memory
'------------------------------------------------
Set oWord = Nothing
Set oWdoc = Nothing
End Function
Filter the SQL to return only the current Id:
SQLStatement:="SELECT * FROM [Contract Information] Where ProjectId = " & Me!ProjectId.Value & ""
and adjust outFileName to reflect "Name of product - Name of client":
outFileName = Me!ProductName.Value & " - " & Me!ClientName.Value
I am using the below code to export emails as individual text files to system folder.I need to replace the third line in the text file as a string for all the text files each time in the loop.any one can suggest a solution
' General Declarations
Option Explicit
' Public declarations
Public Enum olSaveAsTypeEnum
olSaveAsTxt = 0
olSaveAsRTF = 1
olSaveAsMsg = 3
End Enum
Sub COBExport_MailasMSG()
' Routine will take all selected mails and export them as .MSG files to the
' directory defined by
' Error Handling
On Error Resume Next
' Varaiable Declarations
Dim objItem As Outlook.MailItem
Dim strExportFolder As String: strExportFolder = "I:\Documents\"
Dim strExportFileName As String
Dim strExportPath As String
Dim objRegex As Object
Dim OldName As String, NewName As String
' Initiate regex search
Set objRegex = CreateObject("VBScript.RegExp")
With objRegex
.Pattern = "(\s|\\|/|<|>|\|\|\?|:)"
.Global = True
.IgnoreCase = True
End With
' Check if any objects are selected.
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item has been selected.")
Else
' Cycle all selected objects.
For Each objItem In Application.ActiveExplorer.Selection
' If the currently selected item is a mail item we can proceed
If TypeOf objItem Is Outlook.MailItem Then
' Export to the predefined folder.
strExportFileName = objRegex.Replace(objItem.Subject, "_")
strExportPath = strExportFolder & strExportFileName & ".txt"
objItem.SaveAs strExportPath, olSaveAsTxt
'MsgBox ("Email saved to: " & strExportPath)
OldName = Dir(strExportPath)
NewName = Left(strExportPath, Len(strExportPath) - Len(OldName)) & _
Left(OldName, Len(OldName) - 4) & "Dir" & _
CStr(Format(FileDateTime(strExportPath), "ddmmyyhhmmss")) & ".txt"
Name strExportPath As NewName
Else
' This is not an email item.
End If
Next 'objItem
End If
' Clear routine memory
Set objItem = Nothing
Set objRegex = Nothing
End Sub
This solution might cut out the middle man of what you are trying to do. Instead of updating the file after it is exported why dont we just edit the body of the email before hand!
BE WARNED that this will temporarily change the body of your emails. If the process fails or the code is not used properly you can damage email permanently. You should test this on mail you don't care about.
I did try to copy the mail so that we could edit a copy but that ended up with another copy of the mail, in Outlook, that i could not programically delete. Therefore this solution seemed cleaner.
' declaration to go with the others
Dim strEmailBodybackup As String
' this will go in your for loop
' Save the body so that we can restore it after.
strEmailBodybackup = objItem.Body
' Edit the body of the mail to suit needs.
objItem.Body = Replace(objItem.Body, "scantext", "Tscanfile", , 1, vbTextCompare)
' Process the export like in your question
' Restore the body of the original mail
objItem.Body = strEmailBodybackup
You can look up the Replace command here
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