Extraire le prénom et le Nom

[Michael DELIQUE]

voici une fonction qui renvoi le nom et le prénom séparement.

Code : Tout sélectionner

Public Function ExtractPrenomNom(Byval wNomNotes As String) As Variant
   
   'Cette Fonction extrait le nom et le prenom d'un nom notes
   'convention de départ le nom est en majuscule et le prénom en misnuscule
   
   'Déclaration de variables
   Dim nmName As notesName
   Dim LstValue List As String
   Dim Selection As String
   Dim Char As String
   Dim nbValue As Integer
   Dim i  As Integer
   Dim J As Integer
   
   
   On Error Goto ErreurHandle
   
   LstValue("NOM") = ""
   LstValue("PRENOM") = ""
   
   'extraction du nom prénom
   If Trim(wNomNotes) ="" Then
      ExtractPrenomNom = LstValue
      Erase LstValue
      Exit Function
   Else
      Set nmName = New NotesName(wNomNotes)
      Selection = Trim(nmName.Common)
      Set nmName = Nothing
      If Trim(Selection) ="" Then
         ExtractPrenomNom = LstValue
         Erase LstValue
         Exit Function
      End If   
   End If
   
   i = Len(Selection)
   J = 0
   
   'recherche de la premiere minuscule indiquand la fin du prénom
   While J = 0
      Char = Mid(Selection,I,1)
      Select Case Asc(Char)
   '   Case "a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z"
      Case Asc("a") To Asc("z")
         J = I
      Case Else
         I = I-1
      End Select         
      If i = 0 Then
         J = 1
      End If
      Char = ""
   Wend
   
   If J = 1 Then
      LstValue("NOM") = Selection
      LstValue("PRENOM") = Selection
      ExtractPrenomNom = LstValue
      Erase LstValue
      Exit Function
   End If
   
   nbValue = True
   
   i = J
   J = 0
   
   'recherche de la premiere majuscule indiquand le début du nom
   While nbValue = True
      Char = Mid(Selection,i,1)
      Select Case Asc(Char)
'      Case "A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z"
      Case Asc("A") To Asc("Z")
         nbValue = False
      Case Else
         i = i+1
      End Select         
      
      If i > Len(Selection) Then
         nbValue = False
      End If
      Char =  ""
   Wend
   
   If i = Len(Selection) Then
      LstValue("NOM") = Selection
      LstValue("PRENOM") = Selection
      ExtractPrenomNom = LstValue
      Erase LstValue
      Exit Function
   End If
   
   nbValue = True
   
   'recherche du premiere espace avant le nom donnant la postion exact de la séparatione ntre le nomet le prenom
   While nbValue = True
      Char = Mid(Selection,i,1)
      If Char = " " Then
         nbValue = False
      Else
         i = i-1
      End If
      
      If i = 1 Then
         nbValue = False
      End If
      
      Char = ""
   Wend
   
   If I = 1 Then
      LstValue("NOM") = Selection
      LstValue("PRENOM") = Selection
      ExtractPrenomNom = LstValue
      Erase LstValue
      Exit Function
   Else
      LstValue("NOM") = Trim(Right(Selection,Len(Selection)-i))
      LstValue("PRENOM") = Trim(Left(Selection,i))
   End If
   
   ExtractPrenomNom = LstValue
   Erase LstValue
   Exit Function
   
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Set Session = New NotesSession
   Call Error_LOG(Cstr(Session.Username),Cstr(Now),Structure_Log,Cstr(Getthreadinfo (1)),Cstr(Err),Cstr(Error),Cstr(Erl))
   LstValue("NOM") = ""
   LstValue("PRENOM") = ""
   ExtractPrenomNom = LstValue
   Erase LstValue
   Exit Function
End Function