He tenido necesidad de implementar un AJUSTE de texto en unos documentos y aunque no llega a la perfección del Word y similares (ni se les acerca siquiera), he conseguido desarrollar esta función que cumple gran parte de su cometido.
Como es muy simple y no es mucho código, a fin de no tener que adjuntar un archivo copia aqui la funcion con un ejemplo de uso de la misma.
Public Function JustificaTexto(ByVal Texto As String, Ancho As Integer, Hacia As Object) As String
' Justifica (mas o menos) el texto indicado. No es el de Office ni hace milagros pero puede servir.
' Recibe....: Texto a Autoajustar, Ancho deseado, Objeto que recibirá el texto
' Devuelve..: Lineas separadas por CrLf y ajustada al ancho deseado
Dim Todo As String, Desde As Integer, Hasta As Integer, Previo As Integer, Linea As String, Parte As String
Dim Posicion As Integer, Insertar As Boolean, HayBlancos As Boolean, Intro As Integer
Dim Objeto As Object
Set Objeto = Hacia
Todo = RTrim$(Texto) & Chr$(32) ' Añade al final un caracter en blanco
TieneIntros:
' Comprueba si es un texto Multi-Párrafo
Intro = InStr(Todo, vbCrLf)
If Intro > 0 Then
Parte = Left$(Todo, Intro - 1)
Todo = Mid$(Todo, Intro + 2)
JustificaTexto = JustificaTexto & JustificaTexto(Parte, Ancho, Hacia)
GoTo TieneIntros
End If
Do
If InStr(Todo, Chr$(32)) = 0 Then
JustificaTexto = JustificaTexto & Todo & vbCrLf
Exit Do
End If
Desde = 1
MasAun:
Hasta = InStr(Desde, Todo, Chr$(32))
If Objeto.TextWidth(Left$(Todo, Hasta - 1)) < Ancho Then
Previo = Hasta 'El último corte que encaja en el ancho
Desde = Hasta + 1
If Hasta < Len(Todo) Then GoTo MasAun
End If
Linea = RTrim$(Left$(Todo, Previo - 1))
Todo = LTrim$(Mid$(Todo, Previo + 1))
' Ajusta con blancos la linea para igualar al máximo
Ajustar:
Posicion = 1
If InStr(Linea, Chr$(32)) > 0 Then HayBlancos = True Else HayBlancos = False
Insertar = False
Do
If Not HayBlancos Then Exit Do
If Mid$(Linea, Posicion, 1) <> Chr$(32) Then
Insertar = True
Else
If Insertar Then
Linea = Left$(Linea, Posicion) & Chr$(32) & Mid$(Linea, Posicion + 1)
Insertar = False
If Objeto.TextWidth(Linea) >= Ancho Then Exit Do
End If
End If
If Posicion = Len(Linea) Then Exit Do
Posicion = Posicion + 1
Loop
If Objeto.TextWidth(Linea) < Ancho And HayBlancos And Todo <> "" Then GoTo Ajustar
JustificaTexto = JustificaTexto & Linea & vbCrLf
Loop
Set Objeto = Nothing
End Function
Aqui código del ejemplo Pic es un PictureBox, txtTexto es un TexBox multilinea y Ajustar es un Slider para probar diversos Anchos
Option Explicit
Private Sub Form_Load()
txtTexto = vbTab & "Esta texto es la prueba para comprobar esta función de Justificacion de Texto, no pretende sustituir"
txtTexto = txtTexto & " la función de los editores profesionales, ya que no controla los cambios de Fuente, Tamaño,"
txtTexto = txtTexto & " negrita dentro del mismo texto, pero en algunas circunstancias creo que puede valer, por lo"
txtTexto = txtTexto & " menos a mi me vale. Puede no estar exento de errores, de hecho estoy seguro que tiene alguno,"
txtTexto = txtTexto & " por lo que se aceptan mejoras al mismo. Un saludo a todos."
txtTexto = txtTexto & vbCrLf
txtTexto = txtTexto & vbTab & "Para probar su funcionamiento basta con ir desplazando la barra con el fin de determinar el ancho."
txtTexto = txtTexto & vbCrLf
txtTexto = txtTexto & vbTab & "Se ha modificado porque había un error si incluíamos CrLf en el texto. Antes sólo editaba bien"
txtTexto = txtTexto & "un párrafo y sin embargo con esta modificacion ajusta bien un texto en el que se pueden indicar"
txtTexto = txtTexto & "diferentes párrafos con el CrLf para separarlos. Tambien se ha comprobado su funcionamiento si lleva"
txtTexto = txtTexto & "insertado entre el texto Tabulaciones vbTab, espero que no haya mas cambios"
txtTexto = txtTexto & vbCrLf & vbCrLf
txtTexto = txtTexto & vbTab & "En la linea anterior se ha incluido un doble Intro CrLf para probar su funcionamiento"
Ajustar.Max = Pic.Width
Ajustar.Min = 1000
Ajustar.Value = Pic.Width \ 3
End Sub
Private Sub Ajustar_Click()
Pic.Cls
Pic.Print JustificaTexto(txtTexto, Ajustar.Value, Pic)
End Sub
Saludos y ojalá le sirva a alguien.
pd: He tenido que aplicar una modificación porque de la manera anterior sólo justificaba correctamente el primer párrafo de un texto. De este modo justifica todos los párrafos considerando los mismos si estan separados por CrLF. Asi mismo he verificado el correcto funcionamiento de vbTab en el Texto.
