Para testar, foi adaptado agora mesmo:
Num Módulo .bas
Public Function Justifica(lpzText, ControlText As Control, obj As Object) As String
'Simula o alinhamento justificado de texto em campos de objectos
Dim Carac As String, Newtext As String
Dim Numspaces As Integer, WidthSpace As Integer
Dim WidthControl As Integer
Dim I As Integer, inicio As Integer
Dim MaxPos As Integer, PosSpace As Integer, PoscharBreak As Integer
Dim FinalText As String, SpacesInStr As Integer
Dim SizeText As Integer
Dim POSI As Integer, CI As Integer
Dim NextCarac As String
Dim n As Integer
'As próximas 4 linhas definem as propriedades de fontes do objecto com as
'definições da caixa de texto que irá receber o texto justificado, pois as
'dimensões do texto para cálculos são feitas através da propriedade TextWidth
'do objecto
obj.FontName = ControlText.FontName
obj.FontSize = ControlText.FontSize
obj.FontBold = ControlText.FontBold
obj.FontItalic = ControlText.FontItalic
'Obtém o tamanho da caixa de texto que irá receber o texto alinhado
WidthControl = ControlText.Width
'Obtém o tamanho de espaço na fonte atual
WidthSpace = obj.TextWidth(" ")
'obtém o tamanho do texto a ser justificado
SizeText = Len(lpzText)
I = 1
inicio = 1
Do While I < SizeText + 1
Carac = Mid(lpzText, I, 1) 'extrai um caracter de cada vez
Newtext = Newtext + Carac 'cria nova sequência de caracteres
Select Case Carac
Case Chr(13) 'se o caracter for ENTER - final do parágrafo ...
FinalText = FinalText + Left(Newtext, Len(Newtext) - 1) + Chr(13) + Chr(10)
Newtext = ""
I = I + 1
MaxPos = 0
inicio = I + 1
Case " " 'se o caracter for ESPAÇO
If obj.TextWidth(Newtext) > WidthControl Then
'Se a nova seqüência for maior que o controle que irá receber o texto,
'refaz a nova seqüência para caber na caixa de texto
Newtext = Mid(lpzText, inicio, MaxPos - inicio)
'obtém o número de espaços necessários, que deverão ser inseridos
'na nova seqüência de texto
Numspaces = Fix((WidthControl - obj.TextWidth(Newtext)) / WidthSpace) - 1
For n = 1 To Len(Newtext)
'Calcula o número de espaços existentes na nova seqüência de texto
Carac = Mid(Newtext, n, 1)
If Carac = " " Then SpacesInStr = SpacesInStr + 1
Next n
POSI = 1
CI = 1
PoscharBreak = 0
Do While CI < Numspaces
'Insere espaços no texto nos espaços já existentes no mesmo
Carac = Mid(Newtext, POSI, 1)
If Carac = " " Then
NextCarac = Mid(Newtext, POSI + 1, 1)
If NextCarac <> " " Then
Newtext = Mid(Newtext, 1, POSI) + String(1, " ") + Mid(Newtext, POSI + 1)
POSI = POSI + 1
CI = CI + 1
End If
PoscharBreak = PoscharBreak + 1
If PoscharBreak = SpacesInStr Then
PoscharBreak = 0
POSI = 0
End If
End If
POSI = POSI + 1
Loop
FinalText = FinalText + Newtext + Chr(13) + Chr(10)
Newtext = ""
I = MaxPos
MaxPos = 0
inicio = I + 1
Else
MaxPos = I
End If
End Select
I = I + 1
Loop
Justifica = FinalText & Newtext
Exit_Justifica:
Exit Function
Err_Justifica:
Resume Exit_Justifica
End Function
Para um form arraste 2 textboxs e 1 CommandButton
No CommandButton, escreva:
Me![Text2] = Justifica(Me![Text1], Me![Text2], Me)
