как провести графич.линию через сердину клекти таблицы?

[viter.alex]

Решение для вертикальных линий я нашел. Приду домой, тогда отпишусь. Это будет часов в 9 по Москве

[tolikman]

спасибо, буду ждать.)

[viter.alex]

Ну, приблизительно так. Для столбцов работает. Будем думать для строк.

Option Explicit

Sub Макрос2()
'
' Макрос2 Макрос
'
'
  Dim oCurrTable As Table 'указатель на текущую таблицу
  Dim oCurrCol As Column 'указатель на текущий столбец в таблице
  Dim oCurrRow As Row 'указатель на текущую строку в таблице
  Dim oAnchor As Range 'якорь для привязки линии к тексту
  Dim nTableHeight, _
      nTableWidth As Integer 'счетчики ширины и высоты таблицы
  'Переменные, в которые будем записывать начальное значение координаты Y для вертикальной линии,
  'координаты X для горизонтальной линии, ширину горизонтальной линии и длину вертикальной линии.
  Dim nYStartPoint, nXStartPoint, nWidthOfLine, nLenghtOfLine
  Dim oLine As Shape
  For Each oCurrTable In ActiveDocument.Tables
    nTableHeight = 0
    nTableWidth = 0
    oCurrTable.Rows.HeightRule = wdRowHeightAtLeast
    oCurrTable.Cell(1, 1).Select
    'считаем ширину таблицы
    For Each oCurrCol In oCurrTable.Columns
      nTableWidth = nTableWidth + oCurrCol.Width
    Next oCurrCol
    'считаем высоту таблицы
    For Each oCurrRow In oCurrTable.Rows
      nTableHeight = nTableHeight + oCurrRow.Height
    Next oCurrRow
    'перебираем столбцы
    For Each oCurrCol In oCurrTable.Columns
      'положение Y
      nYStartPoint = PointsToPixels(MillimetersToPoints(5))
      'длина линии
      nLenghtOfLine = PointsToPixels(nTableHeight) ' + Abs(nYStartPoint)
      'снять выделение с ячейки
      Selection.HomeKey
      'Якорь к ячейке
      Set oAnchor = Selection.Range
      'Рисуем линию
      Set oLine = ActiveDocument.Shapes.AddLine _
                  (0, _
                  -1 * nYStartPoint, _
                  0, _
                  nLenghtOfLine, oAnchor)
      'выравниваем линию относительно центра колонки
      oLine.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
      oLine.Left = wdShapeCenter
      'запрет на перемещение линии мышкой
      oLine.LockAnchor = True
      oLine.LayoutInCell = True
      'если находимся не в последнем столбце, то выбираем следующий
      If Not (oCurrCol.IsLast) Then
        oCurrTable.Columns(oCurrCol.Index).Next.Select
        Selection.HomeKey
      End If
    Next oCurrCol
  Next oCurrTable
End Sub

[viter.alex]

Смотри в приложенном файле готовый макрос.
Но есть один баг, по всей видимости, самого Word'a.
Для того, чтобы выровнять линии относительно ячейки таблицы, нужно ей задавать разметку в ячейке таблицы.

oLine.LayoutInCell = True

Но при этом происходит смещение текста в ячейке вверх. В файле это хорошоо видно для таблицы с широкими строками. Если в твоем файле все строки узкие, то на это можно не обращать внимание.
Еще непонятно, что происходит с точкой начала по Y для вертикальной линии. В таблице с широкими строками рисует как надо, а вот с узкими — заметно, что верхний выступ больше, чем нижний. Тоже самое происходит и с горизонтальными линиями. Может как-то нужно подшаманить с началом координат? Пробуй.
Кстати, там в макросах я написал процедуру для очистки документа от всех линий. Для отладки. Это лучше, чем руками их вытирать каждый раз.

[EducatedFool]

Я тут тоже пытался кое-что сделать.
Взял за основу твой вариант.

Получилось вот что:

Основной макрос, предварительно подготавливающий таблицу:

Sub Main()
    RemoveLines    ' удаляем старые линии

    Dim t As Table: Set t = ActiveDocument.Tables(1)
    With t.Rows
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        .HeightRule = wdRowHeightExactly
        .HorizontalPosition = 0: .VerticalPosition = 0
    End With

    ДобавитьЛинию t, 2, -1    ' линия через 2-ю строку
    ДобавитьЛинию t, 3, -1    ' линия через 3-ю строку
    ДобавитьЛинию t, -1, 2    ' линия через 2-й столбец
    ДобавитьЛинию t, -1, 4    ' линия через 4-й столбец

