Error 91 occurring during iterations randomly - vba

Interesting problem here. This line of code works through multiple iterations until it reaches a point where it throws an Run-time error 91 at me: "Object Variable or With block variable not set". This is occurring in a function designed to find a deal number. The entire program is an end of day email generation program that sends attachments to various different counter-parties. The error occurs on the ** line. For additional color, temp deal is not empty when execution is attempted. There doesn't appear to be any extraneous trailing or leading spaces either. Thanks in advance!
Function getPDFs(cFirm As Variant, iFirm As Variant, row_counter As Variant, reportsByFirm As Worksheet, trMaster As Worksheet, trSeparate As Variant, trName As Variant, reportDate As Variant) As String
dealCol = 1
Dim locationArray() As String
Dim DealArray() As String
cDes = "_vs._NY"
iDes = "_vs._IC"
filePath = "X:\Office\Confirm Drop File\"
dealNum = reportsByFirm.Cells(row_counter, dealCol)
FileType = ".pdf"
If InStr(1, dealNum, "-") > 0 Then
DealArray() = Split(dealNum, "-")
tempDeal = DealArray(LBound(DealArray))
Else
tempDeal = dealNum
End If
'Finds deal location in spread sheet for further detail to obtain file path
**trLocation = trMaster.Columns(2).Find(What:=tempDeal).Address
locationArray() = Split(trLocation, "$")
trRow = locationArray(UBound(locationArray))
'Formats client names for 20 characters and removes punctuation (".") in order to stay within convention of file naming
cFirmFormatted = Trim(Left(cFirm, 20))
iFirmFormatted = Trim(Left(iFirm, 20))
'Finds clearing method
clMethod = trMaster.Cells(trRow, 6).Value
Select Case clmethod
Case "Clport"
'Prevents naming convention issues with punctuations in the name
If InStr(1, cFirmFormatted, ".") > 0 Then
cFirmFormatted = Replace(cFirmFormatted, ".", "")
End If
getPDFs = filePath & cFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & cFirmFormatted & cDes & FileType
Case "ICE"
If InStr(1, iFirmFormatted, ".") > 0 Then
iFirmFormatted = Replace(iFirmFormatted, ".", "")
End If
getPDFs = filePath & iFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & iFirmFormatted & iDes & FileType
End Select
End Function

