VBA Excel -- Workbook.ChangeLink is not responding - excel

For a side-gig I need to replace a the prefix of all data links in a TB worth of excel files from an old drive to a new drive (ex: from \\foo\rest_of_path\ to \\bar\rest_of_path\).
Before running it on the bulk, I'm running it on 25 or so files (one of the many subfolders)
My Macro currently creates a list of all subdirectories in the rootdirectory given to the macro and runs the code below on all found .xlsx files.
I get no compilation errors and no runtime errors.
However, the macro keeps hanging and not responding on the very first data link that it tries to change.
Any ideas why ?
Code:
Sub ChangeFileLinks(ByVal documentPath As String)
' Define variables
Dim excelFile As Workbook
Dim fileLinks As Variant
Dim item As Variant
Dim sourceName As String
Dim newSourceFile As String
' Remove variable value in case the file was not properly closed
Set excelFile = Nothing
' Open Workbook with password that is definitely not good to redirect to Error handler
' if the workbook is password protected.
Set excelFile = Application.Workbooks.Open( _
fileName:=document, _
IgnoreReadOnlyREcommended:=True, _
UpdateLinks:=False, _
Password:="MyFakePassword")
On Error GoTo 0
' If the file has been opened create Array of data sources
If Not excelFile Is Nothing Then
excelFile.Activate ' Activating the file seems to improve performance
fileLinks = ActiveWorkbook.LinkSources
' If there are data sources in the file iterate through the array
If Not IsEmpty(fileLinks) Then
For Each item In fileLinks
sourceName = item
' If current data source starts with the oldPathRoot - modify the PathRoot
If StartsWith.StartsWith(sourceName, Globals.OLD_PATH_ROOT) = True Then
' append the newPathRoot to the the file name
newSourceFile = Replace(sourceName, Globals.OLD_PATH_ROOT, Globals.NEW_PATH_ROOT)
' change data source
ActiveWorkbook.ChangeLink item, newSourceFile
Globals.SOURCE_LINKS_MODIFIED = Globals.SOURCE_LINKS_MODIFIED + 1
Else
Globals.SOURCE_LINKS_UNTOUCHED = Globals.SOURCE_LINKS_UNTOUCHED + 1
End If
Next item
End If
' Close Workbook
excelFile.Close SaveChanges:=True
Else
Debug.Print document
Debug.Print "--> PASSWORD PROTECTED !"
End If
End Sub

Related

Excel crashing randomly when running macro

I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!

Visual basic application written for Jira and Excel file error message

we have an Importer for Jira that imports projects and configures them. I did not write the code myself and there is absolutely no technical documentation regarding it.
A few days ago its started showing an error message
I checked the directory and the file permissions and everything but it is still not working. The other thing is that it is not working solely for one person. Does anyone have any ideas?
Public Sub getValuesFromFile()
' if the property excelDefaultValues has already values in it break this sub
If excelDefaultValues.Count > 0 Then
Exit Sub
End If
' Definitions
Dim ExcelFolder As String
Dim selectedfile As String
Dim excel As Application
Dim workbook As Workbook
Dim sheet As Worksheet
Dim column As Integer = 0
Dim row As Integer = 0
' Define the location and name of the default values file
ExcelFolder = "R:\PM\01_Team\01_Allgemein\07_Jira_Importer\Masterfile"
selectedfile = ExcelFolder & "\" & "DefaultValues.xlsx"
' try to open excel and the file
Try
excel = New Application
excel.DisplayAlerts = False
excel.Workbooks.Open(selectedfile)
workbook = excel.ActiveWorkbook
sheet = workbook.Worksheets(1)
' fails if the file does not exist, open a message box.
Catch
MsgBox("file template not found! please make sure that the file is in this directory:" & vbCrLf & selectedfile, MsgBoxStyle.OkOnly, "warning!")
Exit Sub
End Try

VBA Excel - Faster Execute - Copy Sheet (with charts/objects) from closed file

