Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Вписывание текста в прямоугольник, с сохранением формата текста.
 
Добрый вечер.
У меня есть макрос расставляющий по листу прямоугольники.
Данные по прямоугольникам идут в таблице.

Подскажите - как в эти прямоугольники вписать  текст того форматирования (размер шрифта,цвет,курсив,подчеркивание, жирность), которое представлено в таблице ?
Текст указан в строке 8.
 
Попробуйте:
Код
Option Explicit

Sub Makros2()
Dim i As Long, lastcol As Long, dl As Long
Dim c_x1y1, c_x2y2, Color1
Dim tekst As String
Dim objtekst As Font

Static j As Long

    With ActiveSheet 'ili With Sheets("Variant 1")
        lastcol = .Range("a1").CurrentRegion.Columns.Count
        
        c_x1y1 = .Range(.Cells(2, 2), .Cells(3, lastcol)).Value
        c_x2y2 = .Range(.Cells(5, 2), .Cells(6, lastcol)).Value
        Color1 = .Range(.Cells(7, 2), .Cells(7, lastcol)).Value
        
        lastcol = lastcol - 1
        
        For i = 1 To lastcol
            j = j + 1
            
            With .Cells(8, i + 1)
                tekst = .Value
                dl = Len(tekst)
                Set objtekst = .Font
            End With
            
            .Shapes.AddShape(msoShapeRectangle, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i)).Name = "prugol" & CStr(j)
            
            With .Shapes("prugol" & CStr(j))
                With .TextFrame
                    .Characters.Text = tekst
                    With .Characters(Start:=1, Length:=dl).Font
                        .Name = objtekst.Name
                        .Size = objtekst.Size
                        .ColorIndex = objtekst.ColorIndex
                        .Italic = objtekst.Italic
                        .Bold = objtekst.Bold
                        .Underline = objtekst.Underline
                    End With
                    Set objtekst = Nothing
                End With
                
                With .Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = Cells(7, i + 1).Interior.Color
                    .Transparency = 0
                End With
            End With
        Next
    End With
End Sub
Изменено: ocet p - 14 Апр 2018 03:51:57
 
ocet p, почему-то при увеличенной таблице начинает выдавать ошибку:
"Run-time error 1004. Указанное значение выходит за допустимые пределы."

Размещает при этом - максимум 7 прямоугольников с текстом - не больше.
 
:)
Вы хотели присвоить отрицательное значение высоты: -10, -20, -30, -40 - это невозможно.

пс:
под декларацию "Option Explicit" введите ещё "Option Base 1" чтобы было:
Код
Option Explicit
Option Base 1

будет отсчитываться в vba от 1, а не от 0, это будет "безопаснее"
 
ocet p, теперь все стало ясно.
Большое вам спасибо за помощь.
Страницы: 1
Читают тему (гостей: 1)
Наверх