USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (Datas/Números/Strings)

Título da Dica:  Rotina que retorna nome para crachá.
Postada em 13/3/2004 por Enigm@      Clique aqui para enviar email para o autor  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
 


CyberWEB Network Ltda.    © Copyright 2000-2024   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página