End Sub

Sub RemoveLines()
    For Each Line In ActiveDocument.Shapes: Line.Delete: Next
End Sub

И, собственно, сама процедура добавления строк:

Sub ДобавитьЛинию(ByRef t As Table, ByVal ro As Long, ByVal col As Long)
    delta = MillimetersToPoints(5)

    Dim oCurrCol As Column, oCurrRow As row, oAnchor As Range, oLine As Shape
    Dim nTableHeight, nTableWidth As Long       'счетчики ширины и высоты таблицы

    Application.Options.MeasurementUnit = wdPoints: Application.ScreenUpdating = False

    With t
        y = .Rows.VerticalPosition: x = .Rows.HorizontalPosition

        'считаем ширину таблицы
        For Each oCurrCol In .Columns: nTableWidth = nTableWidth + oCurrCol.Width: Next oCurrCol
        'считаем высоту таблицы
        For Each oCurrRow In .Rows: nTableHeight = nTableHeight + oCurrRow.Height: Next oCurrRow

        If ro > 0 And ro <= .Rows.Count Then
            Set oCurrRow = .Rows(ro)

            oCurrRow.Cells(1).Select: Selection.HomeKey    'снять выделение с ячейки
            Set oAnchor = Selection.Range    'Якорь к ячейке

            Set oLine = ActiveDocument.Shapes.AddLine(x - delta, y, x + nTableWidth + delta, y, oAnchor)   'Рисуем линию

            'выравниваем линию относительно центра строки
            oLine.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
            oLine.RelativeVerticalPosition = wdRelativeVerticalPositionLine
            oLine.Top = oLine.Top - oCurrRow.Height / 2           'wdShapeCenter

            oLine.LockAnchor = True: oLine.LayoutInCell = True    'запрет на перемещение линии мышкой
        End If

        If col > 0 And col <= .Columns.Count Then
            Set oCurrCol = .Columns(col)

            oCurrCol.Cells(1).Select: Selection.HomeKey    'снять выделение с ячейки
            Set oAnchor = Selection.Range    'Якорь к ячейке

            Set oLine = ActiveDocument.Shapes.AddLine(0, y - delta, 0, y + nTableHeight + delta, oAnchor)    'Рисуем линию

            'выравниваем линию относительно центра колонки
            oLine.Left = wdShapeCenter

            oLine.LockAnchor = True: oLine.LayoutInCell = True    'запрет на перемещение линии мышкой
        End If

        If Not oLine Is Nothing Then
            oLine.Line.ForeColor.RGB = RGB(0, 0, 255)    'изменим цвет линии
            oLine.Line.Weight = 2    'изменим толщину линии
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Получается примерно вот что:

[viter.alex]

А с несколькими таблицами пробовал его запускать?
Когда ты выравниваешь таблицу

      .Rows.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
      .Rows.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin

,
то теряется изначальное ее расположение, что не есть хорошо.
А сама идея с заданием строки и столбца — хороша+1

[EducatedFool]

Когда ты выравниваешь таблицу, то теряется изначальное ее расположение, что не есть хорошо.

Знаю, что теряется. Знаю, что нехорошо
По-другому просто никак не получилось сделать...

Когда я увидел эту тему, решил, что за пару минут напишу макрос.
Делов-то - получить координаты верхнего левого угла таблицы, и размеры строк и столбцов.

Через пару часов я понял, что не всё так просто...

[viter.alex]

Сообщение от EducatedFool

…
Через пару часов я понял, что не всё так просто...

Все очень непросто. Нужно кроме положения левого верхнего угла таблицы и ее ширины и высоты, учитывать и границы текста LeftPadding, RightPadding для первого и последнего столбца, и TopPadding, BottomPadding для первой и последней строки.

[tolikman]

Большое спасибо Вам viter.alex и EducatedFull! постараюсь разобраться и при положительном резульате выложу сюда финальную процедуру.

[viter.alex]

Можно избавиться от смещения текста после вставки линии, если все линии сгруппировать!
Проблема в том, как их группировать? Есть метод ShapeRange.Group. Нужно выбирать линии индивидуально для каждой таблицы. Как?