.Pattern = "(^|\b|\s).{1," & LineLen & "}(\s|\b|$)"
For Each m In .Execute(StringIn)
SplitString = SplitString & Trim(m) & vbCrLf
Next mDeceptively
simple line
breaking
simple
line
breaking
This is an
example
This is
an
example
This is an
example
Another
exampleWhat if you not display it in a message box but on a label in a small custom user form?
Dim msg As String
msg = "This is some incredibly looooong message. A messagebox displaying this text will surely not look any kind of presentable at all let alone wrap it properly!"
UserForm1.Label1.Caption = msg
UserForm1.Show
[blue]Option Explicit
Dim WithEvents cmdOK As CommandButton
Dim cheatform As UserForm1 ' choose a form that doesn't have any initialisation or termination code ...
' Illustrative only ...
Public Sub wombat()
Dim mylabel As Label ' this will do our linebreaking for us ...
Dim coverup As Object
Set cheatform = New UserForm1
Set coverup = cheatform.Controls.Add("Forms.Frame.1", , True)
coverup.Width = cheatform.Width
coverup.Height = cheatform.Height
Set cmdOK = coverup.Controls.Add("Forms.CommandButton.1", , True)
cmdOK.Caption = "OK"
'cmdOK.Visible = True
Set mylabel = coverup.Controls.Add("Forms.Label.1", , True)
With mylabel
.AutoSize = True
.WordWrap = True
.Width = 200
.Visible = True
.Caption = "And now for a further example that demonstrates the problems with a larger width than the previous examples have shown"
End With
cmdOK.Top = mylabel.Height + 10
cmdOK.Left = (cheatform.Width - cmdOK.Width) / 2
cheatform.Show
End Sub
Private Sub cmdOK_Click()
Unload cheatform
End Sub[/blue]![[smile]](/data/assets/smilies/smile.gif "[smile] [smile]")
[blue]Option Explicit
Private Const WS_CHILD = &H40000000
Private Const ES_MULTILINE = &H4&
Private Const EM_FMTLINES = &HC8
Private Const WM_GETTEXT = &HD
Private Const WM_SETTEXT = &HC
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETFONT = &H30
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function GetTextExtentPoint Lib "gdi32" Alias "GetTextExtentPointA" (ByVal hdc As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Function vbLinebreakText(ByVal strSource As String, ByVal lBreakPos As Long) As String
Dim myfont As Long
Dim myDC As Long
Dim oldfont As Long
Dim StringExtent As Size
Dim hWndEdit As Long
Dim strOutput As String
lBreakPos = lBreakPos + 1
' create a default fixed width font to use.
myfont = CreateFont(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "Courier New")
' Step 1 - establish how many pixels wide our edit box needs to be to match requested breakpoint
myDC = GetDC(GetDesktopWindow) ' Leverage the desktop's DC
oldfont = SelectObject(myDC, myfont) ' Now select our fixed width font into the DC
Call GetTextExtentPoint(myDC, String(lBreakPos, "W"), lBreakPos, StringExtent) ' OK, StringExtent now has size we need
' We need a multiline edit control with an hWnd for this trick to work. Which means we have to revert to the API if using VBA Forms
' This one is 'owned' by the desktop. Use the width we've calculated
If hWndEdit = 0 Then hWndEdit = CreateWindowEx(0&, "edit", "", WS_CHILD Or ES_MULTILINE, 0&, 0&, StringExtent.cx, StringExtent.cy * 10, GetDesktopWindow, 0&, 0&, 0&)
' Match the font that was used in the DC for the width calculation
SendMessage hWndEdit, WM_SETFONT, myfont, 0
' Now do the magic
SendMessage hWndEdit, WM_SETTEXT, 0&, ByVal strSource
SendMessage hWndEdit, EM_FMTLINES, 1, 0& ' apply Windows default linebreaking algorithm
'Retrieve the string which now includes soft breaks
strOutput = Space(SendMessage(hWndEdit, WM_GETTEXTLENGTH, 0, 0) + 1)
SendMessage hWndEdit, WM_GETTEXT, Len(strOutput), ByVal strOutput
vbLinebreakText = Replace(strOutput, vbCr & vbCr, vbCr)
' All done, so tidy up GDI and window objects
SelectObject myDC, oldfont 'select original font back in
If myfont <> 0 Then DeleteObject myfont
If myDC <> 0 Then DeleteDC myDC ' dispose of the DC as we don't need it anymore
If hWndEdit <> 0 Then DestroyWindow hWndEdit
End Function[/blue]