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...

Lo de la fila y columna funciona de maravilla pero lo de justificar no me anda

Saludos

Hola Post-Newbie,

Si, como dije en el post, yo pegué este código en el foro hace MUCHÍSIMO tiempo porque lo encontré por la web, pero a mi no me funcionaba (a otras personas del foro si).

Ahora busqué ese mismo archivo que hice hace tiempo, pero lo abrí desde la máquina del laburo y aquí me funciona perfecto.

No tengo la más remota idea de qué es lo que hace que en algunas máquinas funcione y en otras no.

Lo peor de todo es que no se qué pasará cuando se empaquete un programa que utiliza esta clase. ¿Funcionará en todas las máquinas? (¿Qué pasa si yo empaqueto el programita este y te lo envío a vos? ¿Funcionará o no?)

Bueno, lamentablemente no te puedo ayudar porque:
1º El código NO lo hice yo
2º Cuando pregunté tampoco nadie me pudo dar una respuesta
3º No se cómo hacerlo.

Saludos.

PD: Me encanta tu avatar.
<div style="text-align: center;">...Free as in Freedom...

Hola, ami me funciona perfecto.


Viste que hay 2 funciones SendMessage ?, en realidad es la misma, pero una apunta a una función y la otra a otra función dentro de la dll. Probá con una, y después con otra a ver si handa. No se si tendrá que ver, a mi me funciona con las 2


Salu2

aunque no la he probado, dentro de la api de windows encontré una que se llama más o menos SetJusifyText -o algo parecido-. no se si la han visto.

Hola Vanchi, me fue de mucha ayuda tu codigo para justificar el texto dentro de un RichTextBox.

Efectue algunas modificaciones y le agrege una rutina para imprimir el documento con formato justificado, espero que les sea de utilidad.

Modulo:

Option Explicit
'Juan Carlos Proal Bordonave 16/5/2007
'Basado en ejemplos de las siguientes direcciones:
'http://www.canalvisualbasic.net/forum/forum_posts.asp?TID=22442 (Iván -Vanchi- La Malfa)
'http://support.microsoft.com/kb/146022/en-us
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 EM_FORMATRANGE As Long = WM_USER + 57
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 Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CharRange
cpMin As Long ' First character of range (0 for start of doc)
cpMax As Long ' Last character of range (-1 for end of doc)
End Type
Private Type FormatRange
hdcActual As Long ' Actual DC to draw on
hdcTarget As Long ' Target DC for determining text formatting
rc As Rect ' Region of the DC to draw to (in twips)
rcPage As Rect ' Region of the entire DC (page size) (in twips)
chrg As CharRange ' Range of text to draw (see above declaration)
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
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
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
Public Sub RTB_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.cpMin = intStart
cr.cpMax = intEnd

' 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)
lngRet = SendMessageLong(hwndr, EM_GETTYPOGRAPHYOPTIONS, mZERO, mZERO)
lngRet = SendMessage(hwndr, EM_GETPARAFORMAT, mZERO, myparaf)

myparaf.dwMask = PFM_ALIGNMENT
myparaf.wAlignment = PFA_JUSTIFY
lngRet = SendMessage(hwndr, EM_SETPARAFORMAT, mZERO, myparaf)

cr.cpMin = 0
cr.cpMax = 0
SendMessage hwndr, EM_EXSETSEL, mZERO, cr
End Sub

Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth, _
TopMarginHeight, RightMarginWidth, BottomMarginHeight, _
P_NextChar, P_Continua, P_Bottom)

Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim r As Long

Printer.Print

' Set printable area rect
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
' Set rect in which to print (relative to printable area)
rcDrawTo.Left = LeftMarginWidth
rcDrawTo.Top = TopMarginHeight
rcDrawTo.Right = RightMarginWidth
rcDrawTo.Bottom = BottomMarginHeight
' Set up the print instructions
fr.hdcActual = Printer.hDC ' Use the same DC for measuring and rendering
fr.hdcTarget = Printer.hDC ' Point at printer hDC
fr.rc = rcDrawTo ' Indicate the area on page to draw to
fr.rcPage = rcPage ' Indicate entire size of page
fr.chrg.cpMin = IIf(P_NextChar > 0, P_NextChar, 0) ' Indicate start of text through
fr.chrg.cpMax = -1 ' end of the text
TextLength = Len(RTF.Text) ' Get length of text in RTF
' Print the page by sending EM_FORMATRANGE message

P_NextChar = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr)

P_Continua = IIf(P_NextChar >= TextLength, False, True)
P_Bottom = fr.rc.Bottom ' indica la ultima posicion de impresion

' Allow the RTF to free up memory
r = SendMessage(RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub


Form:

Private Sub Form_Load()
RTB.Font.Name = "Arial"
RTB.Font.Size = 10
RTB.Refresh
End Sub
Private Sub Command1_Click() ' Justificar
RTB_Justify RTB.hwnd, 0, Len(RTB.Text)
End Sub
Private Sub Command2_Click() ' Impresion del RichTextBox
Dim x1 As Long
Dim x2 As Long
Dim y1 As Long
Dim y2 As Long
Dim P_NextChar As Long
Dim P_Continua As Boolean
Dim P_Bottom As Long

Encabezado

x1 = (Printer.ScaleWidth - RTB.Width) / 2 'LeftMarginWidth
x2 = Printer.ScaleWidth - (Printer.ScaleWidth - RTB.Width) / 2 'RightMarginWidth
y1 = Printer.CurrentY + 130 'TopMarginHeight
y2 = Printer.ScaleHeight - 1440 'BottomMarginHeight

P_NextChar = 0
P_Continua = True
P_Bottom = 0

While P_Continua
Call PrintRTF(RTB, x1, y1, x2, y2, P_NextChar, P_Continua, P_Bottom)
If P_Continua Then
Printer.CurrentY = Printer.ScaleHeight - 400
Printer.Print Tab(3); Date;
Printer.Print Tab(125); "Página: "; Format(Printer.Page, "####")
Printer.NewPage
Encabezado
y1 = Printer.CurrentY + 130
End If
Wend

Printer.CurrentY = P_Bottom
Printer.Print
Printer.Print Tab(3); "Fin del Reporte"

Printer.EndDoc
End Sub ' Fin Etiqueta Todo_Accion_RepExp02
Private Function Encabezado()
Printer.Font.Name = "Arial"
Printer.Font.Size = 10

Printer.CurrentX = (Printer.ScaleWidth - Printer.TextWidth("Prueba de Justificacion de Texto")) / 2
Printer.Print "Prueba de Justificacion de Texto"
Printer.Print
End Function

Funcionó? RARO