Treze
|
SÃO VICENTE
SP - BRASIL
|
|
ENUNCIADA !
|
|
|
Postada em 08/09/2011 13:30 hs
Carlos você trouxe ao topico de 2005, vc não justifica nada em textbox, somente em Richtextbox. |
|
|
|
|
|
|
|
Postada em 08/09/2011 14:30 hs
Treze eu sei que o topico é antigo, mas foi apenas para não criar outro.
Dificil aceitar que o VB não tenha como justificar.
O Richtextbox não me atende pelo fato que necessita de OCX e eu queria algo sem usar outro controle, mesmo assim um campo texto multiline teria o mesmo efeito em um Richtextbox.
A função deveria da certo, acho que falta ajustar algum parametro, pois OverFlow ultrapassou o limite da posição e creio que seria necessário ajustar justamente neste dimensionamento da posição.
|
|
|
|
Alessandro
não registrado
|
|
Postada em 09/12/2015 16:19 hs
Boa Tarde Pessoal,
Primeiramente gostaria de agradecer o post do Mateus que elucidou e muito o problema de alinhamento que estou tendo, eu fiz algumas mudanças no código coisa pouca e também consegui visualizar e elucidar o Overflow levantado pelo Carlos.
Qualquer problema relatem, Obrigado !!!
Option Explicit
Private Sub Command1_Click()
Dim aVetor() As String
Dim intI As Integer
'Para um form arraste 2 textboxs e 1 CommandButton
'No CommandButton, escreva:
'ANTIGO
Me.Text2 = Justifica(Me.Text1, Me.Text2, Me)
'NOVO
Justificar_Texto Me.Text1, Me.Text4, Me, aVetor()
Text4.Text = ""
For intI = 0 To UBound(aVetor)
Text4.Text = Text4.Text & aVetor(intI) & Chr(13) & Chr(10)
Next
'CONVERSÃO DE PIXELS PARA TWIPS. 1 PIXEL VALE 15 TWIPS
Grid1.Column(1).Width = Val(Text3.Text)
Text3.Width = Grid1.Cell(1, 1).Width * 15
End Sub
'*****************************************************************************************************************************
' '
' ALINHAMENTO JUSTIFICADO DE TEXTO EM UM CAMPO OBJETO TEXT BOX E O RETORNO EM UM VETOR COM AS VARIAS LINHAS JUSTIFICADAS. '
' '
'*****************************************************************************************************************************
Public Sub Justificar_Texto(ByVal strTextoOriginal As String, _
ByRef Controle_de_Texto As Control, _
ByRef obj As Object, _
ByRef aVetor() As String)
Dim strCaracterPosicional As String 'Carac
Dim strNovoTexto As String 'NewText
Dim intTamanhodeEspaces As Integer 'WidthSpace
Dim intTamanhodoControle As Integer 'WidthControl
Dim intI As Integer 'I
Dim intInicio As Integer 'inicio
Dim intMaximoPosicional As Integer 'MaxPos
Dim intPosicaodoEspace As Integer 'PosSpace
Dim intTamanhodoTexto As Integer 'SizeText
'A variável FinalText troquei pelo Vetor que retornará preenchido
ReDim aVetor(0) As String
'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 = Controle_de_Texto.FontName
obj.FontSize = Controle_de_Texto.FontSize
obj.FontBold = Controle_de_Texto.FontBold
obj.FontItalic = Controle_de_Texto.FontItalic
'Obtém o tamanho da caixa de texto que irá receber o texto alinhado
intTamanhodoControle = Controle_de_Texto.Width
'Obtém o tamanho de espaço na fonte atual
intTamanhodeEspaces = obj.TextWidth(" ")
'obtém o tamanho do texto a ser justificado
intTamanhodoTexto = Len(strTextoOriginal)
intI = 1
intInicio = 1
If obj.TextWidth(strTextoOriginal) <= intTamanhodoControle Then
intMaximoPosicional = intTamanhodoControle + 1
Retorna_Linha_Justificada strTextoOriginal, _
Controle_de_Texto, _
obj, _
aVetor(), _
intTamanhodoControle, _
intTamanhodeEspaces, _
intI, _
intInicio, _
intMaximoPosicional, _
strNovoTexto
Else
Do While intI < intTamanhodoControle + 1
'extrai um caracter de cada vez
strCaracterPosicional = Mid(strTextoOriginal, intI, 1)
'cria nova sequência de caracteres
strNovoTexto = strNovoTexto + strCaracterPosicional
Select Case strCaracterPosicional
'se o caracter for ENTER - final do parágrafo ...
Case Chr(13)
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Left(strNovoTexto, Len(strNovoTexto) - 1)
strNovoTexto = ""
intI = intI + 1
intMaximoPosicional = 0
intInicio = intI + 1
'se o caracter for ESPAÇO
Case " "
If obj.TextWidth(strNovoTexto) > intTamanhodoControle Then
Retorna_Linha_Justificada strTextoOriginal, _
Controle_de_Texto, _
obj, _
aVetor(), _
intTamanhodoControle, _
intTamanhodeEspaces, _
intI, _
intInicio, _
intMaximoPosicional, _
strNovoTexto
Else
intMaximoPosicional = intI
End If
End Select
intI = intI + 1
Loop
If Len(strNovoTexto) > 0 Then
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Trim(strNovoTexto)
End If
End If
End Sub
Private Function Retorna_Linha_Justificada(ByVal strTextoOriginal As String, _
ByRef Controle_de_Texto As Control, _
ByRef obj As Object, _
ByRef aVetor() As String, _
ByRef intTamanhodoControle As Integer, _
ByRef intTamanhodeEspaces As Integer, _
ByRef intI As Integer, _
ByRef intInicio As Integer, _
ByRef intMaximoPosicional As Integer, _
ByRef strNovoTexto As String) As String
Dim intNumerodeEspaces As Integer 'NumSpaces
Dim intN As Integer 'n
Dim strCaracterPosicional As String 'Carac
Dim intEspacesInStrucoes As Integer 'SpaceInstr
Dim intPosicional As Integer 'POSI
Dim intContadorEspaces As Integer 'CI
Dim strProximoCaracter As String 'NextCarac
Dim intPoscharBreak As Integer 'PoscharBreak
'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
strNovoTexto = Mid(strTextoOriginal, intInicio, intMaximoPosicional - intInicio)
'obtém o número de espaços necessários, que deverão ser inseridos
'na nova seqüência de texto
intNumerodeEspaces = Fix((intTamanhodoControle - obj.TextWidth(strNovoTexto)) / intTamanhodeEspaces) - 1
For intN = 1 To Len(strNovoTexto)
'Calcula o número de espaços existentes na nova seqüência de texto
strCaracterPosicional = Mid(strNovoTexto, intN, 1)
If strCaracterPosicional = " " Then intEspacesInStrucoes = intEspacesInStrucoes + 1
Next intN
intPosicional = 1
intContadorEspaces = 1
intPoscharBreak = 0
Do While intContadorEspaces < intNumerodeEspaces And intPosicional <= Len(strNovoTexto)
'Insere espaços no texto nos espaços já existentes no mesmo
strCaracterPosicional = Mid(strNovoTexto, intPosicional, 1)
If strCaracterPosicional = " " Then
'Faltou andar aqui até o próximo preenchido, pois ele já adicionou espaços no texto para justificar
For intN = intPosicional + 1 To Len(strNovoTexto)
strProximoCaracter = Mid(strNovoTexto, intPosicional + 1, 1)
If strProximoCaracter <> " " Then Exit For
intPosicional = intPosicional + 1
Next
If strProximoCaracter <> " " Then
strNovoTexto = Mid(strNovoTexto, 1, intPosicional) + String(1, " ") + Mid(strNovoTexto, intPosicional + 1)
intPosicional = intPosicional + 1
intContadorEspaces = intContadorEspaces + 1
End If
intPoscharBreak = intPoscharBreak + 1
If intPoscharBreak = intEspacesInStrucoes Then
intPoscharBreak = 0
intPosicional = 0
End If
End If
intPosicional = intPosicional + 1
Loop
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Trim(strNovoTexto)
strNovoTexto = ""
intI = intMaximoPosicional
intMaximoPosicional = 0
intInicio = intI + 1
End Function
|
|
|
|
Alessandro
não registrado
|
|
Postada em 11/12/2015 14:49 hs
Pessoal eu revisei o código e agora me parece correto, eu testei num sistema de contabilidade onde possui varias bases com muitos textos por ter historicos e nome das contas analiticas é isso. Abraços,
'*****************************************************************************************************************************
' '
' ALINHAMENTO JUSTIFICADO DE TEXTO EM UM CAMPO OBJETO TEXT BOX E O RETORNO EM UM VETOR COM AS VARIAS LINHAS JUSTIFICADAS. '
' '
'*****************************************************************************************************************************
Public Sub Justificar_TextBox(ByVal strTextoOriginal As String, _
ByRef Controle_de_Texto As Control, _
ByRef Obj As Object, _
ByRef aVetor() As String, _
ByVal blnJustificado As Boolean)
Dim strCaracterPosicional As String 'Carac
Dim strNovoTexto As String 'NewText
Dim strSimbolodeBusca As String 'Procurar não só espaço como /,;
Dim intTamanhodeEspaces As Integer 'WidthSpace
Dim intTamanhodoControle As Integer 'WidthControl
Dim intI As Integer 'I
Dim IntInicio As Integer 'inicio
Dim intSimbolo As Integer 'Rodar for...next buscando o simbolo.
Dim intMaximoPosicional As Integer 'MaxPos
Dim intPosicaodoEspace As Integer 'PosSpace
Dim intTamanhodoTexto As Integer 'SizeText
Dim intPosicaoNova As Integer
'A variável FinalText troquei pelo Vetor que retornará preenchido
ReDim aVetor(0) As String
'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 = Controle_de_Texto.FontName
Obj.FontSize = Controle_de_Texto.FontSize
Obj.FontBold = Controle_de_Texto.FontBold
Obj.FontItalic = Controle_de_Texto.FontItalic
'Obtém o tamanho da caixa de texto que irá receber o texto alinhado
intTamanhodoControle = Controle_de_Texto.Width
'Obtém o tamanho de espaço na fonte atual
intTamanhodeEspaces = Obj.TextWidth(" ")
'obtém o tamanho do texto a ser justificado
intTamanhodoTexto = Len(strTextoOriginal)
intI = 1
IntInicio = 1
If Obj.TextWidth(strTextoOriginal) <= intTamanhodoControle Then
intMaximoPosicional = intTamanhodoControle + 1
Retorna_Linha_Justificada strTextoOriginal, _
Controle_de_Texto, _
Obj, _
aVetor(), _
intTamanhodoControle, _
intTamanhodeEspaces, _
intI, _
IntInicio, _
intMaximoPosicional, _
strNovoTexto, _
blnJustificado
Else
Do While intI < intTamanhodoControle + 1
'extrai um caracter de cada vez
strCaracterPosicional = Mid(strTextoOriginal, intI, 1)
'cria nova sequência de caracteres
strNovoTexto = strNovoTexto + strCaracterPosicional
Select Case strCaracterPosicional
'se o caracter for ENTER - final do parágrafo ...
Case Chr(13)
If Len(Trim(strNovoTexto)) > 0 Then
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Left(strNovoTexto, Len(strNovoTexto) - 1)
End If
strNovoTexto = ""
intI = intI + 1
intMaximoPosicional = 0
IntInicio = intI + 1
'se o caracter for ESPAÇO
Case " "
If Obj.TextWidth(strNovoTexto) > intTamanhodoControle Then
intMaximoPosicional = intI
Retorna_Linha_Justificada strTextoOriginal, _
Controle_de_Texto, _
Obj, _
aVetor(), _
intTamanhodoControle, _
intTamanhodeEspaces, _
intI, _
IntInicio, _
intMaximoPosicional, _
strNovoTexto, _
blnJustificado
Else
intMaximoPosicional = intI
End If
Case Else
If Obj.TextWidth(strNovoTexto) > intTamanhodoControle Then
'CASO NÃO ENCONTRE " " QUE É O PADRÃO ENCONTRAR OUTRO SIMBOLO
'COMO BASE DE SEPARAÇÃO, CASO NÃO ENCONTRE CORTAR O TEXTO MESMO.
For intSimbolo = 1 To 6
If intSimbolo = 1 Then
strSimbolodeBusca = " "
ElseIf intSimbolo = 2 Then
strSimbolodeBusca = "/"
ElseIf intSimbolo = 3 Then
strSimbolodeBusca = ""
ElseIf intSimbolo = 4 Then
strSimbolodeBusca = ","
ElseIf intSimbolo = 5 Then
strSimbolodeBusca = ";"
End If
'SE ESTOUROU E NÃO COMPLETOU A ULTIMA PALAVRA, COLOCA-LA NA
'LINHA SEGUINTE.
For intPosicaoNova = intMaximoPosicional To 1 Step -1
If Mid(strTextoOriginal, intPosicaoNova, 1) = strSimbolodeBusca Then
'SE A POSICAO NOVA FOR MAIOR QUE INTINICIO CHAMAR FUNÇÃO.
If intPosicaoNova < IntInicio Then
'CASO NÃO SEJA, BUSCAR POR OUTRO SIMBOLO, CASO JÁ ESTOUROU
'A PROCURA CORTAR O TEXTO.
If intSimbolo < 6 Then
Exit For
End If
Else
intI = intPosicaoNova
intMaximoPosicional = intI
End If
Retorna_Linha_Justificada strTextoOriginal, _
Controle_de_Texto, _
Obj, _
aVetor(), _
intTamanhodoControle, _
intTamanhodeEspaces, _
intI, _
IntInicio, _
intMaximoPosicional, _
strNovoTexto, _
blnJustificado And strSimbolodeBusca = " "
strSimbolodeBusca = "ACHOU"
Exit For
End If
Next
If strSimbolodeBusca = "ACHOU" Then Exit For
Next
Else
intMaximoPosicional = intI
End If
End Select
intI = intI + 1
Loop
If Len(Trim(strNovoTexto)) > 0 Then
If Len(strNovoTexto) > 0 Then
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Trim(strNovoTexto)
End If
End If
End If
End Sub
Private Function Retorna_Linha_Justificada(ByVal strTextoOriginal As String, _
ByRef Controle_de_Texto As Control, _
ByRef Obj As Object, _
ByRef aVetor() As String, _
ByRef intTamanhodoControle As Integer, _
ByRef intTamanhodeEspaces As Integer, _
ByRef intI As Integer, _
ByRef IntInicio As Integer, _
ByRef intMaximoPosicional As Integer, _
ByRef strNovoTexto As String, _
ByVal blnJustificado As Boolean) As String
Dim intNumerodeEspaces As Integer 'NumSpaces
Dim intN As Integer 'n
Dim strCaracterPosicional As String 'Carac
Dim intEspacesInStrucoes As Integer 'SpaceInstr
Dim intPosicional As Integer 'POSI
Dim intContadorEspaces As Integer 'CI
Dim strProximoCaracter As String 'NextCarac
Dim intPoscharBreak As Integer 'PoscharBreak
'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
strNovoTexto = Mid(strTextoOriginal, IntInicio, intMaximoPosicional - IntInicio)
If blnJustificado Then
'obtém o número de espaços necessários, que deverão ser inseridos
'na nova seqüência de texto
intNumerodeEspaces = Fix((intTamanhodoControle - Obj.TextWidth(strNovoTexto)) / intTamanhodeEspaces) - 1
intEspacesInStrucoes = 0
For intN = 1 To Len(strNovoTexto)
'Calcula o número de espaços existentes na nova seqüência de texto
strCaracterPosicional = Mid(strNovoTexto, intN, 1)
If strCaracterPosicional = " " Then
If intN + 1 <= Len(strNovoTexto) Then
If Mid(strNovoTexto, intN + 1, 1) <> " " Then
intEspacesInStrucoes = intEspacesInStrucoes + 1
End If
End If
End If
Next intN
intPosicional = 1
intContadorEspaces = 1
intPoscharBreak = 0
Do While intContadorEspaces < intNumerodeEspaces And intEspacesInStrucoes > 0
'Insere espaços no texto nos espaços já existentes no mesmo
strCaracterPosicional = Mid(strNovoTexto, intPosicional, 1)
If strCaracterPosicional = " " Or Len(strNovoTexto) = intPosicional Then
'Faltou andar aqui até o próximo preenchido, pois ele já adicionou espaços no texto para justificar
For intN = intPosicional + 1 To Len(strNovoTexto)
strProximoCaracter = Mid(strNovoTexto, intPosicional + 1, 1)
If strProximoCaracter <> " " Then Exit For
intPosicional = intPosicional + 1
Next
If strProximoCaracter <> " " Then
strNovoTexto = Mid(strNovoTexto, 1, intPosicional) + String(1, " ") + Mid(strNovoTexto, intPosicional + 1)
intPosicional = intPosicional + 1
intContadorEspaces = intContadorEspaces + 1
End If
intPoscharBreak = intPoscharBreak + 1
If intPoscharBreak = intEspacesInStrucoes Then
intPoscharBreak = 0
intPosicional = 0
End If
End If
intPosicional = intPosicional + 1
Loop
End If
If Len(Trim(strNovoTexto)) > 0 Then
If aVetor(0) <> "" Then
ReDim Preserve aVetor(UBound(aVetor) + 1) As String
End If
aVetor(UBound(aVetor)) = Trim(strNovoTexto)
End If
strNovoTexto = ""
intI = intMaximoPosicional
intMaximoPosicional = 0
IntInicio = intI + 1
End Function
|
|
|
|
|
