VB Quicktakes - Word Wrap Text

The code listed below can be compiled as a class or can be added to a project. This code wraps text to a specified number of characters per line. It does this by using several api calls and a fixed width font. This method for wrapping text is much faster than any other code I have found on the internet. These are the necessary objects: one form called frmMain with txtbox on it called txtHidden, a module called modMainCode, and a class module called WordWrap

'modMainCode

Option Explicit

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Public Const EM_LINEINDEX = &HBB
Public Const EM_LINELENGTH = &HC1
Public Const EM_GETLINE = &HC4
Public Const EM_GETLINECOUNT = &HBA
Public Const EM_FMTLINES = &HC8


'frmMain

Option Explicit

Public intMaxLineLen As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINELENGTH = &HC1
Private Const EM_GETLINE = &HC4
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_FMTLINES = &HC8

'************************************************************************
'This sets up the textbox so it will wrap to the correct amount of
'characters
'************************************************************************
Private Sub SetUpRTB()
Dim lngIndex As Long
Dim intLength As Integer
   
   intLength = 0
   txtHidden.MultiLine = True
   txtHidden.Font.Name = "Fixedsys"
   txtHidden.Text = String(500, "W")
   Do Until intLength = intMaxLineLen
      
      txtHidden.Width = txtHidden.Width + 5
      lngIndex = SendMessage(txtHidden.hWnd, _
         EM_LINEINDEX, 1, 0)
      intLength = SendMessage(txtHidden.hWnd, _
         EM_LINELENGTH, lngIndex, 0)
   Loop
   txtHidden = ""
   txtHidden.Visible = False

End Sub



Private Sub Form_Load()
SetUpRTB
End Sub

'WordWrap Class

Option Explicit



Public Function WordWrap(strText As String, intLineLen As Integer) As String
   frmMain.intMaxLineLen = intLineLen
   Load frmMain
   WordWrap = GetText(strText)
End Function

'*************************************************************************************
'This function wraps a string by using apis and a textbox control(txtHidden)
'located on frmmain
'*************************************************************************************
Private Function GetText(strSource As String) As String
   Dim lngCounter As Long
   Dim lngLinecount As Long
   Dim strHolder As String
   Dim strLine As String
   Dim lngCurrPos As Long, lngCurrPos2 As Long
   Dim lngNextLen As Long
   Dim lngtxtSize As Long
   
   Dim intLength As Integer, intPrevLength As Integer
   Dim lngCount As Long
   Dim lngIndex As Long
   Dim strBuf As String, strBufReplace As String
   
   
   lngtxtSize = 65535 / ((2 / ((frmMain.intMaxLineLen + 1) / 2)) + 1)
   strHolder = Space$(10000000)
   
   lngNextLen = lngtxtSize
   lngCurrPos = 1
   lngCurrPos2 = 1
   Do Until lngCurrPos >= Len(strSource)
      If Len(strSource) - lngCurrPos < lngtxtSize Then
         lngNextLen = Len(strSource) - lngCurrPos + 1
      End If
      frmMain.txtHidden = Mid(strSource, lngCurrPos, lngNextLen)
      SendMessage frmMain.txtHidden.hWnd, EM_FMTLINES, True, 0

      lngIndex = SendMessage(frmMain.txtHidden.hWnd, _
         EM_LINEINDEX, 0, 0)
      intLength = SendMessage(frmMain.txtHidden.hWnd, _
         EM_LINELENGTH, lngIndex, 0)
      
      If intLength + intPrevLength > frmMain.intMaxLineLen Then
         strBuf = Space$(intLength + 1)
         SendMessage frmMain.txtHidden.hWnd, EM_GETLINE, 0, ByVal strBuf
         strBuf = Left$(strBuf, intLength)
         strBufReplace = FixBuf(strBuf, intPrevLength)
         frmMain.txtHidden = Replace$(frmMain.txtHidden, strBuf, strBufReplace, , 1)
         SendMessage frmMain.txtHidden.hWnd, EM_FMTLINES, True, 0
      End If
            
      
      lngCount = SendMessage(frmMain.txtHidden.hWnd, _
         EM_GETLINECOUNT, 0, 0)
      lngIndex = SendMessage(frmMain.txtHidden.hWnd, _
         EM_LINEINDEX, lngCount - 1, 0)
      intPrevLength = SendMessage(frmMain.txtHidden.hWnd, _
         EM_LINELENGTH, lngIndex, 0)
         
      Mid$(strHolder, lngCurrPos2, Len(frmMain.txtHidden)) = frmMain.txtHidden
      
      lngCurrPos2 = lngCurrPos2 + Len(frmMain.txtHidden)
      lngCurrPos = lngCurrPos + lngNextLen
   Loop
   GetText = Replace$(Trim$(strHolder), vbCr & vbCr & vbLf, vbCrLf)
End Function

'****************************************************************************
'This function ensures that the first line of the text to be conconcatonated
'does not exceed the maximum line length when concatonated to the last line
'in the main string variable
'****************************************************************************
Private Function FixBuf(ByVal strText As String, intLen As Integer) As String
   Dim intMaxLen As Integer
   Dim i As Integer
   Dim intlstSpace As Integer
   
   intMaxLen = frmMain.intMaxLineLen - intLen
   
   For i = 1 To intMaxLen
      If Mid$(strText, i, 1) = Space$(1) Then
         intlstSpace = i
      End If
         
   Next
   If intlstSpace <> 0 Then
      strText = Left$(strText, intlstSpace - 1) & vbCrLf & Right$(strText, Len(strText) - intlstSpace)
   Else
      strText = Left$(strText, intMaxLen) & vbCrLf & Right$(strText, Len(strText) - intMaxLen)
   End If
   FixBuf = strText
End Function