Save zip attachments from Outlook in an internal drive (folder) - excel

I work in bank and we have a lot of restrictions. I can't use the Developer option in Outlook. I can use Excel VBA.
I would like to automate saving a zip file, which is received everyday, in a local drive folder and automatically unzip it and replace the yesterday's file.
I would like to create a button in an Excel sheet. Once I press the button the attachment in Outlook should save in a local folder in whatever destination I want and the attachment should unzip.
I have tried some things saving attachments from Outlook by using VBA, but it doesn't help much.

I am not surprised a bank doesn’t want its emails accessed. You could change the sender, add or remove recipients or change the text. It is difficult to do any of these without leaving a trail but it is possible. You do not want to change anything; you just want to automate saving an attachment so this might be allowed by your tech people and Outlook.
Before attempting the more complicated parts of your requirement, let us check your requirement is possible. I do not know how much you know about Excel VBA. If I ask you to do something you do not understand, come back with questions.
Create a macro-enabled workbook somewhere convenient. The name of the workbook does not matter.
Open the workbook and then the VBA Editor.
Click [Tools] and then [References]. You will get a drop-down menu of all the available libraries. Scroll down until you find “Microsoft Outlook nn.0 Object Library”. “nn” identifies the version of Outlook in use which I understand will be “14” for you. Click the box to the left and a tick will appear. Click [OK]. This will give you access to Outlook from Excel.
In the Project Explorer, you will see something like:
- VBAProject (YourNameForWorkbook.xlsm)
- Microsoft Excel Objects
Sheet1 (Sheet1)
ThisWorkbook
If either of the minuses is a plus, click that plus.
Click [ThisWorkbook]. An empty code area will appear on the right of the VBA Editor window. Copy the code below to this area.
Within the code you will find lines starting ‘###. These lines tell you about changes you must make or things you must check. Make the necessary changes and then save and close the workbook. Reopen the workbook. With good fortune, the macro will run automatically and the default worksheet will report what it has done. It will probably have found the wrong email and saved the wrong attachment. This does not matter. If you can save any attachment, you can save the attachment you want.
Option Explicit
Sub Workbook_Open()
'### Replace "C:\DataArea\SO\" with the name of a disc folder on your system
' Make sure your folder name ends with \.
Const DiscFldrDest As String = "C:\DataArea\SO\"
'### The name of the default worksheet depend on the local language. Replace
' "Sheet1" is this is not the default name for you.
Const WshtOutName As String = "Sheet1"
' ### The subject of the email. Correct if I have misunderstood your comment ' ###
Const Subject As String = "ISIN List: Financial Sanctions - ISIN screening" ' ###
Dim AppOut As Outlook.Application
Dim Found As Boolean
Dim InxA As Long
Dim InxI As Long
Dim OutFldrInbox As Outlook.Folder
Dim RowNext As Long
Dim WshtOut As Worksheet
Set AppOut = CreateObject("Outlook.Application")
With AppOut
With .Session
Set OutFldrInbox = .GetDefaultFolder(olFolderInbox)
End With
End With
Set WshtOut = Worksheets(WshtOutName)
RowNext = WshtOut.Cells(Rows.Count, "A").End(xlUp).Row + 1
'### Change if you prefer different date or time formats
WshtOut.Cells(RowNext, "A").Value = "Macro activated at " & _
Format(Now(), "h:mm") & " on " & _
Format(Now(), "d mmm yy")
RowNext = RowNext + 1
'### GetDefaultFolder is not much use on my system because I have two
' email addresses, each with their own Inbox, neither of which is
' the default Inbox. Probably you only have one work email address
' which is the default for you. To check, the following statement
' outputs the name of the default Inbox's mailbox. Tell me if it is
' not the mail box you want.
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Inbox accessed"
WshtOut.Cells(RowNext, "B").Value = OutFldrInbox.Parent.Name
RowNext = RowNext + 1
Found = False
With OutFldrInbox
For InxI = .Items.Count To 1 Step -1
With .Items(InxI)
If .Subject = Subject And .Attachments.Count > 0 Then '###
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved from email" '###
WshtOut.Cells(RowNext, "B").Value = "With subject"
WshtOut.Cells(RowNext, "C").Value = .Subject
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "B").Value = "Received"
'WshtOut.Cells(RowNext, "C").Value = .ReceivedTime
WshtOut.Cells(RowNext, "C").Value = Format(.ReceivedTime, "\a\t h:mm \o\n d mmm yy")
'WshtOut.Cells(RowNext, "C").NumberFormat = "at h:mm on d mmm yy"
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved" '###
For InxA = 1 To .Attachments.Count '###
If UCase(Right$(.Attachments(InxA), 4)) = ".ZIP" Then '###
WshtOut.Cells(RowNext, "B").Value = .Attachments(InxA).Filename '###
.Attachments(1).SaveAsFile DiscFldrDest & .Attachments(1).Filename '###
Found = True '###
Exit For '###
End If '###
Next '###
End If
End With
Next
With WshtOut
If Not Found Then
.Cells(RowNext, "B").Value = "No email with correct subject and a ZIP attachment found"
RowNext = RowNext + 1
End If
.Columns.AutoFit
.Cells(RowNext, "A").Select
End With
End With
End Sub