I am hoping to find a way to help this code run faster; so this is the path im following to try and achieve this -
current time - 23 seconds, most of it opening & closing files.
So I am attempting to pull data from files without opening them.
I've seen Microsoft.ACE.OLEDB.12.0 but I have not idea how to use it to get the entire sheet, warts and all.
I've seen a lot of solutions that pull data from cells and gets sheet names -
I want my entire sheet, all objects on that sheet, its headers, footers, everything.
This is the macro I'd like to apply it to:
Sub DirPDF_Long_Sections(LongFolderPath As String)
' ####################################################################################
' # INTRO
'-------------------------------------------------------------------------------------
' Purpose
' This procedure assists the user to put all long sections from a folder into one
' PDF file. This makes it convieniet to share the long sections & print them.
'
' THIS PROCEDURE USES DIR instead of FSO
'
' ####################################################################################
' # DECLAIRATIONS
'-------------------------------------------------------------------------------------
' OBJECTS
Dim LongFolder As String
Dim LongFile As String
Dim OpenLong As Workbook
Dim ExportWB As Workbook
'Dim FileSystemObj As New FileSystemObject
'-------------------------------------------------------------------------------------
' VARIABLES
Dim count As Long
Dim DefaultPrinter As String
Dim DefaultSheets As Variant
Dim FirstSpace As Long
Dim LastSpace As Long
Dim start_time, end_time
' ####################################################################################
' # PROCEDURE CODE
'-------------------------------------------------------------------------------------
' optimise speed
start_time = Now()
Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------
' Print the Files in the Folder:
DefaultSheets = Application.SheetsInNewWorkbook '// save default setting
Application.SheetsInNewWorkbook = 1 '// create a one worksheet workbook
Set ExportWB = Workbooks.Add
Application.SheetsInNewWorkbook = DefaultSheets '// re-set application to default
LongFile = Dir(LongFolderPath & "\*PipeLongSec*", vbNormal)
While LongFile <> vbNullString '// loop through all the files in the folder
FirstSpace = InStr(1, LongFile, " ") '// record position of first space character
LastSpace = InStr(FirstSpace + 1, LongFile, " ") '// record position of last space character
Set OpenLong = Workbooks.Open(LongFile) '// open the file
OpenLong.Sheets("Long Sections").Copy After:=ExportWB.Sheets(ExportWB.Sheets.count)
'// copy sheet into export workbook
ExportWB.Sheets(ExportWB.Sheets.count).Name = Mid(LongFile, FirstSpace + 1, LastSpace - FirstSpace - 1)
'// rename sheet we just moved to its pipe number
OpenLong.Close '// close the file
LongFile = Dir() '// get next file
Wend
'-------------------------------------------------------------------------------------
' Delete the other worksheet in the temporary workbook
Application.DisplayAlerts = False
ExportWB.Sheets("Sheet1").Delete
Application.DisplayAlerts = True
'-------------------------------------------------------------------------------------
' Send Workbook to PDF - in save location
ExportWB.ExportAsFixedFormat xlTypePDF, LongFolderPath & "\" & "LongSectionCollection " & Replace(Date, "/", "-")
ExportWB.Close SaveChanges:=False
'#####################################################################################
'# END PROCEDURE
Application.ScreenUpdating = True
Set OpenLong = Nothing
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))
End Sub
Add Option Explicit before any code at the top
Convert DefaultSheets to CLngPtr(DefaultSheets)
Convert Long data types to CLngPtr(variable)
Convert to CDate(Start_Time)
Convert to CDate(End_Time)
No worries. They should be defined in the dim statement if they would remain the same data type. If this data type changes throughout the code then use as variant in the dim statement and use the conversion functions found in the object browser to convert the data types as needed.

Automate creation of charts in multiple excel files?