Your code assumes that trLocation is always found, if it isn't found then you will receive an error because you don't have a range to return the .Address property for.
Try testing the result first:
Dim testLocation As Excel.Range
Set testLocation = trMaster.Columns(2).Find(tempDeal)
If Not testLocation Is Nothing Then
trLocation = testLocation.Address
'// Rest of code here...
Else
MsgBox "Cannot find """ & tempDeal & """!"
Exit Function
End If

Related

Export VBA Procedures (Sub/Function) Separately

In the project I'm working on all of my code is in modules which each have a varying number of procedures. I'm trying to export VBA code procedures one by one into folders named after their respective module. I already have code to export whole modules but I like the challenge of this one and it's more fun to track changes this way!
The export code below works for every module except itself because of the way that I check for the start and end of a function/sub. It's a circular problem, really, because it thinks the phrases from the checks are the start of a new sub!
If anyone has a more creative solution for marking the beginning and end of a function or sub that will work here or has a way to tweak mine I would really appreciate it!
Sub ExportVBCode2()
'NOTE: Globals will be included with the first procedure exported, not necessarily the procedure(s) they're used in
Dim directory As String
directory = "C:\Users\Public\Documents\VBA Exports" & "\"
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
' If fso.FolderExists(Left(directory, Len(directory) - 1)) Then
' fso.deletefolder Left(directory, Len(directory) - 1)
' End If
If Len(Dir(directory, vbDirectory)) = 0 Then
MkDir directory
End If
Dim VBComponent As Object
Dim Fileout As Object
Dim i As Long
Dim currLine As String
Dim currLineLower As String
Dim functionString As String
Dim functionName As String
Dim funcOrSub As String
For Each VBComponent In ThisWorkbook.VBProject.VBComponents
If VBComponent.Type = 1 Then 'Component Type 1 is "Module"
If Len(Dir(directory & "\" & VBComponent.Name & "\", vbDirectory)) = 0 Then
MkDir directory & VBComponent.Name
End If
For i = 1 To VBComponent.CodeModule.CountOfLines
currLine = RTrim$(VBComponent.CodeModule.Lines(i, 1))
currLineLower = LCase$(currLine)
'TODO need a more clever solution for the if check below, because it catches ITSELF. Maybe regex ?
If (InStr(currLineLower, "function ") > 0 Or InStr(currLineLower, "sub ") > 0) And InStr(currLineLower, "(") > 0 And InStr(currLineLower, ")") > 0 Then
'this is the start of a new function
Select Case InStr(currLineLower, "function ")
Case Is > 0
funcOrSub = "function"
Case Else
funcOrSub = "sub"
End Select
functionName = Mid(currLine, InStr(currLineLower, funcOrSub) + Len(funcOrSub & " "), InStr(currLine, "(") - InStr(currLineLower, funcOrSub) - Len(funcOrSub & " "))
End If
functionString = functionString & currLine & vbCrLf
If Trim$(currLineLower) = "end sub" Or Trim$(currLineLower) = "end function" Then
'this is the end of a function
Set Fileout = fso.CreateTextFile(directory & "\" & VBComponent.Name & "\" & functionName & ".txt", True, True)
Fileout.Write functionString
Fileout.Close
functionString = ""
functionName = ""
End If
Next i
End If
Next VBComponent
End Sub
I think the key to the problem is to check if the line contains the term "function" contains also a left parenthesis after the function name. For example: Private Function foo(. So you expect to count 1 space character and at least 1 left parenthesis before the next space or comma character.

Passing values from Excel to Word with VBA

For Each cell In rng
workSheetName = Format(SaturdayIsComing(), "mm-dd-yyyy") & " " & cell.Value
If WorksheetExists(workSheetName) Then
Dim localRange, localCell As Range
Set localRange = Worksheets(workSheetName).Range("D8:D19")
Dim contents As Variant
contents = ""
Dim firstLine As Boolean
firstLine = True
For Each localCell In localRange
If Len(localCell.Value) > 0 Then
If firstLine Then
contents = contents & localCell.Value & Chr(11)
Else
contents = contents & Chr(9) & Chr(9) & Chr(9) & localCell.Value & Chr(11)
End If
Else
contents = fixString(contents)
End If
If Len(contents) > 0 Then
firstLine = False
End If
Next localCell
For Each cc In wDoc.SelectContentControlsByTag(cell.Value & "Notes")
If Len(contents) > 0 Then
cc.Range.Text = fixString(contents)
Else
cc.Range.Text = "No Issues Found"
End If
Next
Else
errorCodesString = errorCodesString & cell.Value & ":"
End If
Next cell
Output to Word
Forgot to terminate the meeting
This is a test message\'s
If my cell contains a ' then I get an error saying
One of the values passwed to this method or property is incorrect
I know a ' is a comment in VBA. How do I go around this while preserving the notes that someone had added to the Excel cell?
You need to write a piece of code to search for quotes, either the single (') or double (") variety and either add a backslash before them OR double the character so '' in place of ' and "" in place of " and run this on contents before assigning it to cc.Range.Text.
This routine can also check for other instances of incorrect strings and fix them.
Something like this would do:
Function fixString(ByVal strIn As Variant) As String
Dim i As Integer
Const strIllegals = "\'"""
For i = 1 To Len(strIllegals)
strIn = Replace(strIn, Mid$(strIllegals, i, 1), "\" & Mid$(strIllegals, i, 1))
Next i
fixString = strIn
End Function
Try changing cell.Value to Replace(cell.Value, "'", "")
Or is it contents that has the apostrophe in it? A bit confusing.
Try changing contents to Replace(contents , "'", "")

Getting Property Date/Time from VBA

I have the following code which I use to get date properties of some jpg files. I am trying to have it so I can extract day() month() and year() from this. It works most of the time but on occasion, there are some rogue ? in there. I have tried getproperty1 = Replace(getproperty1, "?", "") however this does not work (and wasnt really expecting it to)
intPos = InStrRev(strFile, "\")
strPath = Left(strFile, intPos)
strName = Mid(strFile, intPos + 1)
''debug.print intPos & " .. " & strPath & " .. " & strName
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPath)
Set objFolderItem = objFolder.ParseName(strName)
If Not objFolderItem Is Nothing Then
getproperty1 = objFolder.GetDetailsOf(objFolderItem, n)
If getproperty1 = vbNullString Then
getproperty1 = objFolder.GetDetailsOf(objFolderItem, 4)
End If
I am wanting it to always be readable as a date at least, as I will be passing it all back to a duplicate file (see Rotate a saved image with vba for more of an idea as to what I do with it) using some more code I have modified from Chip Pearson's site (http://www.cpearson.com/excel/FileTimes.htm) to write it back to the file which takes the datetime as Double (so will be running Dateserial()+Timeserial() at that point. There are reasons stopping me passing datetime directly between the two as I sometimes need to make amendments in between the two bits of code)
I have used a character strip function to iterate through each individual character, eliminating anything that isnt a number, ":" or a space, then passed it through DateValue() to get it as a recognisable date format. Works like a charm now!
Function stripChars(chrStrp As String)
stripChars = ""
For cnt = 1 To Len(chrStrp)
tmpChar = Mid(chrStrp, cnt, 1)
If Val(tmpChar) <> 0 Or tmpChar = "0" Or tmpChar = "/" Or tmpChar = " " Or tmpChar = ":" Then
stripChars = stripChars & tmpChar
End If
Next cnt
Debug.Print stripChars
stripChars = DateValue(stripChars)
End Function

Is there a better way to check if files exist using Excel VBA

I have a folder with thousands of files, and a spreadsheet that has 2 pieces of information:
DocumentNumber Revision
00-STD-GE-1234-56 3
I need to find and concatenate all files in the folder than match this document number and revision combination into this format:
00-STD-GE-1234-56_3.docx|00-STD-GE-1234-56_3.pdf
The pdf must be last
sometimes the file is named without the last 3 chars of the document number (if they are -00 they are left off)
sometimes the revision is separated using "_" and sometimes using "_r"
I have the code working, but it takes a long time (this sheet has over 7000 rows, and this code is 20 file comparisons per row against a network file system), is there an optimization for this?
''=============================================================================
Enum IsFileOpenStatus
ExistsAndClosedOrReadOnly = 0
ExistsAndOpenSoBlocked = 1
NotExists = 2
End Enum
''=============================================================================
Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus
'ExistsAndClosedOrReadOnly = 0
'ExistsAndOpenSoBlocked = 1
'NotExists = 2
With New FileSystemObject
If Not .FileExists(FileName) Then
IsFileReadOnlyOpen = 2 ' NotExists = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select
End Function 'IsFileReadOnlyOpen
''=============================================================================
Function BuildAndCheckPath(sMasterPath As String, sLegacyDocNum As String, sRevision As String) As String
Dim sLegacyDocNumNoSheet As String
sLegacyDocNumNoSheet = Left(sLegacyDocNum, Len(sLegacyDocNum) - 3)
Dim sFileExtensions
sFileExtensions = Array(".doc", ".docx", ".xls", ".xlsx", ".pdf")
Dim sRevisionSpacer
sRevisionSpacer = Array("_", "_r")
Dim i As Long
Dim j As Long
Dim sResult As String
'for each revision spacer option
For i = LBound(sRevisionSpacer) To UBound(sRevisionSpacer)
'for each file extension
For j = LBound(sFileExtensions) To UBound(sFileExtensions)
'Check if the file exists (assume a sheet number i.e. 00-STD-GE-1234-56)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
Next j
Next i
BuildAndCheckPath = sResult
End Function
It's hard to tell without seeing your dataset, but perhaps this approach could be implemented (note the use of Wildcards):
UNTESTED
Const Folder As String = "C:\YourFolder\"
Dim File as Object
Dim XLSFile As String
Dim PDFFile As String
Dim ConCat() As String
Dim DocNos() As Variant
Dim DocRev() As Variant
Dim i As Long
DocNos = Range("A1:A10") '<--Your list of Document #s.
DocRev = Range("B1:B10") '<--Your list of Revision #s.
ReDim ConCat(1 To UBound(DocNos))
'Loop through your Document numbers.
For i = LBound(DocNos) To UBound(DocNos)
'Loop through the folder.
File = Dir(Folder)
Do While File <> ""
'Check the filename against the Document number. Use a wildcard at this _
'point as a sort of "gatekeeper"
If File Like Left(DocNos(i), Len(DocNos(i)) - 3) & "*"
'If the code makes it to this point, you just need to match file _
'type and revision.
If File Like "*_*" & DocRev(i) And File Like "*.xls*" Then
XLSFile = File
ElseIf File Like "*_*" & DocRev(i) File Like "*.pdf" Then
PDFFile = File
End If
If XLSFile <> "" And PDFFile <> "" Then
ConCat(i) = XLSFile & "|" & PDFFile
XLSFile = vbNullString
PDFFile = vbNullString
End If
End If
File = Dir
Loop
Next i
To print the results to your sheet (Transpose pastes the results of the array in one column instead of putting the results in one row), you could use something like this:
Dim Rng As Range
Set Rng = Range("C1")
Rng.Resize(UBound(ConCat),1).Value = Application.Transpose(ConCat)
This approach loops through each document number from your spreadsheet, and then checks each file in the folder to see if it matches the document number, document type, and revision number. Once it finds a match for both .xls* and .pdf types, it concatenates the filenames together.
See this great SO post regarding looping through files.
See this site for more info about the Dir function.
See this article regarding wilcard character usage when comparing strings.
Hope that helps!
Seems to me you are doing unnecessary file existence checks even in cases where a file has already been found. Assuming that talking with your network drive is indeed what takes up most of your execution time, then there's a place to optimise.
What you're doing is this:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
'...
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
'Wait a minute... why ask me to look again if I already found it?
'He must not mind the extra waiting time... ok, here we go again.
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'...
End If
I think you want to look for your file under a different filename if and only if you haven't found it under the first filename pattern. Can do this using an Else clause:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
'Didn't find it using the first filename format.
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
Err.Raise 53, , _
"File not found even though I looked for it in two places!"
End If
End If
This can theoretically cut your number of tries by up to half; likely less in practice, but you'll get the largest benefit if you check the most common filename pattern first. The benefit will be proportionally larger if you have a greater number of filename patterns; from your question I understand you have 4 different combinations?
If you have more than 2 patterns to check, then nesting a bunch of Else clauses will look silly and be difficult to read; instead you can do something like this:
Dim foundIt As Boolean
foundIt = False
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
'...
'... check your other patterns here...
'...
If Not foundIt Then
Err.Raise 53, , _
"File not found even though I looked for it various places!"
End If

Word VBA heading text cut short and function produces reversed results when called from Sub

Sorry for the two fold question in one post.
This indirectly relates to a question I posted recently here: vba: return page number from selection.find using text from array which was solved
Program purpose:
Firstly: add a footer with custom page numbers to documents (i.e. 0.0.0, Chapter.Section,Page representative) in a selected folder and sub folders.
Secondly: create a TOC with the custom page numbers saved as roottoc.docx in the root folder selected.
I now have two new problems before I can fully clean and finally put this to bed, I will post the full code at the end of this post.
Solved First of all, from what I have discovered and just read elsewhere too the getCrossReferenceItems(refTypeHeading) method will only return the text upto a certain length from what of finds. I have some pretty long headings which means this is quite an annoyance for the purpose of my code. So the first question I have is is there something I can do with the getCrossReferenceItems(refTypeHeading) method to force it to collect the full text from any referenced headings or is there an alternative way round this problem.
Solved Secondly the createOutline() function when called in ChooseFolder() produces the correct results but in reverse order, could someone point the way on this one too please.
Unfortunately the actual results I am recieving will be difficulty to exactly replicate but if a folder is made containing a couple of documents with various headings. The directory name should be the the same as what is in the Unit Array i.e. Unit(1) "Unit 1", the file names are made up of two parts i.e. Unit(1) & " " & Criteria(1) & ext becoming "Unit 1 p1.docx" etc, the arrays Unit and Criteria are in the ChooseFolder Sub. chapArr is a numerical representative of the Unit array contents soley for my page numbering system, I used another array because of laziness at this point in time. I could have used some other method on the Unit array to achieve the same result which I might look at when cleaning up.
When running the ChooseFolder Sub if the new folder with documents in is located in My Document then My Documents will be the folder to locate and select in the file dialogue window. This should produce results that are similar and will give an example of what I am talking about.
Complete code:
Public Sub ChooseFolder()
'Declare Variables
'|Applications|
Dim doc As Word.Document
'|Strings|
Dim chapNum As String
Dim sResult As String
Dim Filepath As String
Dim strText As String
Dim StrChapSec As String
'|Integers|
Dim secNum As Integer
Dim AckTime As Integer
Dim FolderChosen As Integer
'|Arrays|
Dim Unit() As Variant
Dim ChapArray() As Variant
Dim Criteria() As Variant
'|Ranges|
Dim rng As Range
'|Objects|
Dim InfoBox As Object
'|Dialogs|
Dim fd As FileDialog
'Constants
Const ext = ".docx"
'Set Variable Values
secNum = 0 'Set Section number start value
AckTime = 1 'Set the message box to close after 1 seconds
Set InfoBox = CreateObject("WScript.Shell") 'Set shell object
Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'Set file dialog object
FolderChosen = fd.Show 'Display file dialogue
'Set Array Values
'ToDo: create form to set values for Arrays
'Folder names
Unit = Array("Unit 1", "Unit 2")
'Chapter Numbers
chapArr = Array("1", "2")
'Document names
Criteria = Array("P1", "P2", "P3", "P4", "P5", "P6", "P7", "P8", "P9", "M1", "M2", "M3", "M4", "D1", "D2", "D3")
If FolderChosen <> -1 Then
'didn't choose anything (clicked on CANCEL)
MsgBox "You chose cancel"
Else
'Set sResult equal to selected file/folder in file dialogue
sResult = fd.SelectedItems(1)
End If
' Loop through unit array items
For i = LBound(Unit) To UBound(Unit)
unitName = Unit(i)
' Test unit folder being looked at and concatenate sResult with
' unitName delimited with "\"
If unitName = "Unit 105" Then
Filepath = sResult & "\unit 9"
Else
Filepath = sResult & "\" & unitName
End If
' Loop through criteria array items
For j = LBound(Criteria) To UBound(Criteria)
criteriaName = Criteria(j)
' Set thisFile equal to full file path
thisfile = Filepath & "\" & unitName & " " & criteriaName & ext 'Create file name by concatenating filePath with "space" criteriaName and ext
' Test if file exists
If File_Exists(thisfile) = True Then
' If file exists do something (i.e. process number of pages/modify document start page number)
' Inform user of file being processed and close popup after 3 seconds
Select Case InfoBox.Popup("Processing file - " & thisfile, AckTime, "This is your Message Box", 0)
Case 1, -1
End Select
' Open document in word using generated filePath in read/write mode
' Process first section footer page number and amend to start as intPages (total pages) + 1
Set doc = Documents.Open(thisfile)
With doc
With ActiveDocument.Sections(1)
chapNum = chapArr(i)
secNum = secNum + 1
' Retrieve current footer text
strText = .Footers(wdHeaderFooterPrimary).Range.Text
.PageSetup.DifferentFirstPageHeaderFooter = False
' Set first page footer text to original text
.Footers(wdHeaderFooterFirstPage).Range.Text = strText
' Set other pages footer text
.Footers(wdHeaderFooterPrimary).Range.Text = Date & vbTab & "Author: Robert Ells" & vbTab & chapNum & "." & secNum & "."
Set rng = .Footers(wdHeaderFooterPrimary).Range.Duplicate
rng.Collapse wdCollapseEnd
rng.InsertBefore "{PAGE}"
TextToFields rng
End With
ActiveDocument.Sections(1).Footers(1).PageNumbers.StartingNumber = 1
Selection.Fields.Update
Hide_Field_Codes
ActiveDocument.Save
CreateOutline sResult, chapNum & "." & secNum & "."
End With
Else
'If file doesn't exist do something else (inform of non existant document and close popup after 3 seconds
Select Case InfoBox.Popup("File: " & thisfile & " - Does not exist", AckTime, "This is your Message Box", 0)
Case 1, -1
End Select
End If
Next
Filepath = ""
secNum = 0
Next
End Sub
Private Function TextToFields(rng1 As Range)
Dim c As Range
Dim fld As Field
Dim f As Integer
Dim rng2 As Range
Dim lFldStarts() As Long
Set rng2 = rng1.Duplicate
rng1.Document.ActiveWindow.View.ShowFieldCodes = True
For Each c In rng1.Characters
DoEvents
Select Case c.Text
Case "{"
ReDim Preserve lFldStarts(f)
lFldStarts(f) = c.Start
f = f + 1
Case "}"
f = f - 1
If f = 0 Then
rng2.Start = lFldStarts(f)
rng2.End = c.End
rng2.Characters.Last.Delete '{
rng2.Characters.First.Delete '}
Set fld = rng2.Fields.Add(rng2, , , False)
Set rng2 = fld.Code
TextToFields fld.Code
End If
Case Else
End Select
Next c
rng2.Expand wdStory
rng2.Fields.Update
rng1.Document.ActiveWindow.View.ShowFieldCodes = True
End Function
Private Function CreateOutline(Filepath, pgNum)
' from https://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
'Declare Variables
'|Applications|
Dim App As Word.Application
Dim docSource As Word.Document
Dim docOutLine As Word.Document
'|Strings|
Dim strText As String
Dim strFileName As String
'|Integers|
Dim intLevel As Integer
Dim intItem As Integer
Dim minLevel As Integer
'|Arrays|
Dim strFootNum() As Integer
'|Ranges|
Dim rng As Word.Range
'|Variants|
Dim astrHeadings As Variant
Dim tabStops As Variant
'Set Variable values
Set docSource = ActiveDocument
If Not FileLocked(Filepath & "\" & "roottoc.docx") Then
If File_Exists(Filepath & "\" & "roottoc.docx") Then
Set docOutLine = Documents.Open(Filepath & "\" & "roottoc.docx", ReadOnly:=False)
Else
Set docOutLine = Document.Add
End If
End If
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutLine.Content
minLevel = 5 'levels above this value won't be copied.
astrHeadings = returnHeaderText(docSource) 'docSource.GetCrossReferenceItems(wdRefTypeHeading)
docSource.Select
ReDim strFootNum(0 To UBound(astrHeadings))
For i = 1 To UBound(astrHeadings)
With Selection.Find
.Text = Trim(astrHeadings(i))
.Wrap = wdFindContinue
End With
If Selection.Find.Execute = True Then
strFootNum(i) = Selection.Information(wdActiveEndPageNumber)
Else
MsgBox "No selection found", vbOKOnly 'Or whatever you want to do if it's not found'
End If
Selection.Move
Next
docOutLine.Select
With Selection.Paragraphs.tabStops
'.Add Position:=InchesToPoints(2), Alignment:=wdAlignTabLeft
.Add Position:=InchesToPoints(6), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
End With
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
' strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Test which heading is selected and indent accordingly
If intLevel <= minLevel Then
If intLevel = "1" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & pgNum & strFootNum(intItem) & vbCr
End If
If intLevel = "2" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & pgNum & strFootNum(intItem) & vbCr
End If
If intLevel = "3" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & pgNum & strFootNum(intItem) & vbCr
End If
If intLevel = "4" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & pgNum & strFootNum(intItem) & vbCr
End If
If intLevel = "5" Then
strText = " " & Trim$(astrHeadings(intItem)) & vbTab & pgNum & strFootNum(intItem) & vbCr
End If
' Add the text to the document.
rng.Collapse (False)
rng.InsertAfter strText & vbLf
docOutLine.SelectAllEditableRanges
' tab stop to set at 15.24 cm
'With Selection.Paragraphs.tabStops
' .Add Position:=InchesToPoints(6), _
' Leader:=wdTabLeaderDots, Alignment:=wdAlignTabRight
' .Add Position:=InchesToPoints(2), Alignment:=wdAlignTabCenter
'End With
rng.Collapse (False)
End If
Next intItem
docSource.Close
docOutLine.Save
docOutLine.Close
End Function
Function returnHeaderText(doc As Word.Document) As Variant
Dim returnArray() As Variant
Dim para As Word.Paragraph
Dim i As Integer
i = 0
For Each para In doc.Paragraphs
If Left(para.Style, 7) = "Heading" Then
ReDim Preserve returnArray(i)
returnArray(i) = para.Range.Text
i = i + 1
End If
Next
returnHeaderText = returnArray
End Function
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
Private Function GetLevel(strItem As String) As Integer
' from https://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
'Returns True if the passed sPathName exist
'Otherwise returns False
On Error Resume Next
If sPathName <> "" Then
If IsMissing(Directory) Or Directory = False Then
File_Exists = (Dir$(sPathName) <> "")
Else
File_Exists = (Dir$(sPathName, vbDirectory) <> "")
End If
End If
End Function
Sub Hide_Field_Codes()
Application.ActiveWindow.View.ShowFieldCodes = False
End Sub
Kevin's Solutions:
Question part 1, Answer
I thought initially that something went wrong when I added your function, but it was due to a blank heading on the following line after the actual heading in the documents. I suppose an If statement to test if there is text present could solve this. :-)
I haven't tested this bit yet (due to being tired), but if the heading is inline with normal text, would this function pick up only the heading or both heading and normal text?
Question part 2, Answer
Just worked, although with one niggle (the list produced is no longer indented as desired in the main CreateOutline function). Time is getting on now so will have to pick this up again tomorrow :-)
Thanks yet again kevin, this is where I should have concentrated more during programming at uni instead of thinking about the pub.
Phil :-)
welcome back! :-)
For the reversed data from the CreateOutline function - change your Collapse function to have a false parameter. Collapse defaults to putting the cursor at the beginning of the selection, but this will put it at the end so you're adding to the end of the doc instead of the beginning:
' Add the text to the document.
rng.Collapse(False) 'HERE'
rng.InsertAfter strText & vbLf
docOutLine.SelectAllEditableRanges
rng.Collapse(False) 'AND HERE'
For the CrossReferenceItems issue, try this and let me know if there's any data missing from what it returns. Call this instead of the CrossReferenceItems method:
Function returnHeaderText(doc As Word.Document) As Variant
Dim returnArray() As Variant
Dim para As Word.Paragraph
Dim i As Integer
i = 0
For Each para In doc.Paragraphs
If Left(para.Style, 7) = "Heading" Then
ReDim Preserve returnArray(i)
returnArray(i) = para.Range.Text
i = i + 1
End If
Next
returnHeaderText = returnArray
End Function