很抱歉在一篇文章中提出了两个问题。
这间接与我最近在这里发布的一个问题有关：vba: return page number from selection.find using text from array which has beensolved
节目目的：
首先：为所选文件夹和子文件夹中的文档（即0.0.0，Chapter.Section，Page代表）添加带有自定义页码的页脚。
其次：在选定的根文件夹中创建一个目录，并将自定义页码保存为 roottoc.docx。
在我完全清理并最终解决之前，我现在有两个新问题，我将在本文末尾发布完整的代码。
解决了首先，从我发现的内容以及刚刚在其他地方阅读的内容来看，该getCrossReferenceItems(refTypeHeading)方法只会从找到的内容中返回一定长度的文本。我有一些很长的标题，这意味着这对于我的代码来说是相当烦人的。所以我的第一个问题是我可以用这种getCrossReferenceItems(refTypeHeading)方法做些什么来强制它从任何引用的标题中收集全文，或者是否有解决这个问题的替代方法。
解决了其次，createOutline()调用该函数时ChooseFolder()会产生正确的结果，但顺序相反，请有人也可以指出这一点。
不幸的是，我收到的实际结果很难准确复制，但如果一个文件夹包含几个具有不同标题的文档。目录名称应与单元数组中的相同，即 Unit(1) "Unit 1"，文件名由两部分组成，即 Unit(1) & " " & Criteria(1) & ext 成为“Unit 1 p1.docx”等，数组Unit和Criteria在ChooseFolder子中。chapArr是我的页码系统唯一的Unit数组内容的数字代表，由于此时的懒惰，我使用了另一个数组。我本可以在 Unit 数组上使用其他一些方法来达到我在清理时可能会看到的相同结果。
运行 ChooseFolder Sub 时，如果包含文档的新文件夹位于“我的文档”中，则“我的文档”将成为在文件对话窗口中定位和选择的文件夹。这应该会产生相似的结果，并会举例说明我正在谈论的内容。
完整代码：
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
凯文的解决方案：
问题第 1 部分，答案
我最初认为当我添加您的函数时出现问题，但这是由于文档中实际标题之后的下一行中的空白标题。我想一个If测试是否存在文本的语句可以解决这个问题。:-)
我还没有测试这一点（由于累了），但是如果标题与普通文本内联，这个函数会只拾取标题还是同时拾取标题和普通文本？
问题第 2 部分，答案
刚刚工作，虽然有一个小问题（生成的列表不再按主CreateOutline函数中的需要缩进）。时间快到了，所以明天必须再次拿起这个:-)
再次感谢 kevin，这是我在 uni 编程期间应该更加专注的地方，而不是考虑酒吧。
菲尔:-)