DominoArea.org [Archive]

il est des cas ou l'on a besoin d'un formatage bien précis, voici une fonction qui permet de le faire

Code : Tout sélectionner

Public Function FormatNumerique(wValeur As String,wFormat As String) As String
   
   'cette fonction format le numérique
   'wValeur est la valeur à formater
   'wFormat est le format à appliquer
   'ex 5V.4S-   => 5 chiffre avant la virgule, 4 chiffre apres la virgule, la vigule est un point le séparateur de millier est le tiret
   
   'Déclaration des Variables   
   Dim AvantVirgule As String
   Dim ApresVirgule As String
   Dim Valeur2 As String
   Dim Separator1000 As String
   Dim Virgule As String
   Dim VirguleOrigine As String
   Dim nbTaille As Integer
   Dim nbAvantVirgule As Integer
   Dim nbApresVirgule As Integer
   Dim i As Long
   Dim J As Long
   Dim nbValue As Integer
   
   On Error Goto ErreurFormatNumerique
   
   If Trim(wValeur) ="" Then
      FormatNumerique = ""
      Exit Function
   End If
   
   If Trim(wFormat) ="" Then
      FormatNumerique = wValeur
      Exit Function
   End If   
   
   'récupération des différente information du format passer en paramêtre
   nbAvantVirgule = Cint(Strleft(wFormat,"V"))
   If wFormat Like "*S*" Then
      Valeur2 = Strleft(Strright(wFormat,"V"),"S")
      If Left(Valeur2 ,1) Like "*[0-9]*" Then
         virgule = ""
      Else
         virgule = Left(Valeur2 ,1)
         Valeur2 = Right(Valeur2,Len(Valeur2)-1)
      End If
     
      nbApresVirgule = Cint(Valeur2)
      Separator1000 = Strright(wFormat,"S")
   Else
      Valeur2 = Strright(wFormat,"V")
      If Left(Valeur2 ,1) Like "*[0-9]*" Then
         virgule = ""
      Else
         virgule = Left(Valeur2 ,1)
         Valeur2 = Right(Valeur2,Len(Valeur2)-1)
      End If
      nbApresVirgule = Cint(Valeur2)
      Separator1000 = ""
   End If
   
   Valeur2 = ""
'   Valeur2 = wValeur
   
   'renvoi un nombre uniquement formé de chiffre avec juste le séparateur de décimal d'origine
   'est considére comme séparateur de décimal le premié point ou virgule trouvé lorsque l'on explore le nombre de droite à gauche
   For i = Len(wValeur) To 1 Step -1
      If Mid(wValeur , i,1) Like "*[0-9]*" Then
         Valeur2 = Mid(wValeur , i,1)+Valeur2
      Else   
         If Trim(VirguleOrigine) = "" Then
            Select Case Mid(wValeur , i,1)
            Case ".",","               
               VirguleOrigine = Mid(wValeur , i,1)
               Valeur2 = Mid(wValeur , i,1)+Valeur2
            Case Else
               VirguleOrigine = "PAS DE VIRGULE"
            End Select
         End If
      End If
   Next
   
   
   AvantVirgule  = ""
   nbTaille = Len(Valeur2)
   i = 0
   nbValue = True
   
   'met au format les chiffre avant la virgule
   While nbValue = True
     
      If Left(Valeur2 ,1) Like "*[0-9]*" Then
         AvantVirgule = AvantVirgule+Left(Valeur2,1)
         Valeur2 = Right(Valeur2,Len(Valeur2)-1)
      Else
         nbValue = False
      End If
     
      i = i + 1   
     
      If i>nbTaille  Then
         nbValue = False
      End If
   Wend
   
   Valeur2 =  ""
   i = 0
   
   'insere le séparateur de millier si nécessaire
   If Separator1000<>"" Then
      Valeur2 = AvantVirgule
      nbTaille = Len(AvantVirgule)
      AvantVirgule = ""
      J = 0
      While i<nbTaille
         J = J+1
         AvantVirgule = Right(Valeur2,1)+AvantVirgule
         Valeur2 = Left(Valeur2,Len(Valeur2)-1)
         If J = 3 Then
            J = 0
            AvantVirgule = Separator1000+AvantVirgule
         End If
         i =i+1
         
      Wend
     
   End If
   
   'si le chiffre avant la virgule est plus long que la taille passé en paramêtre, c'est indiqué par un # en fin de chiffre
   If  nbAvantVirgule > 0 Then
      If Len(AvantVirgule) > nbAvantVirgule Then
         AvantVirgule = Left(AvantVirgule,nbAvantVirgule-1)+"#"
      Else
         AvantVirgule = Complete_LS(AvantVirgule,"G","0",nbAvantVirgule)
      End If
   End If
   
   ApresVirgule  = ""
   
   'mise au format pour les chiffres apres la virgule
   Valeur2 = wValeur
   nbTaille = Len(wValeur)
   i = 0
   nbValue = True
   While nbValue = True
     
      If Right(Valeur2 ,1) Like "*[0-9]*" Then
         ApresVirgule = Right(Valeur2,1)+ApresVirgule
         Valeur2 = Left(Valeur2,Len(Valeur2)-1)
      Else
         nbValue = False
      End If
     
      i = i + 1   
     
      If i>nbTaille  Then
         nbValue = False
      End If
   Wend
   
   Valeur2 = ""
   
   i = 0
   
   If nbApresVirgule > 0 Then
      If Len(ApresVirgule) > nbApresVirgule Then
         ApresVirgule = Right(ApresVirgule,nbApresVirgule)
      Else
         ApresVirgule = Complete_LS(ApresVirgule,"D","0",nbApresVirgule)
      End If
   End If
   
   FormatNumerique = AvantVirgule+virgule+ApresVirgule
   
   Exit Function
ErreurFormatNumerique:
   Msgbox "(FormatNumerique)"+Chr(10)+"Erreur " + Str(Err) + " : " + Cstr(Error)+Chr(10)+"Ligne N° "+Cstr(Erl),16, " ERREUR !"
   FormatNumerique = ""
   Exit Function
End Function

Code : Tout sélectionner

Function Complete_LS(Byval wValeur As String, Byval wSens As String,Byval wChar As String, Byval wnbTaille As Long) As String
   
   'cette fonction permet de compléter une chaine de caratecre
   'wValeur = valeur a compléter
   'wSens = complétéer a gauche ou a droite
   ' wChar = Caratere a rajouter pour compléter
   'wnbTaille = nombre de caratere a renvoyer
   
   'Déclaration des Variables   
   Dim ValeurTempo As String
   
   On Error Goto ErreurComplete_LS
   
   If wChar = "" Then
      Complete_LS = wValeur
      Exit Function
   End If   
   
   If wnbTaille = 0 Then
      Complete_LS = wValeur
      Exit Function
   Else
      If Len(wValeur) >= wnbTaille Then
         Complete_LS = wValeur
         Exit Function
      End If
   End If
   
   ValeurTempo = wValeur
   
   While Len(ValeurTempo) < wnbTaille
      Select Case Ucase(Trim(wSens))
      Case "GAUCHE","G","LEFT","L"
         ValeurTempo = wChar+ValeurTempo
      Case "DROITE","D","RIGHT","R"
         ValeurTempo = ValeurTempo+wChar
      Case Else
         Complete_LS = wValeur
         Exit Function
      End Select
   Wend
   
   Complete_LS = ValeurTempo
   ValeurTempo = ""
   
   Exit Function
ErreurComplete_LS:
   Msgbox "(Complete_LS) Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Complete_LS = ""
   Exit Function
End Function