Надпись На Каждой Странице Документа

[Bob84]

Здравствуйте.
Есть вордовский документ, в котором на каждой странице вставлено изображение.
Макросом рисую поверх изображения надписи на каждой странице:

Раскрывающийся Текст

Sub inscription()
NumberOfPages = Selection.Information(wdNumberOfPagesInDocument)

For CurrentPage = 1 To NumberOfPages
If CurrentPage = 1 Then
Call Selection.GoTo(wdGoToSection, wdGoToFirst)
End If

'================================================================
STAMP_TEXT1 = "Какой-то текст"
Dim shp1 As Shape

Set shp1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
10, 10, Application.InchesToPoints(6), Application.InchesToPoints(10.7))

shp1.Select

Selection.InsertAfter (STAMP_TEXT1)

shp1.Line.Visible = msoFalse
shp1.TextFrame.VerticalAnchor = msoAnchorBottom
'================================================================
Set shp1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Application.InchesToPoints(6.5), _
Application.InchesToPoints(10), _
Application.InchesToPoints(1.5), Application.InchesToPoints(1))

shp1.Select

Selection.InsertAfter (CurrentPage)

shp1.Line.Visible = msoFalse
shp1.TextFrame.VerticalAnchor = msoAnchorBottom
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
'================================================================

Call Selection.Collapse(wdCollapseEnd)
Call Selection.GoTo(wdGoToPage, wdGoToNext, 1)

Next

Call Selection.Collapse(wdCollapseEnd)

End Sub

По какой-то причине код последнюю надпись рисовал на предыдущей странице. Дополнил код вначале добавлением разрыва строки и удалением пустых страниц после цикла.
Код

Call Selection.GoTo(wdGoToPage, wdGoToLast)
Selection.EndKey Unit:=wdStory
Selection.insertbreak Type:=wdPageBreak

добавил к документы аж две страницы (которые потом кодом же удалял).
После этого такая ошибка перестала проявлятся.
Собственно вопрос почему в каких-то случаях не удается добавить надпись на последнюю страницу?
Спасибо.

 

[hosm]

Посмотри на якорную точку изображения - расположена ли она на последней странице, а также параметры обтекания текстом - возможно, надпись почему-то помещается до изображения. Также есть параметры абзаца, отвечающие за переход на новую страницу и обработку "висячих строк". Замечала, что не всегда корректно проставляется стиль последнего параграфа, иногда сбрасывается на дефолтный. И 2 страницы что-то многовато, одна добавленная должна была помочь. Возможно, просто стоит добавить абзац, к которому прикрепится надпись. Возможно, надпись с изображением не помещаются на странице при определенном режиме просмотра текста? Да и на последней странице вроде как бессмысленно переходить на следующую

 

[Bob84]

Понял, буду копать.
Спасибо

 

[Bob84]

Собственно мне этот макрос был нужен для перевода его потом на LotusScript. Вот что вышло

Раскрывающийся Текст

'высота и ширина для разных ориентаций документа в inches, для A4
Private Const W_PORTRAIT = 8
Private Const H_PORTRAIT = 11
Private Const W_LANDSCAPE = 11
Private Const H_LANDSCAPE = 8
' настройки шрифта для штампа в надписи
Private Const STAMP_FontName = "Arial"
Private Const STAMP_FontSize = 12
Private Const STAMP_FontColor = 16646144
Private Const STAMP_PageNumColor = wdColorBlack
' отступы для надписи, верхняя,нижняя, левая и правая актуальны для tif, tiff и docx. Для doc надпись ужимается до размера текста и выравнивается по нижней границе, т.е. влияют только левая и правая границы
Private Const TXTBOX_LEFT = 0.5 ' отступ слева для надписи
Private Const TXTBOX_TOP = 0.5 ' отступ сверху для надписи
Private Const TXTBOX_RIGHT = 0.5 ' отступ справа для надписи
Private Const TXTBOX_BOTTOM = 0.1 ' отступ снизу для надписи

Sub AddStamp( oWord as Variant, oDoc As Variant, StampText as String, StartPageNum	as Integer )
%REM
ИИС 121213		
%END REM
Dim P_Height As Integer
Dim P_Width As integer
Dim AddedText As string
Dim CurrPageNum As Integer
Dim CurrentPage As Integer
Dim NumberOfPages As Integer
Dim shp As Variant
Dim tstr As string
Dim Version As Integer

On Error GoTo errsub

P_Width = W_PORTRAIT '8
P_Height = H_PORTRAIT '11
If oDoc.PageSetup.Orientation = wdOrientLandscape Then
P_Width = W_LANDSCAPE '11
P_Height = H_LANDSCAPE '8
End If

CurrPageNum = 0
AddedText = StampText 
If AddPageNum Then
CurrPageNum = StartPageNum		
End If
If Len( AddedText ) = 0 Then
If CurrPageNum = 0 Then
Exit Sub
End If		
End If
'Stop
'oDoc.Application.Visible = true
' цикл по страницам
tstr = oWord.Version
If Len( strleft( tstr, "." ) ) > 0 Then
tstr = StrLeft( tstr, "." )
End If
Version = CInt( tstr ) ' 12 2007 14 2010
NumberOfPages = oDoc.ComputeStatistics(2)
tstr = "/" & CStr(NumberOfPages)
For CurrentPage = 1 To NumberOfPages
Print "Страница " & CStr( CurrentPage ) & tstr
If CurrentPage = 1 Then
Call oWord.Selection.GoTo(wdGoToSection, wdGoToFirst)
End If

Set shp = oDoc.Shapes.AddTextbox(msoTextOrientationHorizontal, _
oWord.InchesToPoints(TXTBOX_LEFT),_ 'Left
oWord.InchesToPoints(TXTBOX_TOP),_ ' Top
oWord.InchesToPoints(CDbl(P_Width) - TXTBOX_RIGHT),_ ' Width
oWord.InchesToPoints(CDbl(P_Height)-TXTBOX_BOTTOM)) ' Height

shp.Select

oWord.Selection.InsertAfter ( AddedText )

shp.Line.Visible = msoFalse
If Version >= 14 Then ' 2010 end higher
shp.TextFrame.VerticalAnchor = msoAnchorBottom
End If

oWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight

oWord.Selection.Font.Name = STAMP_FontName
oWord.Selection.Font.Size = STAMP_FontSize
oWord.Selection.Font.Color = STAMP_FontColor

If CurrPageNum > 0 Then
Call oWord.Selection.MoveRight( wdCharacter, 1 )
oWord.Selection.InsertAfter ( Chr(10) & Chr(10) & CStr( CurrPageNum ) )
oWord.Selection.Font.Color = STAMP_PageNumColor
End If

If LCase( Strrightback( oDoc.Name, "." ) ) = "doc" Then 'Or oDoc.CompatibilityMode = 11 Then
Call shp.ZOrder( 5 )
shp.TextFrame.AutoSize = True
shp.LayoutInCell = false
shp.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
shp.Top = wdShapeBottom
End If

Call oWord.Selection.Collapse(wdCollapseEnd)
Call oWord.Selection.GoTo(wdGoToPage, wdGoToNext, 1)
If CurrPageNum > 0 Then
CurrPageNum = CurrPageNum + 1
End If	

Next
Call oWord.Selection.Collapse(wdCollapseEnd)

endsub:	
Exit sub
errsub:
MsgBox "SL PrintLib >> Sub AddStamp >> Error " & Error & " on " & erl
Resume endsub
End Sub

Может будет кому-то полезно