Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

20 Сентябрь 2020, 21:47 *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

Войти
Новости: Часто задаваемые вопросы по LibreOffice и Apache OpenOffice.org
 
   Начало   Помощь Поиск Войти Регистрация    задать вопрос  
Страниц: « 1 2 3   Вниз
  Печать  
Автор Тема: Функция Msgbox - не влезает большой текст  (Прочитано 3588 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Tigrik
Форумчанин
***
Offline Offline

Сообщений: 94


« Ответ #55024: 24 Июнь 2020, 01:22 »

В Диалоге с кнопками, все-таки, хотелось что бы была проверка текста (и для сообщения, и для надписей кнопок).
Проверка будет самой простой - влезает ли строка из текста в те ограничения по количеству символов, которые получились в макросе с Диалогом и подсчёт максимальной длины строки в тексте сообщения или на кнопках.
Если строка длиннее, чем ограничитель - MaxChar (это, в основном, будет более актуально для кнопок, если их будет много - они будут не очень широкими), тогда "включается" доп функция SplitBigString.
Она убирает лишние пробелы между словами и если это будет необходимо, то "разобьет" слово, которое длиннее, чем ограничитель. Возможно, в каких-то случаях, будет достаточно "подчистить" в тексте лишние пробелы и обновленная строка влезет в "габариты".
Может такое случится, что к "остатку", который не влез в строку, можно было бы прибавить следующую строку, но я подумал, что это не нужно - пользователь (если таковой найдется, что бы применять эти макросы) в своём тексте мог специально, по своим соображениям, отделять их друг от друга - пусть так и остается. В макросе есть возможность (закомментарил) убирать полностью пустые строки.
Код:
REM  *****  BASIC  *****

Sub CheckStringProc()
Dim MaxChar%, strText$, tt(), s$
strText = InputBox ("Введите любой текст: ", "Проверка функции CorrectText")
MaxChar = InputBox ("Введите число - ограничение на длину строки: ", "Проверка функции CorrectText")
tt() = CorrectText(strText$, MaxChar%)
s = "Было введен текст: " & chr(10) & strText & chr(10) & String(30, "-") & chr(10) & _
"Ограничение по количеству символов в строке: " & MaxChar & chr(10) &_
"Длина введенного текста: " & Len(strText) & chr(10) & chr(10) & _
"ПОЛУЧИЛОСЬ =>" & chr(10) & "Новый текст: " & chr(10) & tt(0) & chr(10) & String(30, "-") & chr(10) & _
"Длина полученного текста: " & Len(tt(0)) & chr(10) & "Максимальная длина строки: "  & tt(1)
Msgbox s
End Sub


Function CorrectText(strText$, MaxChar%) As Object
Dim aBT(), aBW() '   Массивы для строк текста и для слов в строке
Dim sW$, sNew$ '   Строки: каждая строка из старого текста и Новый Текст
Dim MaxLenStr%, sumLens%, strLen%, tempLen% '   Длины: Максимальная, Сумма, Слова в строке, для подсчета Суммы
Dim del$, i%, j%
aBT() = Split(Join(Split(strText, chr(13)), chr(10)), chr(10)) '  Если есть символы chr(13)), то заменяем их на chr(10)
For i = 0 To UBound(aBT()) '  ПО СТРОКАМ
strLen = Len(aBT( i )) '  Длина строки в первоначальном тексте
' If strLen Then '  Можно включить, если нужно убирать полностью пустые строки
'   Если длина строки длиннее MaxChar символов, тогда "Сборка" строки из слов
If strLen > MaxChar Then aBT( i ) = SplitBigString(Trim(aBT( i )), MaxChar)
'   Если обработка строки не помогла
If Len(aBT( i )) > MaxChar Then
sW = ""
aBW() = Split(aBT( i ), " ")
For j = 0 To UBound(aBW()) '   ПО СЛОВАМ
strLen = Len(aBW( j )) '   Длина слова
If sumLens + strLen > MaxChar Then '   Текущее слово уже не влезает в новую строку
tempLen = 0
del = chr(10)
If MaxLenStr < MaxChar Then MaxLenStr = IIf(MaxLenStr < sumLens - 1, sumLens - 1, MaxLenStr)
Else '   Строка ещё не набрана
tempLen = sumLens
del = " "
EndIf
If j = 0 Then del = "" '   В самом начале строки нет разделителя
sW = sW & del & aBW( j ) '   "Накопительная" преобразованная строка из первоначального текста
sumLens = tempLen + strLen + 1
Next
sumLens = 0
Else
sW = aBT( i ) ' Иначе, строка полностью переносится в строку Нового Текста
If MaxLenStr < MaxChar Then MaxLenStr = IIf(MaxLenStr < Len(sW), Len(sW), MaxLenStr)
EndIf
del = IIf(i = 0, "", chr(10)) '   В самом начале нового текста нет разделителя
sNew = sNew & del & sW '   Обработанная строка вошла в новый текст
' EndIf
Next
CorrectText = Array(sNew, MaxLenStr)
End Function


Function SplitBigString(strBigText$, MaxChar%, Optional del$) As String
  Dim aBT(), s$, strElem$, i%, nn%
If IsMissing(del) Then del = " " '   По умолчанию, разделитель в строке - пробел
aBT() = Split(strBigText, del)
nn = UBound(aBT())
For i = 0 To nn
aBT( i ) = Trim(aBT( i ))
If Len(aBT( i )) Then
If Len(aBT( i )) > MaxChar Then strElem = InsertDelWord(aBT( i ), MaxChar, " ") Else strElem = aBT( i )
If i = nn Then del = "" '   В самом конце строки нет разделителя
s = s & strElem & del
EndIf
Next
SplitBigString = s
End Function


Function InsertDelWord(strWord$, MaxChar%, del$) As String
Dim i%, j%, s$
j = Len(strWord)
For i = 1 To j Step MaxChar : s = s & Mid(strWord, i, MaxChar) & del : Next
InsertDelWord = Left(s, j + (j / MaxChar - 0.501)) '   Удаление последнего (лишнего) разделителя
End Function

Первый макрос - он проверочный, только для тестирования. В ходе тестирования, мне было удобнее смотреть: первоначальный текст и его длина и что получилось, если задать определенный ограничитель. Я оставил этот шаблон.

Функция InsertDelWord, хоть и не большая, но мне почему-то думается, что есть стандартная функция или другое решение, но ничего не нашёл. Да, особо и не искал - эта функция на полчаса работы.
Может быть, и функцию SplitBigString, также, можно как-то по другому, попроще "решить" - хотя и так не очень сложно получилось. И получились они немного "универсальными" - можно задавать различные разделители.
Возможно, эти функции можно было через регулярные выражения "пропустить", но я, пока, ими ещё не занимался.

Меня немного "смущает" некоторая громоздкость основной функции CorrectText. Её главная задача - это "собирать" строки из слов - не сложная задача, но получился, на мой взгляд, большой код.
Записан
Страниц: « 1 2 3   Вверх
  Печать  
 
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2009, Simple Machines Valid XHTML 1.0! Valid CSS!