I want functionality to a button in Access - vba

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

Related

MS Word vba to save .docm to .docx WITHOUT converting active document

I have an MS Word document with macros (.docm)
Based on many StackOverflow posts, I've written a macro to export as a pdf and save as a .docx
I open/edit the .docm document, that has an onSave macro that saves the document in .pdf format and .docx format which I distribute for other people to use. I will always be making my changes to the .docm document.
My issue is that doing so converts the active(open) document from .docm to .docx such that I'm no longer making my changes to the .docm.
Sub SaveActiveDocumentAsDocx()
On Error GoTo Errhandler
If InStrRev(ActiveDocument.FullName, ".") <> 0 Then
Dim strPath As String
strPath = Left(ActiveDocument.FullName, InStrRev(ActiveDocument.FullName, ".") - 1) & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath, FileFormat:=wdFormatDocumentDefault
End If
On Error GoTo 0
Exit Sub
Errhandler:
MsgBox "There was an error saving a copy of this document as DOCX. " & _
"Ensure that the DOCX is not open for viewing and that the destination path is writable. Error code: " & Err
End Sub
I can find no parameter to prevent this conversion of the active document in either "saveas" or "saveas2"
Furthermore, after the "saveas" command, any additional lines in the original macro are not executed because the active document no longer contains macros. I tried adding lines to the macro to reopen the original .docm and then close the .docx but those commends never execute.
I'm hoping I'm just missing something simple?
Sub SaveAMacrolessCopyOfActiveDocument()
' Charles Kenyon 2 October 2020
' Save a copy of active document as a macrofree document
'
Dim oDocument As Document
Dim oNewDocument As Document
Dim iLength As Long
Dim strName As String
Set oDocument = ActiveDocument ' - saves a copy of the active document
' Set oDocument = ThisDocument '- saves copy of code container rather than ActiveDocument
Let iLength = Len(oDocument.Name) - 5
Let strName = Left(oDocument.Name, iLength)
Set oNewDocument = Documents.Add(Template:=oDocument.FullName, DocumentType:=wdNewBlankDocument, Visible:=False)
oNewDocument.SaveAs2 FileName:=strName & ".docx", FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=15
oNewDocument.Close SaveChanges:=False
' Clean up
Set oDocument = Nothing
Set oNewDocument = Nothing
End Sub
The above code creates and saves a copy of the ActiveDocument with the same name but as a .docx formatted document (macro-free). The visible property in the .Add command means that it will not appear on screen and it is closed by the procedure. The new document will appear in Recent documents.

Need to open an excel file manually in the middle of a macro

First time posting so please be kind.
From a template file, I am running a macro to create a new folder with a copy of the template file in it. I then rename it and update it. At one point, I need to manually download a file from a website and open it and then start another macro to finish the update.
I initially tried to do that from one unique macro but I got issues as the macro would keep running before the excel file had time to open.
I have now split my macro in 2. At the end of the 1st macro, I call a userform with instructions and a continue button. The idea is that I would download the file while the userform is opened and click on "continue" when the file is opened.
For some reason, the file does not open at all. It seems like either the userform or the macro stops the file from opening. However, If I run it using the debug function, It works fine...
Public strSN As String, strPart As String, strPath As String
Sub create_new()
' Create Folder if it doesn't exist
'Dim strSN As String, strPart As String, strPath As String
'strSN = SerialNumber.Value
'strPart = PartNumber.Value
'strPath = "M:\Quality\QUALITY ASSURANCE\DOC\Rental Folder\Scanned MRB's\"
' close userform
welcomeform.Hide
'set Microsoft scription runtime reference to allow creation of folder macro
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D- 00A0C9054228}", 1, 0
On Error GoTo 0
If Not FolderExists(strSN) Then
'Serial Number folder doesn't exist, so create full path
FolderCreate strPath & strSN
End If
' Create new file in new folder
On Error Resume Next
ActiveWorkbook.SaveCopyAs Filename:=strPath & strSN & "\" & strPart & " " & strSN & " " & "SNR.xlsm"
If Err.Number <> 0 Then
MsgBox "Copy error: " & strPath & "TEMPLATE SNR.xlsm"
End If
On Error GoTo 0
' open new file without showing it or opening macros
Application.EnableEvents = False 'disable Events
Workbooks.Open Filename:=strPath & strSN & "\" & strPart & " " & strSN & " " & "SNR.xlsm"
Application.EnableEvents = True 'enable Events
' Modify serial number and part number in traceability summary form
Sheets("Traceability Summary Form").Activate
Sheets("Traceability Summary Form").Unprotect
Range("A7").Value = strSN
Range("C7").Value = strPart
' update file with ITP
Call Download_itp
End Sub
Sub Download_itp()
downloaditp.Show
End Sub
In the download_itp userform:
Sub continue_Click()
Call update_traceable_items
End Sub
Then the 2nd macro starts with code:
Sub update_traceable_items()
'
' Macro to update the SNR tab with the traceable items from the ITP
'
downloaditp.Hide
' copy ITP in file
Application.ActiveProtectedViewWindow.Edit
ActiveSheet.Name = "ITP"
ActiveSheet.Copy after:=Workbooks(strPart & " " & strSN & " " & "SNR.xlsm").Sheets("SNR template")
Any help would be appreciated!
Thanks
The UserForm is being displayed modally, which probably prevents you from "opening" the recently downloaded file. When UserForm is displayed modally, the user is prevented from "interacting" with any part of Excel Application that is not the UserForm itself -- so you can't select cells or worksheets, you can't open files or close files, etc.
This is the default behavior for UserForms, but fortunately there is an optional parameter for the .Show method which allows you to display the form "modelessly":
downloaditp.Show vbModeless
This allows you to interact with the Excel Application while the form is open.
Note: If the file is on a shared network location, you can probably handle this better by using a FileDialog object to allow you to "browse" to the location of the file, and open it, all within the scope of your main procedure, like:
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 1 Then
MsgBox "No file selected!", vbCritical
Exit Sub
Else
Dim NewWorkbook as Workbook
Set NewWorkbook = Workbooks.Open(.SelectedItems(0))
End If
End With

