Question

所以我编写了一个模块，将文本分成多行，模仿自动换行。每行文本都成为一个数组中的项目，以后可以用于填充文本框，列表框等等。我想知道是否有办法根据行的可见长度而不是字符数来执行此操作。由于某些字符在大多数字体中比其他字符宽，我发现我的方法是根据字符串长度打破文本有时不可靠。这是我的代码：

Function breakText( _
ByVal textToRead As String, _
ByVal lineLength As Integer, _
Optional ByVal NoTrailingReturns As Boolean = True, _
Optional ByVal NoLeadingReturns As Boolean = False, _
Optional ByVal MaxNumbLines As Integer = -1 _
) As Variant
On Error GoTo err_breakText

Dim intSegmentLength As Integer
Dim intLineNumb As Integer
Dim strTextSegment As String
Dim strTextArray() As String

'Clear leading and trailing spaces
textToRead = Trim(textToRead)

'Replace all CrLf and isolated Lf with Cr's
textToRead = Replace(textToRead, vbCrLf, vbCr)
textToRead = Replace(textToRead, vbLf, vbCr)

'Clear unwanted LF/CR if NoTrailingReturns = true and/or NoTrailingReturns = true
If NoTrailingReturns = True Then
    While Right(textToRead, 1) = vbCr
        textToRead = Left(textToRead, Len(textToRead) - 1)
    Wend
End If
If NoLeadingReturns = True Then
    While Left(textToRead, 1) = vbCr
        textToRead = Right(textToRead, Len(textToRead) - 1)
    Wend
End If
textToRead = Trim(textToRead)

'Make sure we have a string to work with
If Len(textToRead) = 0 Then Err.Raise vbObjectError + 200, , "No text to read"

'Break text into lines and populate temp array
ReDim strTextArray(1)
intLineNumb = 1
Do
    'Take a section of the total string to process
    strTextSegment = Left(textToRead, lineLength + 1)
    'Determine the condition that ends the current line
    If InStrRev(strTextSegment, vbCr) > 0 Then
        'There is a CR in the string
        intSegmentLength = InStr(1, strTextSegment, vbCr)
        strTextSegment = Left(strTextSegment, intSegmentLength - 1)
    ElseIf Len(textToRead) < lineLength + 1 Then
        'The string is shorter than the line length
        intSegmentLength = Len(textToRead)
        strTextSegment = textToRead
    ElseIf InStrRev(strTextSegment, " ") Then
        'There is a space in the string
        intSegmentLength = InStrRev(strTextSegment, " ")
        strTextSegment = Left(strTextSegment, intSegmentLength - 1)
    Else
        'There are no breaks in the string
        intSegmentLength = lineLength
        strTextSegment = Left(strTextSegment, intSegmentLength)
    End If

    'Remove unwanted leading/trailing spaces from the redefined segment
    strTextSegment = Trim(strTextSegment)
    'Redefine and add the segment to the array
    ReDim Preserve strTextArray(0 To intLineNumb)
    strTextArray(intLineNumb) = strTextSegment
    'Remove the current segment from the remaining text and trim spaces
    textToRead = Right(textToRead, Len(textToRead) - intSegmentLength)
    textToRead = Trim(textToRead)
    intLineNumb = intLineNumb + 1

    'Check to see if we have any more lines available to populate
    'MaxNumbLines = -1 means there is no line count limit
    If intLineNumb > MaxNumbLines And MaxNumbLines > 0 Then
        Err.Raise vbObjectError + 100, , "Max line count met"
    End If
    If Len(textToRead) = 0 Then Exit Do

Loop

res_breakText:
    breakText = strTextArray
    Exit Function

err_breakText:

MsgBox Err.Description, , "Error " & Err.Number
Resume res_breakText

End Function

VBA访问：将文本换行到数组的行

0 个答案: