如何以随机顺序将包含格式信息的范围从 word doc 中的页面传输到新的 word doc？

Question

我的妻子是一名教授，我发现她多年来一直在手动创建她的测试的随机版本（以减少作弊）手动以及她所在部门的所有其他教师。她使用 Word 2007 和 2010 编写测试，因此我着手编写 VBA 宏来为她完成这个繁琐的过程。

她的测试包括图像、列表和其他格式，因此无法直接复制文本。引用相同图像的所有问题都在同一页面上，否则每个问题都有自己的页面。第一页包含说明，需要包含在随机测试文档的开头，但所有其他页面都需要在新文档中随机化。在随机化过程之后，我将删除分页符，以便问题整齐地放在尽可能少的页面上。

到目前为止，我还无法在不丢失格式信息的情况下将从 Page 集合中获取的 Ranges 传输到新文档。我用谷歌搜索了所有地方，但我还没有发现任何迹象表明我做错了什么。

到目前为止我的代码：

Sub CreateTestVersions()

Dim ThisDoc As Document
Dim NewDoc As Document
Dim Pgs As pages
Dim Question As Range

Let Skip = 1 'Number of pages to skip randomizing

Set ThisDoc = Application.ActiveDocument
Set NewDoc = Documents.Add 'Create new document
Set Pgs = ThisDoc.Windows(1).Panes(1).pages 'Pages collection

ReDim Questions(1 To Pgs.Count - Skip) As Range

For p = 1 To Skip 'Add skipped pages to begining of new document
    NewDoc.Content = NewDoc.Content & Pgs(p).Rectangles(1).Range
Next

' Add questions to an array of ranges
For q = LBound(Questions) To UBound(Questions)
    Set Question = Pgs(q + Skip).Rectangles(1).Range

    'Keep questions on a single page, don't split accross pages
    Question.Paragraphs.KeepTogether = True

    ' All lists, text formatting, etc. is lost for some reason
    Set Questions(q) = Question ' Needs fixed
Next

'Randomization needs to happen here

'Add randomized questions to new document
For q = LBound(Questions) To UBound(Questions)
    NewDoc.Content = NewDoc.Content & Questions(q)
Next

'Remove page breaks
With NewDoc.Content.Find
    .Text = "^m"
    .Forward = True
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
End With
End Sub

我使用 Questions 数组是因为我认为它更容易随机化，尤其是当我扩展此代码以生成多个版本时。如果可能的话，我还想避免使用选择、复制、粘贴。

感谢任何关于我为什么会丢失格式以及应该采用什么正确方法的见解。

Answer 1

我确实设法使用 InsertFile 并在每个问题周围添加范围书签来使其工作。这是成品。希望它能帮助其他人！

Sub CreateTestVersions()

Dim ThisDoc As Document
Dim NewDocs() As Document
Dim Pgs As pages
Dim Question As Range
Dim skip As Variant
Dim versions As Variant
Dim Vers() As Integer
Dim qList As String
Dim numQs As Integer
Dim bound() As String
Dim fileName() As String
Dim pages As Integer
Dim minPages As Integer
Dim tryAgain As Boolean
Dim all As Range

Set ThisDoc = Application.ActiveDocument
Set Pgs = ThisDoc.ActiveWindow.Panes(1).pages 'Pages collection

'Number of pages to skip randomizing
skip = InputBox( _
    "Each question should be on its own page, " _
    & "unless that question shares a connection with another " _
    & "(e.g. they share an image reference).  You can separate " _
    & "them using CTRL-Enter or Insert Page Break." & vbNewLine & vbNewLine _
    & "How many pages belong at the beginning of every version " _
    & "(instructions, personal data, etc.)?", "Question", 1)

If skip = "" Then Exit Sub

versions = InputBox("How many versions would you like to produce?", "Question", 4)

If versions = "" Then Exit Sub

numQs = Pgs.Count - skip

qList = InputBox(numQs & " question pages detected. Please list which questions" _
    & " you want to use, with ranges denoted with dashes and gaps by commas" _
    & " (e.g. 1-5, 9, 12-20).", "Question", "1-" & numQs)

If qList = "" Then Exit Sub

ReDim NewDocs(1 To versions) As Document
ReDim Vers(1 To versions) As Integer
For v = 1 To versions
    'Create new document(s)
    Set NewDocs(v) = Documents.Add
    Vers(v) = v
Next

ReDim Indexes(1 To numQs) As Long
qList = Replace(qList, " ", "")
RangeList = Split(qList, ",")
numQs = 0
For Each rng In RangeList
    bound = Split(rng, "-")
    For i = bound(LBound(bound)) To bound(UBound(bound))
        numQs = numQs + 1
        Indexes(numQs) = i
    Next
Next

ReDim Preserve Indexes(1 To numQs) As Long
ReDim Questions(1 To numQs) As Range

' Add questions to an array of ranges
For Each q In Indexes
    If (Not ThisDoc.Bookmarks.Exists("Question " & q)) Then
        ThisDoc.Bookmarks.Add "Question" & q, _
                          Pgs(q + skip).Rectangles(1).Range
    End If
Next

minPages = Pgs.Count
Randomize
Do
    For Each v In Vers
        'Clear new document in case we are retrying for a shorter version
        Set all = NewDocs(v).Content
        all.WholeStory
        all.Select
        Selection.Delete
        'Add skipped pages to begining of new document
        If (Not ThisDoc.Bookmarks.Exists("Introduction")) Then
            ThisDoc.Bookmarks.Add "Introduction", _
                ThisDoc.Range(Pgs(1).Rectangles(1).Range.Start, _
                              Pgs(skip).Rectangles(1).Range.End)
        End If
        NewDocs(v).Content.InsertFile ThisDoc.FullName, "Introduction"

        'Generate random indexs
        For i = numQs To 2 Step -1
            r = Int(Rnd() * (i - 2)) + 1
            temp = Indexes(r)
            Indexes(r) = Indexes(i)
            Indexes(i) = temp
        Next i

        'Add randomized questions to new document
        For q = LBound(Questions) To UBound(Questions)
            i = Indexes(q)
            Set Question = NewDocs(v).Content
            Question.Collapse Direction:=wdCollapseEnd
            Question.InsertFile ThisDoc.FullName, "Question" & i
            Set Question = NewDocs(v).Range(Question.Start, NewDocs(v).Range.End)
            Question.Paragraphs.KeepWithNext = True
            NewDocs(v).Bookmarks.Add "Question" & i, Question
        Next

        'Remove page breaks
        With NewDocs(v).Content.Find
            .Text = "^m"
            .Forward = True
            .Wrap = wdFindContinue
            .Replacement.Text = ""
            .Execute Replace:=wdReplaceAll
        End With

        'Group questions within pages, not accross them
        For Each Bookmark In NewDocs(v).Bookmarks
            Bookmark.Range.Paragraphs.Last.KeepWithNext = False
        Next

        pages = NewDocs(v).Windows(1).Panes(1).pages.Count
        If pages < minPages Then minPages = pages
    Next

    ' If all pages are not minimum length then try again
    tryAgain = False
    For Each v In Vers
        pages = NewDocs(v).Windows(1).Panes(1).pages.Count
        If pages > minPages Then tryAgain = True
    Next
Loop While tryAgain

For Each v In Vers
    'Save Document
    fileName = Split(ThisDoc.Name, ".")
    file = fileName(0)
    ext = fileName(1)
    NewDocs(v).SaveAs2 _
            fileName:=file & " Version " & v & "." & ext, _
            CompatibilityMode:=wdCurrent
Next
ThisDoc.Activate
End Sub