100 funciones para manejo de Cadenas (nueva funcion)

Hace un rato nuestro amigo Carlos Marin me preguntó si tenía una
función que justifique una cadena a un ancho determinado.

Me puse a buscar en la Web, y encontré una función que transforma una
cadena de texto, en un párrafo, de forma proporcional, es decir,
considerando que cada letra tiene el mismo ancho.

NOTA: Agradeceremos que si alguien ya tiene una función que haga lo
mismo pero con fuentes no proporcionales (como arial), sea tan amable
de compartirlo con nosotros, que es un asunto de mucha utilidad en los
reportes.


Saludos a todos,
Carlos Bardales,




'************************************************************************
' TextoAParrafos(Texto,Parrafo) --> String
' Función desarrollada por Eduardo Olaz
' Primera versión 4/11/99
' Última revisión 4/11/99
'************************************************************************
' parámetros: Texto (por valor, string) Texto que se quiere
convertir
' Parrafo (por valor, long) Longitud máxima del
párrafo
' Valor devuelto (String) Cadena transformada
' Método: Recursivo
' Funciones auxiliares: SubParrafo(Texto,Parrafo) --> String
' PosicionCorte(Texto,Parrafo)--> Long
' Devuelve la cadena Texto transformada
' en párrafos de longitud igual a Parrafo
' salvo que se encuentre un salto de línea ó retorno de carro
' que hará que ese párrafo sea más corto.
' Para igualar los párrafos inserta espacios junto a cada espacio
' hasta completar una línea de longitud constante
' esta función se usa de forma recursiva cortando
' la cadena Texto hasta que el último trozo es
' de longitud <= que Parrafo

Public Function TextoAParrafos(ByVal Texto As String, _
ByVal Parrafo As Long) _
As String

Dim lngLongitudTexto As Long
Dim lngPuntoCorte As Long 'punto por donde cortar la cadena
Dim strTextoIzquierda As String 'cadena a la izquierda del corte
Dim strTextoDerecha As String 'cadena a la derecha del corte
Dim strCaracter As String * 1
lngLongitudTexto = Len(Texto)

If lngLongitudTexto <= Parrafo Then
TextoAParrafos = Texto
Else
lngPuntoCorte = PosicionCorte(Texto, Parrafo)
strTextoIzquierda = RTrim(Left$(Texto, lngPuntoCorte))
strCaracter = Mid$(Texto, lngPuntoCorte)
If (strCaracter = vbNewLine Or strCaracter = vbLf) Then
' Se ha detectado final de párrafo
strTextoDerecha = Mid$(Texto, lngPuntoCorte + 1)
TextoAParrafos = strTextoIzquierda & _
TextoAParrafos(LTrim$(strTextoDerecha), Parrafo)
Else
' Añadir espacios en los huecos hasta longitud de parrafo
strTextoIzquierda = SubParrafo(strTextoIzquierda, Parrafo)
strTextoDerecha = Mid$(Texto, lngPuntoCorte + 1)
TextoAParrafos = strTextoIzquierda & vbCrLf & _
TextoAParrafos(LTrim$(strTextoDerecha), Parrafo)
End If

End If
End Function


'************************************************************************
' PosicionCorte(Texto,Parrafo) --> Long
' Función desarrollada por Eduardo Olaz
' Primera versión 4/11/99
' Última revisión 4/11/99

'************************************************************************
' parámetros: Texto (por valor, string) del que obtener pto. de
corte
' Parrafo (por valor, long) Longitud máxima del
párrafo
' Valor devuelto (Long) Punto por el que cortar la cadena Texto
' Método: Iterativo

Public Function PosicionCorte(ByVal Texto As String, ByVal Parrafo As
Long)
As Long
Dim lngLongitudTexto As Long
Dim lngContador As Long
Dim strCaracter As String * 1
Dim strIzquierda As String

lngLongitudTexto = Len(Texto)
' Recorre carácter a carácter la cadena
' hasta la posición Parrafo.
' esta búscqueda se interrumpe si encuentra una carácter
' de retorno de carro o salto de línea o si se acaba la cadena
Do While lngContador < Parrafo And _
lngContador <= lngLongitudTexto _
And strCaracter <> vbNewLine _
And strCaracter <> vbLf
lngContador = lngContador + 1
strCaracter = Mid$(Texto, lngContador, 1)
Loop
If lngContador < Parrafo Then
PosicionCorte = lngContador
Else
Select Case strCaracter
Case vbNewLine, vbLf
PosicionCorte = lngContador
' Si encuentra un espacio en blanco o un tabulador
' en la última posición recorre la cadena hacia la izquierda
' hasta encontrar un carácter
Case " ", vbTab
Do While (strCaracter = " " Or strCaracter = vbTab)
lngContador = lngContador - 1
strCaracter = Mid$(Texto, lngContador, 1)
Loop
PosicionCorte = lngContador + 1
Case Else
' Busca un espacio en blanco o tabulador a la izquierda
' para efectuar el corte en un blanco
PosicionCorte = lngContador
Do While (strCaracter <> " " _
And strCaracter <> vbTab _
And lngContador > 1)
lngContador = lngContador - 1
strCaracter = Mid$(Texto, lngContador, 1)
Loop
'Extrae la cadena sin blancos a la derecha
strIzquierda = RTrim(Left$(Texto, lngContador))
PosicionCorte = Len(strIzquierda)
End Select
End If
End Function

Public Function SubParrafo(ByVal Texto As String, _
ByVal Parrafo As
Long) _
As String
' Devuelve una cadena contenida en la parte izquierda de Texto
' de longitud menor ó igual que el valor de parrafo
Dim lngContador As Long
Dim lngLongitudTexto As Long
Dim lngBlancos As Long
Dim lngBlancosPorEspacio As Long
Dim lngEspacios As Long
Dim lngPosicion As Long
Dim strCaracter As String * 1
Dim strLadoIzquierdo As String
Dim strLadoDerecho As String
Dim lngEspacioActual As Long
Dim astrEspacios() As String

lngLongitudTexto = Len(Texto)
If lngLongitudTexto = Parrafo Then
SubParrafo = Texto
Else
lngBlancos = Parrafo - lngLongitudTexto
' Averiguar el nº de espacios en blanco que hay en texto
For lngPosicion = 1 To lngLongitudTexto
strCaracter = Mid$(Texto, lngPosicion, 1)
If strCaracter = " " Then
lngEspacios = lngEspacios + 1
End If
Next lngPosicion
If lngEspacios = 0 Then
SubParrafo = Texto
Else
' Uso la matriz dinámica astrEspacios para almacenar
' los blancos a añadir
ReDim astrEspacios(1 To lngEspacios)
lngBlancosPorEspacio = lngBlancos \ lngEspacios
For lngContador = 1 To lngEspacios
astrEspacios(lngContador) Space(lngBlancosPorEspacio)
Next lngContador
For lngContador = 1 _
To lngBlancos - lngBlancosPorEspacio * lngEspacios
astrEspacios(lngContador) = astrEspacios(lngContador)
& " "
Next lngContador
For lngPosicion = 1 To lngLongitudTexto
strCaracter = Mid$(Texto, lngPosicion, 1)
strLadoIzquierdo = strLadoIzquierdo & strCaracter
If strCaracter = " " Then
lngEspacioActual = lngEspacioActual + 1
strLadoIzquierdo = strLadoIzquierdo _
& astrEspacios(lngEspacioActual)
End If
Next lngPosicion
SubParrafo = strLadoIzquierdo
End If
End If

End Function