Related

SendKeys not sending range to fillable pdf

I am working on some VBA to export data from Excel to a fillable pdf in Adobe Acrobat. I'm following a tutorial from YouTube that accomplishes exactly what I need, just different variable names and ranges obviously. I have the code able to successfully open the pdf template and navigate to the first field, but it isn't entering the text from the specified range. According to what I found it should basically be "tab to get to first field, then type the client name in that field" but it won't type anything. The clients are grouped by households (HHName). Here is the code I have so far
Sub CreatePDFForms()
Dim PDFTemplateFile, NewPDFName, SavePDFFolder, HHName As String
Dim DateRun As Date
Dim HHRow, LastRow As Long
With Sheet1
LastRow = .Range("A999").End(xlUp).Row 'Last Row
PDFTemplateFile = .Range("Z4").Value 'Template File Name
SavePDFFolder = .Range("Z7").Value 'Save PDF Folder
ThisWorkbook.FollowHyperlink PDFTemplateFile
Application.Wait Now + 0.00005
For HHRow = 2 To 2
HHName = .Range("A" & HHRow).Value 'HH Name
DateRun = .Range("B" & HHRow).Value 'Date Run
Application.SendKeys "{Tab}", True
Application.SendKeys HHName, True
Application.Wait Now + 0.00001
Next HHRow
Application.SendKeys "{numlock}%s", True
End With
End Sub
I've tried renaming variables, deleting and retyping. I'm very new to VBA and coding in general so my troubleshooting skills are not that great. Thank you for the help

Edit Outlook locally saved .msg body by replacing text in VBA

