Текст заголовка VBA заголовка сокращен и функция вызывает обратные результаты при вызове из Sub

Question

Извините за два вопроса в одном сообщении.

Это косвенно относится к вопросу, который я разместил недавно здесь: vba: return page number from selection.find using text from array которая была решена

Цель программы:

Во-первых: добавить колонтитул с номерами пользовательских страниц для документов (т.е. 0.0.0, Chapter.Section , Страница) в выбранной папке и вложенных папках.

Во-вторых: создайте TOC с номерами пользовательских страниц, сохраненными как roottoc.docx в выбранной корневой папке.

У меня теперь есть две новые проблемы, прежде чем я смогу полностью очистить и, наконец, положить это в постель, я выложу полный код в конце этого сообщения.

решаемые Прежде всего, от того, что я обнаружил, и только что прочитал в других местах тоже метод getCrossReferenceItems(refTypeHeading) будет возвращать только текст Шифрование до определенной длины, от того, что находок. У меня есть довольно длинные заголовки, что означает, что это довольно раздражает для моего кода. Итак, первый вопрос, который у меня есть, - это то, что я могу сделать с помощью метода getCrossReferenceItems(refTypeHeading), чтобы заставить его собирать полный текст из любых упоминаемых рубрик или есть альтернативный способ обойти эту проблему.

решаемые Во-вторых, функция createOutline() при вызове в ChooseFolder() дает правильные результаты, но в обратном порядке, может кто-то указать путь на этот тоже пожалуйста.

К сожалению, фактические результаты, которые я получаю, будут трудно точно воспроизвести, но если папка создана с несколькими документами с различными заголовками. Имя каталога должно быть таким же, как и в массиве устройств, т.е. Единице (1) «Единица 1», имена файлов состоят из двух частей, т.е. Единицы измерения (1) & »« & Критерии (1) & «Единица 1 p1.docx» и т. Д., Массивы Единица и Критерии находятся в ChooseFolder Под. chapArr является числовым представителем Единица Содержимое массива soley для моей системы нумерации страниц, я использовал другой массив из-за лености в этот момент времени. Я мог бы использовать какой-либо другой метод в массиве Unit для достижения того же результата, который я мог бы рассмотреть при очистке.

При запуске SelectFolder Sub, если новая папка с документами находится в My Document, тогда Мои документы будут папкой для поиска и выбора в диалоговом окне файла. Это должно привести к сходным результатам и привести пример того, о чем я говорю.

Полный код:

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 

Solutions Кевина:

Вопрос часть 1, Ответ

Первоначально я думал, что что-то пошло не так, когда я добавил вашу функцию, но это было связано с пустой заголовок в следующей строке после фактического заголовка в документах.Я полагаю, что заявление If для проверки наличия текста может решить эту проблему. :-)

Я еще не тестировал этот бит (из-за усталости), но если заголовок встроен в обычный текст, будет ли эта функция отображать только заголовок или оба заголовка и обычный текст?

Вопрос часть 2, ответ

Просто работал, хотя и с одним (размениваться на мелочи списка не производится больше не отступом по желанию в основной CreateOutline функции). Время набирает силу, так что придется завтра снова забирать это :-)

Еще раз спасибо kevin, вот где я должен был сконцентрироваться больше на программировании в uni, вместо того чтобы думать о пабе.

Phil :-)

Answer 1

добро пожаловать обратно! :-)

Для обратных данных из функции CreateOutline - измените функцию Collapse, чтобы иметь параметр false. Collapse по умолчанию, чтобы поставить курсор в начале отбора, но это поставит его в конце, так что вы хотите добавить в конце док вместо начала:

' Add the text to the document. 
rng.Collapse(False) 'HERE' 
rng.InsertAfter strText & vbLf 
docOutLine.SelectAllEditableRanges 
rng.Collapse(False) 'AND HERE' 

Для выпуска CrossReferenceItems, попробуйте это и дайте мне знать, нет ли каких-либо данных, из которых он возвращается. Назовем это вместо метода CrossReferenceItems:

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