Иной раз требуется текст нарезать на части и вывести эти части, каждую в своем поле, при этом эти части не должны превышать размер поля. Данная процедура режет текст на части и вставляет в указанные поля
Процедура деления текста на части по размеру и по количеству полей, в которые их (части) требуется вписать. Еще одна реализация решения от Igor V. Makeev Описание: Иной раз требуется текст нарезать на части и вывести эти части, каждую в своем поле, при этом эти части не должны превышать размер поля. К сожалению, стандартный контрол TextBox не дает возможность выводить вторую строку с отступом. А если навставлять пробелов, то надо еще определить, какое слово перенесется на следующую строку. Что бы было понятнее, как пример приведу документ 'Взнос наличных на р/счет', российскую реализацию, где вторую строку суммы прописью, слева, загораживает надпись 'Сумма прописью'. Данная процедура режет текст на части и вставляет в указанные поля. Аргументы процедуры: strDividedString - Текст, который необходимо разделить на части varArr - Массив из полей, куда необходимо вписать части строк varArrStr - Массив из строк, которые не должны отделяться (Необязательный) Private Type SIZE cx As Long cy As Long End Type Private Declare Function GetDC Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" _ (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" _ (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function GetTextExtentPoint32 Lib "gdi32" _ Alias "GetTextExtentPoint32A" _ (ByVal hdc As Long, ByVal lpsz As String, _ ByVal cbString As Long, lpSize As SIZE) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _ (ByVal h As Long, ByVal W As Long, ByVal E As Long, _ ByVal O As Long, ByVal W As Long, ByVal I As Long, _ ByVal u As Long, ByVal s As Long, ByVal C As Long, _ ByVal OP As Long, ByVal CP As Long, ByVal q As Long, _ ByVal PAF As Long, ByVal F As String) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Public Sub DivideString(strDividedString As String, _ varArr As Variant, _ Optional varArrStr As Variant) On Error GoTo Err_ Dim dc As Long Dim varA As Variant, varAS As Variant Dim strText As String, intRev As Integer Dim lPixelPerInchX Dim lFont As Long, lFontOld As Long, splen As Long Dim sz As SIZE Const LOGPIXELSY = 90 Const LOGPIXELSX = 88 dc = GetDC(0) strText = strDividedString & " " For Each varA In varArr With varA 'Отбрасываем слова, пока не поместится Do Line1: intRev = InStrRev(strText, " ") If intRev = 0 Then strText = vbNullString: Exit Do 'Если есть список непереносимых слов, то ... If VarType(varArrStr) >= vbArray Then '... перебираем его и ... For Each varAS InvarArrStr '... сравниваем с отброшенным словом 'Если отбрасывается непереносимое слово. If StrComp(varAS, Mid$(strText, intRev + 1), vbTextCompare) = 0 Then strText = Left$(strText, intRev - 1) GoTo Line1 End If Next End If strText = Left$(strText, intRev - 1) splen = Len(strText) If splen = 0 Then splen = 1 lPixelPerInchX = GetDeviceCaps(dc, LOGPIXELSX) lFont = CreateFont(-(.FontSize * GetDeviceCaps(dc, LOGPIXELSY)) / 72, _ 0, 0, 0, .FontWeight, 0, 0, 0, _ 1, 0, 0, 0, 2, .FontName) lFontOld = SelectObject(dc, lFont) GetTextExtentPoint32 dc, strText, splen, sz SelectObject dc, lFontOld DeleteObject lFont Loop Until ((((sz.cx + (sz.cx / splen)) / lPixelPerInchX) * 1440) < .Width) .Value = strText End With strDividedString = Mid$(strDividedString, intRev + 1) strText = strDividedString & " " Next Ex_: SelectObject dc, lFontOld DeleteObject lFont ReleaseDC 0, dc Exit Sub Err_: MsgBox Err.Description Resume Ex_ End Sub
|
Пример использования Dim a(2) As Variant Dim s As Variant Set a(0) = Me.Поле0 Set a(1) = Me.Поле3 Set a(2) = Me.Поле5 s = Array("руб.", "коп.") DivideString "Текст требуемый нарезать", a, s |
Пример использования в форме и отчете можно взять здесь ... (29 Kb) Просмотров: 8481
Ваш коментарий будет первым | | |