Good afternoon,
I have an Outlook .msg email saved at a local folder in my computer.
Is there any way I can replace the word "AAAA" in the body with any word I want in VBA?
Is there any way I can change the To: field?
The goal is to run an Excel table and create copies of a template message, replace the To: field and some words of the template with the info in the Excel table and save it. We will manually send latter.
I only need the .msg file modifying code (To: field and body replaces). The loop is already coded.
Thank you so much,
The Outlook object model doesn't provide anything to edit MSG files out of the box. But you can automate Outlook to create an item, edit it and then save it back as a template.
Use the Application.CreateItemFromTemplate method which creates a new Microsoft Outlook item from an Outlook template (.oft) and returns the new item. So, you can create a new item based on the template saved on the disk and then replace everything you need there. Then you could save it back as a template or send the item out. Read more about that in the How To: Create a new Outlook message based on a template article.
You can use Application.Session.OpenSharedItem to open an MSG file, modify the returned MailItem object (Subject / HTMLBody / Recipients), then call MAilItem.Save to update the MSG file.
If anyone needs, here it is the code I used. Do not focus on the for loops, but in the way the msg is loaded, edited and saved.
In this example some words in the msg file are replaced for the values in an excel table, as well as the TO: (email receiver). e.g. word AA in a msg file is changed with the value of the C7 cell.
The aim is to create a msg as a template with some key words (AA, BB, CC, etc), copy that template, replace those words with the ones in the excel table and save the new msg file.
Sub Recorrer()
Dim x As Integer
Dim fsObject As Object
Dim outApp As Object 'Outlook.Application
Dim outEmail As Object 'Outlook.MailItem
Dim outRecipient As Object 'Outlook.Recipient
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
Set fsObject = CreateObject("Scripting.FileSystemObject")
' Set numcols = number of cols to be replaced.
NumCols = Range("C1", Range("C1").End(xlToRight)).Cells.Count
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
fsObject.CopyFile ThisWorkbook.Path & "\" & Range("B" & x + 1) & ".msg", ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg"
Set outEmail = outApp.Session.OpenSharedItem(ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg")
outEmail.Recipients.Add Range("A" & x + 1)
For Z = 1 To NumCols
'MsgBox Cells(x + 1, Z + 2)
outEmail.HTMLBody = Replace(outEmail.HTMLBody, Cells(1, Z + 2), Cells(x + 1, Z + 2))
Next
outEmail.Save
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub

Find command - How to match names on multiple tabs and input data?

I am working on a spreadsheet that has to be completed quarterly so am looking to automate a lot of the process. I have a master tab - "#" and 16 Team tabs. On the # is a table which includes all 16 team names, I would like this table to update depending on what Teams have signed off.
Quick runthrough:
Spreadsheet is emailed out to multiple teams, each log in and review Products. After all products have been reviewed, they press the "Sign Off" button. This button does 3 things;
Inputs username and date to right of button
Sends email to spreadsheet owner
Updates table on "#" tab.
Number 3 is where I am having the issue. I have tried find, if, functions - lots of different options but just can't get it to work. Functions didn't work as the spreadsheet is reset every quarter so the cell values are cleared, so it needs to be VBA.
Some previous options I tried:
Sub If_Team 1()
'Set variables
Set sht1 = Sheets("#")
Set sht2 = Sheets("Team 1")
'Team1
If sht2.Range("M2:N2") <> "" Then
sht1.Range("C4:D4") = sht2.Range("M2:N2")
sht1.Range("B4") = "P"
Else
sht1.Range("C4:D4") = ""
sht1.Range("B4") = "O"
End If
Unfortunately this worked until I put in more If functions, where it then pasted the data in the whole table rather than just Team 1. The below also worked, until again adding more values where it pasted the data in every field where the criteria was met (which was them all).
If pfID = "Team 1" Then GoTo 1 Else
If pfID = "Team 2" Then GoTo 2 Else
1 sht2.Cells(3, 2).Value = "P"
sht2.Cells(3, 3).Value = Date
sht2.Cells(3, 4).Value = Environ("username")
On each team tab is the team name, so lets say "Team 1". Team 1 is found in Cell "F1" on the Active Team Sheet. On the # tab in the table, Team 1 is Cell "A3".
What I would like to happen is ActiveSheet.Range("F1") to find the same name on the # (sht2) tab, and then do the following if the names match (so as we know Team 1 on the # tab is "A3"):
sht2.Range("A4").Value = "P"
sht2.Cells("A5").Value = Date
sht2.Cells("A6").Value = Environ("username")
This way the spreadsheet owner will only need to review the # tab to see who has signed off, rather than go through each tab. However I don't want it to point to an invdividual cell like above as I would like it to find and match the names.
Here is the full code so far:
Sub Button2_Click() 'SIGN OFF BUTTON
Dim cellAddr As String
Dim aCol As Long
' Declare variables
Dim c As Integer ' Column
Dim emBody As String ' Body text of email
Dim emCnt As Integer ' Count of email addressees
Dim emTitl As String ' Subject line of email
Dim emTxt As String ' List of email addressees
Dim myOutlook As Object ' MS Outlook application
Dim mySendmail As Object ' The email to be sent
Dim pfID As String ' Platform ID
Dim r As Integer ' Row
'Set variables
Set sht1 = ActiveSheet
Set sht2 = Sheets("#")
'Cell Address
cellAddr = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address
'Column Number
aCol = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column
'Input Date and Username
If aCol <> 1 Then _
sht1.Range(cellAddr).Offset(, 2).Value = Date
sht1.Range(cellAddr).Offset(, 1).Value = Environ("username")
' Obtain Platform details
pfID = ActiveSheet.Range("F1").Value
'Version ID
vID = sht2.Range("D1").Value
**'Input Sign Off on "#" Tab**
' Email subject line
emTitl = pfID & " - Out of Support Software Review " & vID & " Completed"
' Email body text
emBody = "<BODY style=font-size:12pt;font-family:Calibri>" & "Hi," & "<br>" & "<br>" & "Out of Support Software Review " & "<b>" & vID & "</b>" & " Completed for " & "<b>" & pfID & "</b>" & "."
Set myOutlook = CreateObject("Outlook.Application")
Set mySendmail = myOutlook.CreateItem(olMailItem)
With mySendmail
.to = ""
.Subject = emTitl
.HTMLBody = emBody
.Display
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'
End Sub
Any help is appreciated, any questions let me know! Sorry if this is slightly confusing.

VBA sheet to new workbook if specific cell populated

I have a macro built that copies a single sheet from my workbook to a new workbook and saves the new workbook in a specific location. I have built out my source file and have 3 sheets (of 6) which possibly need to be added to the new saved file.
I would like save sheet 4 (the original) sheet to a new file, then look at sheet 2 and if c2 has a specific result, move the sheet to the new file, then look at sheet 17 and if c2 has a specific result, move the sheet to the new file.
And save.
My struggle is on referencing a specific cell to call the action.
My struggle is on referencing a specific cell to call the action.
you can use a button and assigned your created macro on it just to trigger the action.
#urdearboy
Sub Cleanup()
'
' Cleanup Macro
'
' Keyboard Shortcut: Ctrl+e
'
'This is some clean up stuff on a specific tab, somewhere after this I need to add the check of a specific cell and pull the full sheet.
Application.ScreenUpdating = False
'Get path for desktop of user PC
Path = Environ("USERPROFILE") & "\Desktop"
Sheets("Uploader").Cells.Copy
'Create new workbook and past copied data in new workbook & save to desktop
Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.ActiveSheet.Paste
ActiveWorkbook.ActiveSheet.Name = "Upload"
x = Weekday(Date, vbSaturday)
Select Case x
Case 1
x = 2
Case 2
x = 3
Case Else
x = 1
End Select
ActiveWorkbook.SaveAs Filename:=Path & "\" & "Upload " & Format(CStr(Date - x), "mmddyyyy") & ".xlsx"
' start email
Dim Outlook As Object, EMail As Object
Set Outlook = CreateObject("Outlook.Application")
Set EMail = Outlook.CreateItem(0)
With EMail
.To = "1"
.CC = "2"
.BCC = ""
.Subject = "File is Ready"
.Body = "Isn't Automation Amazing!?"
.Attachments.Add ActiveWorkbook.FullName ' To add active Workbook as attachment
'.Attachments.Add "" ' To add other files just use path, Excel files, pictures, documents pdf's ect.
.Display 'or use .Send to skip preview
End With
Set EMail = Nothing
Set Outlook = Nothing
'end email
ActiveWorkbook.Close savechanges:=True
Application.ScreenUpdating = True
ActiveWorkbook.Close savechanges:=False
End Sub

Update excel sheet based on outlook mail [closed]

It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 11 years ago.
My objective is to update an excel sheet, whenever I am getting mails with a particular subject (I set up a rule for moving relevant mails to a folder).
I saw a similar post in this site, but the code given is not complete. Being not a 'pro' or 'techie' its very difficult to wrtie codes.
Mail contains:
File Name:
Owner Name:
Last update date:
File locaion(this will be share drive path):
I will get this mail daily and need to update this info in an excel sheet. (which i will keep open till the month end)
Please help me. Thanks in advance
Introduction
In the first version of this answer, I referred you to another question which I now know you will not be able to read.
All the code you need is here but this is not written as an immediate solution. This is a tutorial which introduces you to the Outlook object model, getting data out of the outlook database and into an Excel workbook. Don't worry that you are not "a 'pro' or 'techie'"; once we were all newbies. Work through the sections. Don't worry if you don't understand it all. Just pick out the bits you need now. When you want to enhance your solution, come back to this tutorial and the code which you will have copied to your disc.
In the following sections, AnswerA() and AnswerB() are intended to help you understand the folder structure. AnswerC1() is also a short term training aid. However, AnswerC2() and AnswerC3() are subroutines that you may need permenently. If you do keep them, I suggest you rename them; for example: FindFolder() and FindFolderSub().
AnswerD() is also a training aid but one you should retain. This shows you how to access a few mail item properties but I you may need access to more mail item properties than I have shown. Within the VB Editor, click F2 to display the Object Explorer. Scroll down the list of classes to MailItem. You will be shown a list of over 100 methods and properties. Some are obvious but you will have to use VB Help to discover the purpose of many. Expand AnswerD() to use methods or display properties you think might be useful.
AnswerE() is a development aid but also provides the structure for your macro. Currently it outputs to disc the text and html bodies of the mail items within a folder. You do not want to do this at the moment but you might. I archive all my emails to Excel. I create one row per email with columns for sender, recipients, subject, dates, etc. I save the text body, html body and any attachments to disc and create hyperlinks to them. I have emails going back years from multiple Outlook installations.
AnswerF1() shows you how to create a new Excel workbook and AnswerF2() shows you how to open an existing Excel workbook. I assume AnswerF2() is what you need.
There is a lot here but if you work through it steadily you will come to understand the Outlook object model and how to achieve your objective.
Health warning
Everything in this answer was discovered by experimentation. I started with VB Help, used F2 to access the object model and experimented until I found what worked. I did buy a highly recommended reference book but it contained nothing important I had not discovered and omitted much that I had discovered.
I suspect that a key feature of the knowledge I have gained is that it is based on many different installations. Some of the problems encountered may have been the result of installation mistakes which would explain why reference book authors did not know of them.
The code below has been tested with Excel 2003 and Outlook Exchange 2003 and 2007.
Getting started if you are unfamiliar with Outlook VBA
Open "Outlook" or "Outlook Exchange". These macros do not work with "Outlook Express".
From the toolbar, select Tools, Macro, Security. Change the security level to "Medium" if it is not already at that level. This means that macros can be run but only with your explicit approval.
To start the Outlook VB Editor either:
1) From the toolbar, select Tools, Macro, Macros
or click Alt+F11
2) Select Enable macros.
From the tool bar, select Insert, Module.
You can see one, two or three windows. Down the left should be the Project Explorer. You do not need it today but, if it is missing, click Ctrl+R to display it. To the right, at the top, is the area into which you will place the code. At the bottom you should see the Immediate Window. If the Immediate Window is missing, click Ctrl+G to display it. The macros below all use the Immediate Window for output so you must be able to see it.
The cursor will be in the code area.
Enter: Option Explicit.
This instructs the VB Editor to check that all variables are defined. The code below have been tested but this avoids one type of error in any code you may enter.
One by one, copy and paste the macros below into the code area.
Macros AnswerC(), AnswerD(), Answer(E), AnswerF1() and AnswerF2() will require some modification before running. Instructions within the macro.
To run a macro, place the cursor within it and press F5.
Accessing the top two folder levels
The top level of folders are of type Folders. All subfolders are of type MAPIFolder. I have never tried accessing the top level other than as a means of getting to the subfolders.
AnswerA() gets access to the Outlook Exchange database and outputs the names of the top level folders to the Immediate Window.
Sub AnswerA()
Dim InxIFLCrnt As Integer
Dim TopLvlFolderList As Folders
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxIFLCrnt = 1 To TopLvlFolderList.Count
Debug.Print TopLvlFolderList(InxIFLCrnt).Name
Next
End Sub
AnswerB() outputs the names of the top level folders and their immediate children.
Sub AnswerB()
Dim InxIFLCrnt As Integer
Dim InxISLCrnt As Integer
Dim SndLvlFolderList As MAPIFolder
Dim TopLvlFolderList As Folders
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxIFLCrnt = 1 To TopLvlFolderList.Count
Debug.Print TopLvlFolderList(InxIFLCrnt).Name
Set SndLvlFolderList = TopLvlFolderList.Item(InxIFLCrnt)
For InxISLCrnt = 1 To SndLvlFolderList.Folders.Count
Debug.Print " " & SndLvlFolderList.Folders(InxISLCrnt).Name
Next
Next
End Sub
The problem with AnswerB() is that the children can have children can have children to any depth. You need to be able to find a particular folder whatever the depth.
Find named folder
If you want to search a default folder such as "Inbox" or "Sent Items" you will not need this code. If you copy the messages containing tables to a different folder you will need this code. Even if you decide you do not need this code now, I suggest you keep it in case you need it in the future.
The code below uses two sub-routines. The caller assembles a folder name such as "Personal Folders|MailBox|Inbox". The sub-routines work down the hierarchy and return the required folder as an object if it is found.
Note: the special case of locating a default folder such as "Inbox" or "Sent Items" is discussed later.
Sub AnswerC1()
' This routine wants a folder. It does nothing but display its name.
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
' The names of each folder down to the one required separated
' by a character not used in folder names.
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Else
Debug.Print FolderNameTgt & " found: " & FolderTgt.Name
End If
End Sub
Sub AnswerC2(ByRef FolderTgt As MAPIFolder, NameTgt As String, NameSep As String)
' This routine initialises the search and finds the top level folder
Dim InxFolderCrnt As Integer
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Integer
Dim TopLvlFolderList As Folders
Set FolderTgt = Nothing ' Target folder not found
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
' I need at least a level 2 name
Exit Sub
End If
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To TopLvlFolderList.Count
If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
' Have found current name. Call AnswerC3() to look for its children
Call AnswerC3(TopLvlFolderList.Item(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
Exit For
End If
Next
End Sub
Sub AnswerC3(FolderCrnt As MAPIFolder, ByRef FolderTgt As MAPIFolder, _
NameTgt As String, NameSep As String)
' This routine finds all folders below the top level
Dim InxFolderCrnt As Integer
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Integer
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
NameCrnt = NameTgt
NameChild = ""
Else
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
End If
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
' Have found current name.
If NameChild = "" Then
' Have found target folder
Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
Else
'Recurse to look for children
Call AnswerC3(FolderCrnt.Folders(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
End If
Exit For
End If
Next
End Sub
Examining a target folder
AnswerC2() and AnswerC3() provides the code to find a target folder. Folders contain items: mail items, meeting requests, contacts, calendar entries and more. Only mail items are examined by this code. Accessing meeting requests is essentially the same but they have different properties.
AnswerD() outputs a selection of a mail item's properties.
Once you have tried AnswerD() on a selection of folders, press F2 or, from the tool bar, select View, Object Browser. Scroll down the list of items until you reach MailItem. The members' area will display all its properties and methods of which there are in excess of 100. Some are pretty obvious; most you will have to look up in VB Help. Amend this routine to explore more properties and methods and, perhaps, other types of item.
Warning. This code is designed to look through a named folder for mail items. You may encounter problems if you amend the code to explore the entire folder hierarchy. It could have been my mistake or it could have been faults in the installation but I have found that my code crashes if I attempt to access certain folders such as "RSS Feeds". I have never been interested enough to explore these crashes and have simply amended my tree search to ignore branches with selected names.
When you run this macro, you will receive a warning: "A program is trying to access e-mail addresses you have stored in Outlook. Do you want to allow this?" Tick "Allow access for", select an interval, and click Yes.
Sub AnswerD()
Dim FolderItem As Object
Dim FolderItemClass As Integer
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
Dim InxAttach As Integer
Dim InxItemCrnt As Integer
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Else
' Display mail items, if any, within folder
Debug.Print "Mail items within " & FolderNameTgt
For InxItemCrnt = 1 To FolderTgt.Items.Count
Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)
With FolderItem
' This code seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = .Class
On Error GoTo 0
If FolderItemClass = olMail Then
' Display Received date, Attachment count and Subject
Debug.Print " Mail item: " & InxItemCrnt
Debug.Print " Received=" & Format(.ReceivedTime, _
"ddmmmyy hh:mm:ss") & " " & _
.Attachments.Count & _
" attachments Subject = " & .Subject
Debug.Print " Sender: " & .SenderName
With .Attachments
' If the are attachments display their types and names
If .Count > 0 Then
Debug.Print " Attachments:"
For InxAttach = 1 To .Count
With .Item(InxAttach)
Debug.Print " Type=";
Select Case .Type
Case olByReference
Debug.Print "ByRef";
Case olByValue
Debug.Print "ByVal";
Case olEmbeddeditem
Debug.Print "Embed";
Case olOLE
Debug.Print " OLE";
End Select
Debug.Print " DisplayName=" & .DisplayName
End With
Next
End If
End With
End If
End With
Next InxItemCrnt
End If
End Sub
Saving bodies to disc
AnswerE() finds a folder of your choice and saves a copy of the text and html bodies of every mail item within it. I suggest you copy a select of messages containing table to a new folder and run AnswerE(). This is not directly relevant to your questions but I believe it will aid understanding.
When you run this macro, you will receive a warning: "A program is trying to access e-mail addresses you have stored in Outlook. Do you want to allow this?" Tick "Allow access for", select an interval, and click Yes.
Sub AnswerE()
' Output any Text or HTML bodies found within specified folder
Dim FolderItem As Object
Dim FolderItemClass As Integer
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
Dim FileSystem As Object
Dim FileSystemFile As Object
Dim HTMLBody As String
Dim InxAttach As Integer
Dim InxItemCrnt As Integer
Dim PathName As String
Dim TextBody As String
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' The folder you pick must have at least one mail item with an
' HTML body for this macro to do anything.
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Exit Sub
End If
' ####################################################################
' The following is an alternative method of accessing a default folder
' such as Inbox. This statement would replace the code above.
' Set FolderTgt = CreateObject("Outlook.Application"). _
' GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' ####################################################################
' Extract bodies if found
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' ##############################################################
PathName = "C:\Email\"
For InxItemCrnt = 1 To FolderTgt.Items.Count
Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)
With FolderItem
' This code seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = .Class
On Error GoTo 0
If FolderItemClass = olMail Then
HTMLBody = Trim(.HTMLBody)
If HTMLBody <> "" Then
' Save HTML body to disc. The file name is of the form
' BodyNNN.html where NNN is a a sequence number.
' First True in CreateTextFile => overwrite existing file.
' Second True => Unicode format
Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
"Body" & Right("00" & InxItemCrnt, 3) & _
".html", True, True)
FileSystemFile.Write HTMLBody
FileSystemFile.Close
End If
TextBody = Trim(.Body)
If HTMLBody <> "" Then
' Save text body to disc. The file name is of the form
' BodyNNN.txt where NNN is a a sequence number.
Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
"Body" & Right("00" & InxItemCrnt, 3) & _
".txt", True, True)
FileSystemFile.Write TextBody
FileSystemFile.Close
End If
End If
End With
Next InxItemCrnt
End Sub
Creating or updating an Excel workbook
You do not say if you will create a new Excel workbook or update an existing one. AnswerF1() creates a workbook. AnswerF2() opens an existing workbook.
Before trying either of these macros you must:
From within the Outlook VBA Editor, select Tools from the toolbar.
Select References.
Scroll down to Microsoft Excel 11.0 Object Library and tick the box against it.
.
Sub AnswerF1()
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim PathName As String
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' Replace "MyWorkbook.xls" with the your name for the workbook
' ##############################################################
PathName = "C:\Email\"
FileName = "MyWorkbook.xls"
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
.Visible = True ' This slows your macro but helps during debugging
Set ExcelWkBk = xlApp.Workbooks.Add
With ExcelWkBk
' Add Excel VBA code to update workbook here
.SaveAs FileName:=PathName & FileName
.Close
End With
.Quit
End With
End Sub
Sub AnswerF2()
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim PathName As String
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' Replace "MyWorkbook.xls" with the your name for the workbook
' ##############################################################
PathName = "C:\Email\"
FileName = "MyWorkbook.xls"
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
.Visible = True ' This slows your macro but helps during debugging
Set ExcelWkBk = xlApp.Workbooks.Open(PathName & FileName)
With ExcelWkBk
' Add Excel VBA code to update workbook here
.Save
.Close
End With
End With
End Sub
Writing to the Excel workbook
This code finds the next free row in you workbook and writes to it. I explain why constants are useful and warn you about keeping your Outlook and Excel code apart.
' Constants allow you alter the sequence of columns in your workbook without
' having to change your code. Replace the 1, 2 and 3 in these statements
' and the job is done.
' !!! Constants must be above any subroutines and functions.
Public Const ColFrom As Integer = 1
Public Const ColSubject As Integer = 2
Public Const ColSentDate As Integer = 3
Sub AnswerG()
Dim RowNext As Integer
' This code goes at the top of your macro
With Sheets("Sheet1") ' Replace with the name of your worksheet
' This finds the bottom row with a value in column A. It then adds 1 to get
' the number of the first unused row.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
' You will have to separate your Outlook and Excel code.
' With Outlook
' Var1 = .Body
' Var2 = .ReceivedTime
' Var3 = .SenderName
' End With
' With Excel
' .Cell(R, C).Value = Var1
' End With
With Sheets("Sheet1") ' Replace with the name of your worksheet
.Cells(RowNext, ColFrom).Value = "John Smith"
.Cells(RowNext, ColSubject).Value = "Our meeting"
With .Cells(RowNext, ColSentDate)
.Value = Now()
' This format means the time is stored and I can access it but it
'is not displayed. Change to "mm/dd/yy" or whatever you like.
.NumberFormat = "d mmm yy"
End With
RowNext = RowNext + 1 ' Ready for next loop
End With
End Sub
Summary
I hope I have provided an appropriate level of detail. Please respond with a comment either way.
Don't leap to the final macros. If anything goes wrong you will not understand the cause. Take the time to play with each of the earlier answers. Amend them to do something slightly different.
Best of luck. You will be amazed how quickly you will become comfortable with Outlook and VBA.

Resources