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


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_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
About this page: