StackOverflow2013

Note that there are some explanatory texts on larger screens.

plurals

POWord VBA heading text cut short and function produces reversed results when called from Sub
text
Body
copied!<p>Sorry for the two fold question in one post.</p> <p>This indirectly relates to a question I posted recently here: <a href="https://stackoverflow.com/questions/13327813/vba-return-page-number-from-selection-find-using-text-from-array">vba: return page number from selection.find using text from array</a> which was solved</p> <p>Program purpose:</p> <p>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.</p> <p>Secondly: create a TOC with the custom page numbers saved as roottoc.docx in the root folder selected.</p> <p>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. </p> <p><strong>Solved</strong> First of all, from what I have discovered and just read elsewhere too the <code>getCrossReferenceItems(refTypeHeading)</code> 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 <code>getCrossReferenceItems(refTypeHeading)</code> method to force it to collect the full text from any referenced headings or is there an alternative way round this problem. </p> <p><strong>Solved</strong> Secondly the <code>createOutline()</code> function when called in <code>ChooseFolder()</code> produces the correct results but in reverse order, could someone point the way on this one too please.</p> <p>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 <strong>Unit</strong> and <strong>Criteria</strong> are in the <code>ChooseFolder</code> Sub. <strong>chapArr</strong> is a numerical representative of the <strong>Unit</strong> 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. </p> <p>When running the ChooseFolder Sub if the new folder with documents in is located in My Document then <strong>My Documents</strong> 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. </p> <p>Complete code:</p> <pre><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 </code></pre> <p>Kevin's Solutions:</p> <p><strong>Question part 1, Answer</strong></p> <p>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 <code>If</code> statement to test if there is text present could solve this. :-)</p> <p>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?</p> <p><strong>Question part 2, Answer</strong></p> <p>Just worked, although with one niggle (the list produced is no longer indented as desired in the main <code>CreateOutline</code> function). Time is getting on now so will have to pick this up again tomorrow :-)</p> <p>Thanks yet again kevin, this is where I should have concentrated more during programming at uni instead of thinking about the pub. </p> <p>Phil :-)</p>

Querying!

Guidance

An individual column

Larger individual text columns get their own page to allow for proper reading.

SQuiL has stopped working due to an internal error.

If you are curious you may find further information in the browser console, which is accessible through the devtools (F12).

Reload