I just spent a significant amount of time creating identical graphs in several dozen excel files (all containing identically formatted data,) and believe there has to be a more efficient way of completing what I've just done.
To simplify things, consider 50 excel documents with data in the same format. Does there exist a method of automatically:
Creating a simple line graph
Adding axis labels, a chart label, removing horizontal grid lines
Including a trend line/R^2 value
Saving the new workbook to a certain location with "_graphed" appended to the filename
Would this be something that an Excel VBA could be used for?
For this sort of problem I would start by recording a macro of the steps you take manually into a personal macro workbook. You can then look at the code produced by Excel and you may find that you don't need to make too many changes for this to be useful as a generic procedure.
After testing, if you wanted to take the automation one step further you could write a little procedure to loop through all of the Excel files in a directory and call your chart procedure for each file when it is open. I can dig out come code I wrote doing something similar if it will help.
Update
Here is a thread where I have provided some code to loop through all of the files containing some given text (in this example ".pdf" but could just as easily be ".xls" to cover xlsx, xlsm etc).
Also this example prints out a list of the files it finds to a worksheet. This is a good start to test the results, but once this is okay you would need to replace the line:
Range(c).Offset(j, 0).Value = vFileList(i)
With some code to open that workbook and call your code to generate the chart. Let me know if you get stuck.
Further Update
I have reviewed the code referred to above and made a few improvements including an additional parameter for you to specify the name of a macro that you want to run against each of the workbooks opened (that meet the condition specified). The macro that you use in the call must exist in the workbook that you are calling all of the other workbooks from (e.g. if the chart macro is in your personal workbook then the code below should also be placed in your personal macro workbook):
Option Explicit
Sub FileLoop(pDirPath As String, _
Optional pPrintToSheet = False, _
Optional pStartCellAddr = "$A$1", _
Optional pCheckCondition = False, _
Optional pFileNameContains = "xxx", _
Optional pProcToRunOnWb)
On Error GoTo PrintFileList_err
' Local constants / variables
Const cProcName = "FileLoop"
Dim vFileList() As String ' array for file names
Dim i As Integer ' iterator for file name array
Dim j As Integer ' match counter
Dim c As String
' variables for optional param pProcToRunOnWb
Dim vFullPath As String
Dim vTmpPath As String
Dim wb As Workbook
vFullPath = Application.ThisWorkbook.FullName
vFileList = GetFileList(pDirPath)
c = pStartCellAddr
j = 0
For i = LBound(vFileList) To UBound(vFileList)
' if condition is met (i.e. filename cotains text or condition is not required...
If pCheckCondition And InStr(1, vFileList(i), pFileNameContains, vbTextCompare) > 0 _
Or Not pCheckCondition Then
' print name to sheet if required...
If pPrintToSheet Then
Range(c).Offset(j, 0).Value = vFileList(i)
j = j + 1 ' increment row offset
End If
' open wb to run macro if required...
If pProcToRunOnWb <> "" Then
Application.DisplayAlerts = False ' set alerts off so that macro can run in other wb
vTmpPath = pDirPath & "\" & vFileList(i)
Set wb = Workbooks.Open(Filename:=vTmpPath)
Workbooks(wb.Name).Activate
Application.Run "'" & vFullPath & "'!" & pProcToRunOnWb
wb.Close (True) ' save and close workbook
Application.DisplayAlerts = True ' set alerts back on
End If
End If
Debug.Print vFileList(i)
Next i
' clean up
Set wb = Nothing
PrintFileList_exit:
Exit Sub
PrintFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Sub
Function GetFileList(pDirPath As String) As Variant
On Error GoTo GetFileList_err
' Local constants / variables
Const cProcName = "GetFileList"
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim c As Double ' upper bound for file name array
Dim i As Double ' iterator for file name array
Dim vFileList() As String ' array for file names
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(pDirPath)
c = objFolder.Files.Count
i = 0
ReDim vFileList(1 To c) ' set bounds on file array now we know count
'Loop through the Files collection
For Each objFile In objFolder.Files
'Debug.Print objFile.Name
i = i + 1
vFileList(i) = objFile.Name
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
GetFileList = vFileList
GetFileList_exit:
Exit Function
GetFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Function
You can call this from another macro or from the immediate window (ctrl+G) with the parameters required e.g. to get all files containing '.xls', and run a macro named 'your_macro_name_here' the code would be:
call FileLoop("C:\Users\Prosserc\Dropbox\Docs\Stack_Overflow\Test", False, "", True, ".xls", "your_macro_name_here")
Obviously change the path in the first parameter to point to the directory containing the files that you want to run the macro against.
There is a library called Xlsxwriter for both python and perl which allows for the automation of chart generation. For some sample python code, see my post here.

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