Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 25 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 09.01.2009, 18:13   #11
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: viter.alex
По умолчанию

Решение для вертикальных линий я нашел. Приду домой, тогда отпишусь. Это будет часов в 9 по Москве
__________________
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума   Ответить с цитированием
Старый 09.01.2009, 18:59   #12
tolikman
Форумчанин
 
Регистрация: 25.08.2008
Сообщений: 159
Репутация: 73
По умолчанию

спасибо, буду ждать.)
tolikman вне форума   Ответить с цитированием
Старый 09.01.2009, 23:51   #13
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: 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 вне форума   Ответить с цитированием
Старый 10.01.2009, 11:28   #14
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: viter.alex
По умолчанию Почти окончательный результат

Смотри в приложенном файле готовый макрос.
Но есть один баг, по всей видимости, самого Word'a.
Для того, чтобы выровнять линии относительно ячейки таблицы, нужно ей задавать разметку в ячейке таблицы.
Код:
oLine.LayoutInCell = True
Но при этом происходит смещение текста в ячейке вверх. В файле это хорошоо видно для таблицы с широкими строками. Если в твоем файле все строки узкие, то на это можно не обращать внимание.
Еще непонятно, что происходит с точкой начала по Y для вертикальной линии. В таблице с широкими строками рисует как надо, а вот с узкими — заметно, что верхний выступ больше, чем нижний. Тоже самое происходит и с горизонтальными линиями. Может как-то нужно подшаманить с началом координат? Пробуй.
Кстати, там в макросах я написал процедуру для очистки документа от всех линий. Для отладки. Это лучше, чем руками их вытирать каждый раз.
Вложения
Тип файла: doc таблицы и линии.doc (64.0 Кб, 15 просмотров)
__________________
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума   Ответить с цитированием
Старый 10.01.2009, 11:57   #15
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,837
Репутация: 1220

skype: ExcelVBA.ru
По умолчанию 2 viter.alex

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

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

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

Код:
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
Получается примерно вот что:

EducatedFool вне форума   Ответить с цитированием
Старый 10.01.2009, 12:51   #16
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: viter.alex
По умолчанию 2 [B]EducatedFool[/B]

А с несколькими таблицами пробовал его запускать?
Когда ты выравниваешь таблицу
Код:
      .Rows.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
      .Rows.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
,
то теряется изначальное ее расположение, что не есть хорошо.
А сама идея с заданием строки и столбца — хороша+1
__________________
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума   Ответить с цитированием
Старый 10.01.2009, 15:55   #17
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,837
Репутация: 1220

skype: ExcelVBA.ru
По умолчанию 2 viter.alex

Цитата:
Когда ты выравниваешь таблицу, то теряется изначальное ее расположение, что не есть хорошо.
Знаю, что теряется. Знаю, что нехорошо
По-другому просто никак не получилось сделать...

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

Через пару часов я понял, что не всё так просто...
EducatedFool вне форума   Ответить с цитированием
Старый 10.01.2009, 16:42   #18
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: viter.alex
По умолчанию

Цитата:
Сообщение от EducatedFool Посмотреть сообщение

Через пару часов я понял, что не всё так просто...
Все очень непросто. Нужно кроме положения левого верхнего угла таблицы и ее ширины и высоты, учитывать и границы текста LeftPadding, RightPadding для первого и последнего столбца, и TopPadding, BottomPadding для первой и последней строки.
__________________
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума   Ответить с цитированием
Старый 10.01.2009, 18:47   #19
tolikman
Форумчанин
 
Регистрация: 25.08.2008
Сообщений: 159
Репутация: 73
По умолчанию

Большое спасибо Вам viter.alex и EducatedFull! постараюсь разобраться и при положительном резульате выложу сюда финальную процедуру.
tolikman вне форума   Ответить с цитированием
Старый 11.01.2009, 04:04   #20
viter.alex
Балуюсь кодами
Профессионал
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Адрес: Харків, Україна
Сообщений: 1,803
Репутация: 716

icq: 194381182
skype: viter.alex
По умолчанию Решение для смещения текста

Можно избавиться от смещения текста после вставки линии, если все линии сгруппировать!
Проблема в том, как их группировать? Есть метод ShapeRange.Group. Нужно выбирать линии индивидуально для каждой таблицы. Как?
__________________
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Отправка SMS через клик по строке таблицы RUBEY Microsoft Office Excel 4 25.12.2008 12:07
Как нарисовать линию по пикселям DenLab Общие вопросы Delphi 4 03.12.2008 10:34
Как же нарисовать линию на форме? (Вопрос новичка) grey Помощь студентам 11 24.11.2008 11:31
хочу стереть линию с канвы.КАК? harmager Общие вопросы Delphi 1 24.11.2008 11:28


06:57.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.