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
( orignal source: http://www.mredkj.com/vbquicktakes/WordWrap.html )
