✔ Programação GLOBAL®: VBA Tips - Inserindo quebra automática

VBA Tips - Inserindo quebra automática - Insert automatic line breaks

| Blog Office VBA | Blog Excel | Blog Access |

A funcionalidade a seguir teria me poupado muito tempo nas inúmeras vezes que precisei de algo assim.

Em certas circunstâncias específicas juntamos as informações de inúmeros campos para compor um texto. Ao apresentá-lo, invariavelmente teremos um espaço limitado.

A função abaixo permite que formatemos a frase delimitando onde será realizada a mudança de linha.

Muito útil em highlights de apresentações Powerpoint, quando a composição dos comentários é formada por várias fontes de dados como tabelas e gráficos.

Pode acelerar muito a composição de Dashboards, onde os comentários são seguidos de números e ranges. O texto ficará automaticamente pré-formatado.

Certamente será ainda mais útil na composição de infográficos

Public Function BreakTextAtX (_

varOriginal As Variant, _

Optional strBreakCharacter As String = " ", _

Optional lngMaxLength As Long = 72) As Variant

' Code written by Ken Snell -- 15 November 2008

' strOriginal is the original text string

' strBreakCharacter is the character that is used to break the

' text into separate lines (e.g., a blank space); if no

' character is provided to the function, it uses a blank

' space as the value

' lngMaxLength is the maximum length for each separate line;

' if no length is provided ot the function, it uses 72

' as the maximum length

Dim strNewString As String, strWorking As String, strPart As String

Dim strOriginalNoCrLf As String

Dim lngPosition As Long, lngHold As Long, lngLength As Long

Dim lngWorkLength As Long

Let lngLength = Len(varOriginal & "")

If lngLength > 0 Then

Let strOriginalNoCrLf = Replace(Replace(CStr(varOriginal), vbCr, ""), vbLf, "")

Let strNewString = ""

Let lngPosition = 1

Do While lngPosition <= lngLength

Let strWorking = Mid(strOriginalNoCrLf, lngPosition, lngMaxLength)

Let lngWorkLength = Len(strWorking)

If lngWorkLength < lngMaxLength Then

If Len(strNewString) > 0 And Len(strWorking) > 0 Then _

Let strNewString = strNewString & vbCrLf

Let strNewString = strNewString & strWorking

Exit Do

Else

Let lngHold = InStrRev(strWorking, strBreakCharacter)

If lngHold = 0 Then Let lngHold = lngWorkLength

If Len(strNewString) > 0 Then _

Let strNewString = strNewString & vbCrLf

Let strNewString = strNewString & Left(strWorking, lngHold)

Let lngPosition = lngPosition + lngHold

End If

Loop

Let BreakTextAtX = strNewString

Else

If IsNull(varOriginal) = True Then

Let BreakTextAtX = varOriginal

Else

Let BreakTextAtX = ""

End If

End If

End Function