Assistance needed in automating the process of populating a word template from Excel

I'm a complete newbie to VBA and would really appreciate some help automating a process, if anyone would be so kind. :)
I am trying to populate a Word template from an excel spreadsheet I have created
I have found some code which emables me to open my Word template, but that's as far as I'm capable of going :( lol
Private Sub PrintHDR_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\Duncan\Desktop\HDR.dotx"
End Sub
The next step I wish to achieve is to copy and paste data from certain cells into my Word document.
I have set up the bookmarks in Word and have named the cells I wish to copy.
Some cells contain text, other cells contain formulas / sums which produce a numerical answer. In the cells that contain formulas or sums, it is the answer which I want copied to Word.
Any help would be much appreciated.
Thanks in advance :)
Duncan
I have code that does something like this. In Word, instead of using bookmarks for the fields to replace, I just use a special marker (like <<NAME>>).
You may have to adapt. I use a ListObject (the new Excel "Tables"), you can change that if you use a simple Range.
Create a "Template.docx" document, make it read-only, and place your replaceable fields there (<<NAME>>, etc.). A simple docx will do, it doesn't have to be a real template (dotx).
Public Sub WriteToTemplate()
Const colNum = 1
Const colName = 2
Const colField2 = 3
Const cBasePath = "c:\SomeDir"
Dim wordDoc As Object, sFile As String, Name As String
Dim lo As ListObject, theRow As ListRow
Dim item As tItem
Set lo = ActiveCell.ListObject
Set theRow = ActiveCell.ListObject.ListRows(ActiveCell.Row - lo.Range.Row)
With theRow.Range
'I use one of the columns for the filename:
Debug.Print "writing " & theRow.Range.Cells(1, colName).text
'A filename cannot contain any of the following characters: \ / : * ? " < > |
Name = Replace(.Cells(1, colName), "?", "")
Name = Replace(Name, "*", "")
Name = Replace(Name, "/", "-")
Name = Replace(Name, ":", ";")
Name = Replace(Name, """", "'")
sFile = (cBasePath & "\" & Name) & ".docx"
Debug.Print sFile
Set wordApp = CreateObject("word.Application")
If Dir(sFile) <> "" Then 'file already exists
Set wordDoc = wordApp.Documents.Open(sFile)
wordApp.Visible = True
wordApp.Activate
Else 'new file
Set wordDoc = wordApp.Documents.Open(cBasePath & "\" & "Template.docx")
wordApp.Selection.Find.Execute Forward:=(wordApp.Selection.Start = 0), FindText:="««NUM»»", ReplaceWith:=.Cells(1, colNum)
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:="««NAME»»", ReplaceWith:=.Cells(1, colName)
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:="««FIELD2»»", ReplaceWith:=.Cells(1, colField2)
wordDoc.ListParagraphs.item(1).Range.Select
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Visible = True
wordApp.Activate
On Error Resume Next
'if this fails (missing directory, for example), file will be unsaved, and Word will ask for name.
wordDoc.SaveAs sFile 'Filename:=(cBasePath & "\" & .Cells(1, colName))
On Error GoTo 0
End If
End With
End Sub
This basically replicates the Mail Merge function in code, to give you more control.

replace the third line of each text files to string using a VBA script

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

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