Создание "уголка" на всех страницах

[DrManual]

Здравствуйте, All!

Просьба. Помогите сделать следующее форматирование - на всех страницах в правом верхнем уголке должно быть пустое поле. Размер 1.0Х0.5см

Прилагаю конечный вид (сделано с помощью переноса вручную "надписи")




Спасибо заранее за терпимость к тупости.

[viter.alex]

Штатными средствами это сделать не получится. Можно, конечно, поместить пустое текстовое поле в колонтитул, и оно будет отображаться на каждой странице. Но текст вокруг него обтекать не будет. Могу предложить такой макрос:

Sub InsertBlankFieldToTopRightConerOfEveryPage()
  Dim PagesCount%, i%, oRng As Range, iLeft#, DocUnit%
  'Определяем количество страниц в документе
  PagesCount = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)
  Set oRng = ActiveDocument.Content
  'Переводим единицы измерения в точки
  DocUnit = Options.MeasurementUnit: Options.MeasurementUnit = wdPoints
  For i = 1 To PagesCount
    'Считаем положение правого верхнего угла страницы
    With oRng.Sections(1).PageSetup
      iLeft = .PageWidth - .LeftMargin - .RightMargin
    End With
    'Добавляем текстовое поле
    With ActiveDocument.Shapes.AddTextbox _
              (msoTextOrientationHorizontal, _
              iLeft - CentimetersToPoints(1), _
              0, _
              CentimetersToPoints(1), _
              CentimetersToPoints(0.5), _
              oRng)
      'Имя фигуры, чтобы можно было ее удалить не трогая другие.
      .Name = "Blank" & i
      'Убираем у поля границы
      .Line.Visible = False
      'Ставим привязку к странице
      .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      'Устанавливаем обтекание текстом
      With .WrapFormat
        .AllowOverlap = True
        .DistanceBottom = 0: .DistanceLeft = 3: .DistanceRight = 0: .DistanceTop = 0
        .Type = wdWrapSquare: .Side = wdWrapLeft
      End With
    End With
    'Переходим на следующую страницу
    Set oRng = oRng.GoToNext(1) 'wdGoToPage
  Next i
  'Восстанавливаем единицы измерения.
  Options.MeasurementUnit = DocUnit
End Sub

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

Добавлено позже
После вставки строк, выделенных жирным, можно добавлять абзацы и поле смещаться не будет. Но при добавлении страницы, придется запустить макрос снова, предварительно удалив все уголки.

Добавлено еще позднее
А этот макрос удалит все наши фигуры.

Sub RemoveBlankFieldFromTheTopRightConerOfEveryPage()
  Dim i%
  For i = ActiveDocument.Shapes.Count To 1 Step -1
    If ActiveDocument.Shapes(i).Name Like "Blank*" Then _
      ActiveDocument.Shapes(i).Delete
  Next i
End Sub

[DrManual]

Работает ОБАЛДЕННО!
Спасибо!

[psa247]

Привет !
Мне надо картинку поставить в определенное место в Ворде. С Left - разобрался. А как вычислить Тор. Я бы привязался бы к Тор какого-нибудь объекта. Но, к сожалению, здесь и остановился

[viter.alex]

А в чём проблема?

[psa247]

Проблема:

У меня есть таблица из 3-х колонок с параметрами. Во 2 колонке нужно вставить рисунок. Left для фигуры-картинки я нашел как лево таблицы+ширину 1-го столбца. Тор у таблицы находится относительно последнего абзаца. (В свойствах таблицы так указано) Соответственно, чтобы закрыть этот вопрос осталось узнать Тор для последнего абзаца хоть в поинтах, чтоль ? Как - не знаю

[viter.alex]

Зачем же вставлять картинку как Shape? Её нужно вставлять в текст. Тогда она будет жёстко привязана к абзацу. Смотри пример.

[psa247]

А как вставить картинку в текст с помощью ВБА ? Именно так, именно в эту таблицу ?

[psa247]

Есть внешняя картинка, которую надо вставить в определенную ячейку таблицы. Я пошел другим путем. Вставлял, делал ее шейпом. Менял ZOrder и перемещал от краем документа. Уперся в Тор

Как получить таблицу - тоже знаю, но как вставить в нее картинку ?

[viter.alex]

Если курсор будет в таблице, то картинка вставится во второй столбец первой строки

Sub InsertPictureInTable()
  If Selection.Information(wdWithInTable) Then
    Selection.Tables(1).Cell(1, 2).Range.InlineShapes.AddPicture ("Путь к картинке")
  End If
End Sub