Impresión de parrafos con ancho fijo

El siguiente es un código que desarrollé un par de años atrás para imprimir párrafos que encajaran dentro de un ancho fijo desde Visual Basic 6.
La función original utilizaba el objeto Printer pero aquí se encuentra modificado para trabajar con el objeto Form de modo que pueda ser probado con sólo llamar a ImprimirParrafo() desde un formulario cualquiera.

Sus argumentos son:

• pX: la coordenada horizontal en puntos de la esquina superior izquierda donde se comenzará a escribir el texto.
• pY: la coordenada vertical en puntos de la esquina superior izquierda donde se comenzará a escribir el texto.
• pAncho: el ancho en puntos con el cual se desea limitar el texto.
• cadena: el texto a escribir propiamente dicho.

Para trabajar nuevamente con el objeto Printer basta con reemplazar Me.Print por Printer.Print.
Aclaro que el motivo fundamental de este post es que puedan rescatar el algoritmo en sí y utilizarlo en sus desarrollos.

Private Function ImprimirParrafo(ByVal pX As Integer, ByVal pY As Integer, _
ByVal pAncho As Integer, ByVal cadena As String) As Integer
Dim Palabra As String
Dim posEspecial As Integer
Dim linePos As Single
Dim resto As Single
Dim caracter As String * 1
Dim hasta As Integer
renglones = 0
linePos = 0
caracter = Left(cadena, 1) ‘Obtenemos el primer caracter
‘Mientras no haya consumido toda la cadena …
While (Len(cadena) > 0)
Select Case caracter
Case (vbLf), (vbFormFeed)
‘Si es un salto de linea bajamos de linea
cadena = Right(cadena, Len(cadena) – 1)
renglones = renglones + 1
Case (vbNewLine), (vbCr)
‘Si es una retorno de carro, volvemos al margen
cadena = Right(cadena, Len(cadena) – 1)
linePos = 0
Case (vbTab), (vbVerticalTab), ” “‘Si es un tabulador
If Me.TextWidth(caracter) <= (pAncho – linePos) Then
‘… y cabe en la linea.
Me.CurrentY = pY + (renglones * Me.TextHeight(“W”))
Me.CurrentX = pX + linePos
‘Se imprime el caracter
Me.Print caracter
linePos = linePos + Me.TextWidth(caracter)
cadena = Right(cadena, Len(cadena) – 1)
Else
‘… NO cabe en la linea, entonces nueva linea
renglones = renglones + 1
linePos = 0
cadena = Right(cadena, Len(cadena) – 1)
End If
Case vbNullChar, vbNullString
‘Si es un caracter nulo, simplemente avanzamos
cadena = Right(cadena, Len(cadena) – 1)
Case Else ‘ —————- Viene una palabra —————–
posEspecial = proximoEspecial(cadena)
If posEspecial = 0 Then
posEspecial = Len(cadena)
Palabra = cadena
cadena = “”
Else
Palabra = Left(cadena, posEspecial – 1)
cadena = Right(cadena, Len(cadena) – (posEspecial – 1))
End If
If Me.TextWidth(Palabra) pAncho) And (hasta > 0)
hasta = hasta – 1
Wend
‘Trunco la cadena
cadena = Right(Palabra, Len(Palabra) – hasta) & cadena
‘Trunco la Palabra
Palabra = Left(Palabra, hasta)
‘Se la imprime y avanzo de linea
Me.CurrentY = pY + (renglones * Me.TextHeight(“W”))
Me.CurrentX = pX + linePos
Me.Print Palabra
renglones = renglones + 1
Else
‘ si NO es la primer palabra de la linea …
‘Se avanza de linea
renglones = renglones + 1
linePos = 0
cadena = Palabra & cadena
End If
End If
End Select
‘Obtengo el proximo caracter
caracter = Left(cadena, 1)
DoEvents
Wend
ImprimirParrafo = renglones + 1
End Function
Private Function proximoEspecial(pCadena As String)
Dim c As Integer
Dim car As String * 1
Dim encontrado As Boolean
Pos = 0
encontrado = False
c = 1
While Not (encontrado) And (c <= Len(pCadena))
car = Mid(pCadena, c, 1)
Select Case car
Case vbLf, vbCr, vbTab, vbVerticalTab, vbNullChar, vbNullString, _
vbBack, vbFormFeed, vbNewLine, vbObjectError, ” “
encontrado = True
c = c – 1
End Select
c = c + 1
Wend
proximoEspecial = c
End Function