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

 

  Fórum

  Visual Basic
Voltar
Autor Assunto:  Abreviar Nomes
Defende
JARINÚ
SP - BRASIL
Postada em 05/07/2007 12:53 hs            
Alguem conhece alguma funcao que faca por exemplo isso aqui:

Rodrigo Mendes Defende Freitas = Rodrigo M. D. Freitas

Valeus
     
PC²
Pontos: 2843 Pontos: 2843
JUCUTUQUARA, VITÓRIA
ES - BRASIL
ENUNCIADA !
Postada em 05/07/2007 13:42 hs            
A funcção abaixo faz quase isto. mas vc pode alterar seu código para sua necessidade.
 
 
 
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

____________________________

PC²   T+

 

   
Defende
JARINÚ
SP - BRASIL
ENUNCIADA !
Postada em 05/07/2007 13:58 hs            
Valeu pela dica mas eu usei e nao mudou nada.
O que seria o parametro nMax?

Eu coloquei Rodrigo Mendes Defende Freitas e retornou a mesma coisa.

Valeu
   
jorge
não registrado
ENUNCIADA !
Postada em 22/10/2008 21:57 hs   
qual abreviatura do nome brasil
   
Guaitoli
Pontos: 2843
SÃO PAULO
SP - BRASIL
ENUNCIADA !
Postada em 23/10/2008 16:25 hs            
Usa isso ai acredito que resolva

Private Function Abreviar(ByVal Nome As String) As String
    Dim vNome As Variant
    Dim i As Byte
    
    vNome = Split(Nome, " ")
    
    If UBound(vNome) > 1 Then
        Abreviar = vNome(0)
        For i = 1 To UBound(vNome) - 1
            If Len(Trim(vNome(i))) > 0 Then
                Abreviar = Abreviar & " " & Left(Trim(vNome(i)), 1) & "."
            End If
        Next i
        Abreviar = Abreviar & " " & vNome(UBound(vNome))
    Else
        Abreviar = Nome
    End If
    
End Function



[]'s
Eder Guaitoli
   
Página(s): 1/1    


Seu Nome:

Seu eMail:

ALTERAR PARA MODO HTML
Mensagem:

[:)] = 
[:P] = 
[:(] = 
[;)] = 

HTML DESLIGADO

     
 VOLTAR

  



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