Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подгонка размера шрифта текста под размер текстового блока
 
#1
30.05.2023 20:17:06
Добрый день.
Прошу помочь советом.
Создаю текстовый блок curBlock фиксированных размеров, и вставляю в него текст из переменной curValue
Код
     Set curBlock = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, curLeft, curTop, BLOCK_WIDTH, BLOCK_HIGH)
     curBlock.TextFrame.Characters.Text = curValue
Иногда вставляемый текст выходит за границы текстового блока.
Не могу найти решение, позволяющее подогнать (уменьшить) размер текста в текстовом блоке под его (блока) размер.

curBlock.TextFrame.AutoSize = msoAutoSizeTextToFitShape    не работает. Подгоняет размер блока под размер текста.

Чую, что нужно отловить свойство размера текста (если есть такое), и циклом уменьшать шрифт пока вышеуказанное не станет меньше размеров блока, НО КАК? (с) Докторватсон.

Заранее спасибо всем откликнувшимся.
Изменено: Владимир_с_добавкой - 30.05.2023 22:19:37
 
 
 
#2
01.06.2023 12:21:39
Up
Вопрос крайне актуален.
Спасибо!
 
 
 
#3
01.06.2023 14:38:05
предлагаю посчитать число знаков в тексте и размер ячейки (в пунктах кажется но не важно)
Вычислить размер шрифта=размер ячейки/число знаков*(константа)
константа -подобрать опытным путем
в формате ячейки указать расчитанный размер шрифта
Метод не идеален т.к. место занимаемое отдельной буквой (цифрой) в пунктах разное, пример "Ж"  и "Е", средне статистически рабочий.
 
Изменено: звездочка яркая - 01.06.2023 14:47:13
 
 
 
#4
01.06.2023 15:07:08
Если текст многострочный (длинный, в одну строку не влазит), - то никак (ибо при любой ширине блока он по ширине не взелет)
Если же текст должен умещаться в одну строку, то всё просто делается, как вы и сказали, в цикле
Примерно так:
Код
Set curBlock = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, curLeft, curTop, BLOCK_WIDTH, BLOCK_HIGH)
With curBlock.TextFrame
    .Characters.Text = curValue
    .AutoSize = True
    Do While curBlock.Width > BLOCK_WIDTH ' уменьшаем шрифт до тех пор, пока ширина блока не станет подходящей
        .Characters.Font.Size = .Characters.Font.Size - 1
        .AutoSize = True
    Wend
    curBlock.Width = BLOCK_WIDTH ' увеличиваем ширину до заданной
End With
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#5
02.06.2023 16:23:57
Игорь, звездочка яркая, спасибо.
К сожалению текст в несколько строк. Переносится.
В итоге пришел практически к такому же решению, как предложила звездочка яркая
 
 
 
#6
02.06.2023 21:05:46
Вариант Игоря можно подправить. Проверяйте:
Код
Option Explicit

' Возвращает Text box с заданным местоположением и текстом.
' Размер шрифта текста подгоняется под заданные размеры.
Function AddTextBox(ByVal Left, ByVal Top, ByVal Width, ByVal Height, ByVal Text As String) As Object
  Dim curBlock As Object
  Set curBlock = ActiveSheet.Shapes.AddTextBox(msoTextOrientationHorizontal, Left, Top, Width, Height)
  With curBlock.TextFrame
    .Characters.Text = Text
    .AutoSize = True
    curBlock.Width = Width
    curBlock.TextFrame2.WordWrap = msoTrue
    Do While curBlock.Height > Height ' уменьшаем шрифт до тех пор, пока ширина блока не станет подходящей
        .Characters.Font.Size = .Characters.Font.Size - 1
        curBlock.Width = 100
    Loop
  End With
  Set AddTextBox = curBlock
End Function

Sub Test()
 AddTextBox 0, 0, 100, 100, "Иногда вставляемый текст выходит за границы текстового блока. " & Chr(10) & _
   "Не могу найти решение, позволяющее подогнать (уменьшить) размер текста в текстовом блоке под его (блока) размер."
End Sub
Владимир
 
 
 
Страницы: 1
Читают тему
Наверх