|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Datas/Números/Strings)
|
|
 |
Título da Dica: Rotina que retorna nome para crachá.
|
 |
|
|
|
Postada em 13/3/2004 por Enigm@
crisunao@onmail.com.br
' **************************************************
' Parametros:
' sNome: Nome a ser formatado
' nMax: Número máximo de caracteres permitido no nome
' **************************************************
Public Function NomeCracha(sNome As String, nMax As Integer) As String
'
Dim Primeiro As String, Ultimo As String ' Primeiro e Último Nome.
Dim PIni As Integer, PFim As Integer ' Posições de Início e Fim da string.
Dim Old As String, I As Integer ' Armazenar caracter.
Dim Achou As Boolean
On Error GoTo err_NomeCracha
If Len(Trim((sNome))) = 0 Then Exit Function
I = Len(Trim(sNome))
'
Primeiro = Left(sNome, InStr(sNome, " "))
Ultimo = Right(sNome, (I - InStrRev(sNome, " ")))
'
If sNome = (Primeiro & Ultimo) Or I <= nMax Then
I = Len(Trim(Primeiro & Ultimo))
If I > nMax Then
NomeCracha = Trim(Primeiro)
Else
NomeCracha = Trim(sNome)
End If
Exit Function
End If
'
Select Case UCase(Trim(Ultimo))
Case "JUNIOR", "JÚNIOR": Achou = True: Ultimo = "JR."
Case "FILHO": Achou = True: Ultimo = "Fº."
Case "FILHA": Achou = True: Ultimo = "Fª."
Case "NETO", "NETA": Achou = True
Case "Fº", "Fº.": Achou = True: Ultimo = "Fº."
Case "Fª", "Fª.": Achou = True: Ultimo = "Fª."
Case "F", "F.": Achou = True: Ultimo = "F."
Case "JR", "JR.": Achou = True: Ultimo = "JR."
Case Else: Achou = False
End Select
'
If Achou Then
PFim = I - Len(Right(sNome, (I - InStrRev(sNome, " "))))
PFim = InStrRev(Left(sNome, (PFim - 1)), " ")
Else
PFim = I - Len(Ultimo)
End If
'
PIni = InStrRev(Left(sNome, (PFim - 1)), " ")
Old = Mid(sNome, (PIni + 1), (PFim - (PIni + 1)))
Select Case UCase(Trim(Old))
Case "DA", "DE", "DI", "DO", "DOS", "DAS": Achou = True
Case Else: Achou = False
End Select
'
If Achou And PIni > 0 Then
NomeCracha = Trim(Primeiro) & Mid(Trim(sNome), PIni, (InStrRev(sNome, " ") - PIni)) & " " & Ultimo
Else
NomeCracha = Trim(Primeiro) & Mid(Trim(sNome), PFim, (InStrRev(sNome, " ") - PFim)) & " " & Ultimo
End If
'
' Verif. se o Texto cabe no campo.
I = Len(Trim(NomeCracha))
If I > nMax Then
NomeCracha = Trim(Primeiro) & " " & Ultimo
'
I = Len(Trim(NomeCracha))
If I > nMax Then NomeCracha = Trim(Primeiro)
End If
Exit Function
'
err_NomeCracha:
NomeCracha = Trim(sNome)
On Error GoTo 0
End Function
|
|
|
|
|
