Hola Gente,
<br style="font-weight: bold;">UTILIDAD: Justificar un texto en un RichTextBox y además everiguar en qué fila y columna está
Este es un código que hace mucho tiempo fue posteado en esta página. Lamentablemente se perdió porque: para el tiempo en que fue posteado no existía la guía de recursos; el post original fue borrado para hacer espacio.
Bueno, sin más preámbulo: Aquí va el código.
<div style="text-align: center;">MODULO DE CLASE: clsRichTextJustify
Código:
Option Explicit
Private Const WM_USER = &H400
Private Const EM_EXSETSEL = (WM_USER + 55)
Private Const EM_SETSEL = &HB1
Private Const EM_GETSEL = &HB0
Private Const EM_GETPARAFORMAT = (WM_USER + 61)
Private Const EM_SETPARAFORMAT = (WM_USER + 71)
Private Const EM_GETSELTEXT = (WM_USER + 62)
Private Const EM_SETTYPOGRAPHYOPTIONS = (WM_USER + 202)
Private Const EM_GETTYPOGRAPHYOPTIONS = (WM_USER + 203)
Private Const TO_ADVANCEDTYPOGRAPHY = &H1
Private Const TO_SIMPLELINEBREAK = &H2&
Private Const PFM_ALIGNMENT = &H8
Private Const PFM_TABSTOPS = &H10
Private Const PFM_STYLE = &H400
Private Const PFA_LEFT = 1
Private Const PFA_RIGHT = 2
Private Const PFA_CENTER = 3
Private Const PFA_JUSTIFY = &H4
Private Const PS_SOLID = 0
Private Const PFA_FULL_GLYPHS = 7
Private Const mZERO = &H0&
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#If UNICODE Then
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal uMgs As Long, ByVal wParam As Long, lParam As Any) As Long
#Else
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal uMgs As Long, ByVal wParam As Long, lParam As Any) As Long
#End If
Private Type Charrange
cpMin As Long
cpMax As Long
End Type
Private Type PARAFORMAT2
cbsize As Integer
dwpad As Integer
dwMask As Long
wNumbering As Integer
wReserved As Integer
dxStartIndent As Long
dxRightIndent As Long
dxOffset As Long
wAlignment As Integer
cTabCount As Integer
lTabstops(0 To 31&) As Long
dySpaceBefore As Long
dySpaceAfter As Long
dyLineSpacing As Long
sStyle As Integer
bLineSpacingRule As Byte
bOutlineLevel As Byte
wShadingWeight As Integer
wShadingStyle As Integer
wNumberingStart As Integer
wNumberingStyle As Integer
wNumberingTab As Integer
wBorderSpace As Integer
wBorderWidth As Integer
wBorders As Integer
End Type
Public Sub Justify(hwndr As Long, intStart As Integer, intEnd As Integer)
Dim myparaf As PARAFORMAT2
Dim cr As Charrange
Dim lngRet As Long
myparaf.cbsize = Len(myparaf)
' paragraph selection points to character before and
' character after position from beginning of the RichText Box
cr.cpMax = intEnd
cr.cpMin = intStart
' Select the text if you don't want to see it make the RichText invisible first
SendMessage hwndr, EM_EXSETSEL, mZERO, cr
lngRet = SendMessageLong(hwndr, EM_SETTYPOGRAPHYOPTIONS, TO_ADVANCEDTYPOGRAPHY, TO_ADVANCEDTYPOGRAPHY)
If lngRet = 1 Then 'only do this if version 3.0
lngRet = SendMessageLong(hwndr, EM_GETTYPOGRAPHYOPTIONS, mZERO, mZERO)
lngRet = SendMessage(hwndr, EM_GETPARAFORMAT, mZERO, myparaf)
If myparaf.wAlignment = PFA_LEFT Then
myparaf.dwMask = PFM_ALIGNMENT
myparaf.wAlignment = PFA_JUSTIFY
lngRet = SendMessage(hwndr, EM_SETPARAFORMAT, mZERO, myparaf)
Else
Debug.Print "Centre"
End If
Else
Debug.Print "FAIL"
End If
cr.cpMin = 0
cr.cpMax = 0
SendMessage hwndr, EM_EXSETSEL, mZERO, cr
End Sub
Public Sub Settabs(hwndr As Long, lngArrTabs() As Long, rwidth As Long, Optional lngstart As Long, Optional lngEnd As Long)
'sets tabs in twips careful not to exceed the width of the rich text box rwidth
' pass in the tabs in an array base 1
Dim myparaf As PARAFORMAT2
Dim lngRet As Long
Dim intCnt As Integer
Dim cr As Charrange
Dim intCum As Integer
Dim lngTabs As Long
lngEnd = lngEnd + 4
'set the selection
If lngstart = 0 And lngEnd = 0 Then
'cr.cpMax = Len(frmName.richtb.Text) 'put appropriate source in here
cr.cpMin = 0
Else
cr.cpMax = lngEnd
cr.cpMin = lngstart
End If
'first select all the text or nothing will happen
SendMessage hwndr, EM_EXSETSEL, 0, cr
'setup the tab array
lngTabs = UBound(lngArrTabs)
myparaf.cbsize = Len(myparaf)
lngRet = SendMessage(hwndr, EM_GETPARAFORMAT, 0, myparaf)
For intCnt = 0 To lngTabs - 1
If lngArrTabs(intCnt + 1) <= rwidth Then '(rwidth * Screen.TwipsPerPixelX) - lngSize Then
myparaf.lTabstops(intCnt) = lngArrTabs(intCnt + 1)
myparaf.cTabCount = intCnt + 1
End If
Next intCnt
'Now do the tabs
myparaf.dwMask = PFM_TABSTOPS
lngRet = SendMessage(hwndr, EM_SETPARAFORMAT, 0, ByVal myparaf)
cr.cpMax = 0
cr.cpMin = 0
'clean up setting selection to zero
SendMessage hwndr, EM_EXSETSEL, 0, cr
End Sub
<div style="text-align: center;">FORM
Código:
Option Explicit
Dim crt As clsRichTextJustify
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 Const EM_GETLINECOUNT = &HBA
Private Const EM_LINEFROMCHAR = &HC9
Private Const EM_LINEINDEX = &HBB
Private Sub Form_Load()
Set crt = New clsRichTextJustify
End Sub
Private Sub Command1_Click()
'JUSTIFICAR
crt.Justify RTB.hwnd, 0, Len(RTB.Text)
End Sub
Private Sub Command2_Click()
'AVERIGUAR EN QUÉ COLUMNA Y LÍNEA ESTÁ)
Dim Linea&, Col&
Linea = SendMessage(RTB.hwnd, EM_LINEFROMCHAR, RTB.SelStart, 0&) + 1
Col = RTB.SelStart - SendMessage(RTB.hwnd, EM_LINEINDEX, Linea - 1, 0&) + 1
Me.Caption = Col & " , " & Linea
End Sub
Saludos
<div style="text-align: center;">...Free as in Freedom...