текстовое поле перемещается в начало последней страницы в текстовом документе макрос vba

Question

Я пишу макрос VBA для документа Word.Я использую макрос VBA для создания текстового поля и текста в документе Word.Проблема в том, что текстовое поле перемещается в верхнюю часть последней страницы, а не остается на первой странице .

Я не знаю, что я делаю неправильно. Все, что мне нужно, чтобы текстовое поле оставалось на первой странице. Мне действительно нужно включить текстовое поле.

ниже - мой код и выходное изображение

Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String


myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
    ' no current word application
    Set wdApp = CreateObject("Word.application")
    Set wrdDoc = wdApp.Documents.Open(WDoc)
    wdApp.Visible = True
Else
    ' word app running
    For Each tmpDoc In wdApp.Documents
        If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
            ' this is your doc
            Set wrdDoc = tmpDoc
            Exit For
        End If
    Next
    If wrdDoc Is Nothing Then
        ' not open
        Set wrdDoc = wdApp.Documents.Open(WDoc)
    End If
End If




ActiveDocument.Content.Select
Selection.Delete

With wdApp
    .Visible = True
    .Activate

    With .Selection
        Dim objShape As Word.Shape


        Set objShape2 = ActiveDocument.Shapes.addTextbox _
        (Orientation:=msoTextOrientationHorizontal, _
        Left:=400, Top:=100, Width:=250, Height:=60)
        With objShape2
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Left = wdShapeRight
            .Top = wdShapeTop
            .TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
            .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
        End With
    End With

    With .Selection
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph

        For i = 1 To 40
            .TypeText i
            .TypeParagraph
        Next i
    End With
End With

Answer 1

Еще одно решение для вас.

'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========A=========B=========C

Option Explicit


Sub textboxtest()

Const my_doc_name                       As String = "mydocument.docx"

Dim my_fso                              As Scripting.FileSystemObject
Dim my_doc                              As Word.Document
Dim my_range                            As Word.Range
Dim counter                             As Long
Dim my_text_box                         As Word.Shape
Dim my_shape_range                      As Word.ShapeRange

' There is no need to test for the Word app existing
' if this macro is in a Word template or Document
' because to run the macro Word MUST be loaded

    Set my_fso = New Scripting.FileSystemObject
    If my_fso.FileExists(ThisDocument.Path & "\" & my_doc_name) Then
        Set my_doc = Documents.Open(ThisDocument.Path & "\" & my_doc_name)

    Else
        Set my_doc = Documents.Add
        my_doc.SaveAs2 ThisDocument.Path & "\" & my_doc_name

    End If

    my_doc.Activate ' Although it should already be visible
    my_doc.content.Delete

    Set my_text_box = my_doc.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        left:=400, _
        top:=100, _
        Width:=250, _
        Height:=60)

    With my_text_box
        .Name = "TextBox1"
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
        .left = wdShapeRight
        .top = wdShapeTop
        With .TextFrame
            .TextRange = "This is nice and shine" & vbCrLf & "222"
            .TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft

        End With

    End With

    Set my_range = my_text_box.Parent.Paragraphs(1).Range

    'FROM
    '
    ' https://docs.microsoft.com/en-us/office/vba/api/word.shape'

    ' Every Shape object is anchored to a range of text. A shape is anchored
    ' to the beginning of the first paragraph that contains the anchoring
    ' range. The shape will always remain on the same page as its anchor.

    my_range.Collapse Direction:=wdCollapseEnd

    With my_range
        For counter = 1 To 90
            .Text = counter
            .InsertParagraphAfter
            .Collapse Direction:=wdCollapseEnd

        Next

    End With

End Sub

Answer 2

Word Shape объекты должны быть привязаны к позиции символа в документе Word.Они всегда будут появляться на странице, где находится символ привязки, и, если форматирование привязки не относится к странице, они будут перемещаться относительно страницы с символом привязки.

Особый случай возникает, когда документ«пустой» (одиночный абзац), поэтому помогает убедиться, что в документе содержится более одного символа.В приведенном ниже примере кода добавляется дополнительный абзац перед добавлением TextBox - к первому абзацу.

Я внес в код некоторые другие корректировки:

1. Добавлено On Error GoTo 0так что появятся сообщения об ошибках.В противном случае отладка становится невозможной.
2. Удален With для приложения Word, поскольку он не требуется при использовании объектов Word
3. Объявлен и используется объект Word Range для вставки содержимого.Как и в Excel, лучше , а не работать с Selection, когда это возможно.
4. Использовать объект wrdDoc, который вы объявляете и создаете, вместо ActiveDocument.

Этот код отлично работал в моем тесте, но я, конечно, не могу воспроизвести всю вашу среду.

Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String

myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0

If wdApp Is Nothing Then
    ' no current word application
    Set wdApp = CreateObject("Word.application")
    Set wrdDoc = wdApp.Documents.Open(WDoc)
    wdApp.Visible = True
Else
    ' word app running
    For Each tmpDoc In wdApp.Documents
        If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
            ' this is your doc
            Set wrdDoc = tmpDoc
            Exit For
        End If
    Next

    If wrdDoc Is Nothing Then
        ' not open
        Set wrdDoc = wdApp.Documents.Open(WDoc)
    End If
End If

wdApp.Visible = True
wrdApp.Activate

Dim i As Long
Dim objShape2 As Word.Shape
Dim rng As Word.Range

Set rng = wrdDoc.Content
rng.Delete

With rng
    .InsertAfter vbCr
    .Collapse wdCollapseStart

    Set objShape2 = ActiveDocument.Shapes.AddTextbox _
                    (Orientation:=msoTextOrientationHorizontal, _
                     Left:=400, Top:=100, Width:=250, Height:=60, Anchor:=rng)
    With objShape2
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
        .Left = wdShapeRight
        .Top = wdShapeTop
        .TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
        .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
    End With

    rng.Start = ActiveDocument.Content.End

    For i = 1 To 40
        .Text = i & vbCr
        .Collapse wdCollapseEnd
    Next i

End With