GFGetLineArrayThroughLineWidth/Mfrm.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Mfrm"
   ClientHeight    =   3185
   ClientLeft      =   65
   ClientTop       =   351
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3185
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Test"
      Height          =   315
      Left            =   3660
      TabIndex        =   2
      Top             =   2400
      Width           =   915
   End
   Begin VB.TextBox Text1
      Height          =   2655
      Left            =   60
      MultiLine       =   ‑1 'True
      TabIndex        =   1
      Text            =   "Mfrm.frx":0000
      Top             =   60
      Width           =   3495
   End
   Begin VB.PictureBox Picture1
      Height          =   315
      Left            =   60
      ScaleHeight     =   260
      ScaleWidth      =   143
      TabIndex        =   0
      Top             =   2820
      Width           =   195
   End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'
'NOTE: this project contains two general functions:
'‑GFGetLineArrayThroughLineWidth() and
'‑GFGetLineArray()
'
'The difference between the two functions is that the first one
'verifies the returned lines are never longer than the desired
'line length, the second function breaks lines at the passed
'border char only.
'

Private Sub Form_Load()
    'on error resume next
    Dim Temp As Long
    Mfrm.AutoRedraw = True
    For Temp = (Picture1.Left + 2 * Screen.TwipsPerPixelX) To (Picture1.Left + 2 * Screen.TwipsPerPixelX + 100 * Screen.TwipsPerPixelX) Step 10 * Screen.TwipsPerPixelX
        'markings every 10 pixels
        Mfrm.Line (Temp, 0)‑(Temp, 5 * Screen.TwipsPerPixelY), 0
    Next Temp
End Sub

Private Sub Command1_Click()
    'on error resume next
    Dim LineNumber As Integer
    Dim LineArray() As String
    Dim Temp As Long
    'begin
    Picture1.Font.Name = Text1.Font.Name
    Picture1.Font.Size = Text1.Font.Size
    Debug.Print GFGetLineArray(Text1.Text, 100 * Screen.TwipsPerPixelX, " ", LineArray(), LineNumber, Picture1)
    For Temp = 1 To LineNumber
        Debug.Print LineArray(Temp)
    Next Temp
End Sub

Private Function GFGetLineArrayThroughLineWidth(ByVal InputString As StringByVal LineWidthMax As LongByVal LineWidthOverflowMax As LongByVal LineBorderChar As StringByRef LineArray() As StringByRef LineNumber As IntegerByRef LineWidthPicture As PictureBox) As Boolean
    'on error resume next 'format: twips; use as general function to create a text block with defined width, words are broken if too long; function returns True for success or False for error
    Dim Temp As Long
    '
    'NOTE: this function may contains bugs.
    '
    'preset
    LineNumber = 0
    ReDim LineArray(1 To 1) As String
    'verify
    If Not (Len(LineBorderChar) = 1) Then
        GoTo Error:
    End If
    If InputString = "" Then
        GFGetLineArrayThroughLineWidth = True 'ok
        Exit Function
    End If
    'begin
    Temp = 0 'reset
    Do
        Temp = Temp + 1
        If Mid$(InputString, Temp, 2) = Chr$(13) + Chr$(10) Then
            If Not (LineNumber = 32767) Then 'verify
                LineNumber = LineNumber + 1
            Else
                GoTo Error:
            End If
            ReDim Preserve LineArray(1 To LineNumber) As String
            LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
            InputString = Right$(InputString, Len(InputString) ‑ Temp ‑ 1)
            Temp = 0 'reset
        Else
            If Mid$(InputString, Temp, 1) = LineBorderChar Then
                Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
                Case Is < LineWidthMax
                    'do nothing
                Case Is >= LineWidthMax
                    If Not (LineNumber = 32767) Then 'verify
                        LineNumber = LineNumber + 1
                    Else
                        GoTo Error:
                    End If
                    ReDim Preserve LineArray(1 To LineNumber) As String
                    LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
                    InputString = Right$(InputString, Len(InputString) ‑ Temp + 0)
                    Temp = 0 'reset
                End Select
            Else
                Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
                Case Is < LineWidthMax
                    'do nothing
                Case Is >= (LineWidthMax + LineWidthOverflowMax)
                    If Not (LineNumber = 32767) Then 'verify
                        LineNumber = LineNumber + 1
                    Else
                        GoTo Error:
                    End If
                    ReDim Preserve LineArray(1 To LineNumber) As String
                    LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
                    InputString = Right$(InputString, Len(InputString) ‑ Temp + 1)
                    Temp = 0 'reset
                End Select
            End If
        End If
        If Temp = Len(InputString) Then
            If Not (LineNumber = 32767) Then 'verify
                    LineNumber = LineNumber + 1
                Else
                    GoTo Error:
                End If
            ReDim Preserve LineArray(1 To LineNumber) As String
            LineArray(LineNumber) = InputString
            Exit Do 'finished
        End If
    Loop
    GFGetLineArrayThroughLineWidth = True 'ok
    Exit Function
Error:
    GFGetLineArrayThroughLineWidth = False 'error
    Exit Function
End Function

Private Function GFGetLineArray(ByVal InputString As StringByVal LineWidthMax As LongByVal LineBorderChar As StringByRef LineArray() As StringByRef LineNumber As IntegerByRef LineWidthPicture As PictureBox) As Boolean
    'on error resume next 'breaks lines like a Command button (string is only broken at border chars), a word may not be completely visible; InputString must not contain Chr$(13) or Chr$(10)
    Dim LineBorderCharPos As Long 'position of last line border char
    Dim Temp As Long
    '
    'NOTE: this function may contains bugs.
    '
    'reset
    LineNumber = 0 'reset
    ReDim LineArray(1 To 1) As String 'reset
    'preset
    InputString = InputString + LineBorderChar 'add end sign (will be cut automatically)
    'begin
    Do
        Temp = Temp + 1
        If Mid$(InputString, Temp, 1) = LineBorderChar Then 'check for border char
            If (LineWidthPicture.TextWidth(Left$(InputString, Temp)) > LineWidthMax) Then
                If Not (LineNumber = 32767) Then
                    LineNumber = LineNumber + 1
                Else
                    GoTo Error:
                End If
                ReDim Preserve LineArray(1 To LineNumber) As String
                If LineBorderCharPos = 0 Then 'happens if a word is too large for one line
                    LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
                    InputString = Right$(InputString, Len(InputString) ‑ Temp)
                Else
                    LineArray(LineNumber) = Left$(InputString, LineBorderCharPos ‑ 1)
                    InputString = Right$(InputString, Len(InputString) ‑ LineBorderCharPos)
                End If
                Temp = 0 'reset
            End If
            If Len(InputString) = 0 Then
                Exit Do 'finished
            Else
                If Temp = Len(InputString) Then
                    If Not (LineNumber = 32767) Then
                        LineNumber = LineNumber + 1
                    Else
                        GoTo Error:
                    End If
                    ReDim Preserve LineArray(1 To LineNumber) As String
                    LineArray(LineNumber) = Left$(InputString, Len(InputString) ‑ 1) 'cut end sign
                    Exit Do 'finished
                End If
            End If
            LineBorderCharPos = Temp
        End If
    Loop
    GFGetLineArray = True 'ok
    Exit Function
Error:
    GFGetLineArray = False 'error
    Exit Function
End Function


[END OF FILE]