J'ai regroupé ci-dessous quelques
 Fonctions qui me semblaient utiles


nombre aléatoire entre mini et maxi

  Télécharger 

Public Function Alea(ByVal Mini As Double, ByVal Maxi As Double) As Double
Alea = Mini + (Rnd * (Maxi - Mini + 1))
End Function

  
test si bits tous à 1

  Télécharger 

Public Function BitA1(ByVal V As String, ByVal B As String) As Boolean
Select Case (V And B)
    Case Is = B
        BitA1 = True
    Case Else
        BitA1 = False
End Select
End Function
  
le plus grand des 2 nombres

  Télécharger 

Public Function PlusGrand(ByVal A As Double, ByVal B As Double) As Double
PlusGrand = (-A * (A >= B) - B * (B > A))
End Function

  
le plus petit des 2 nombres

  Télécharger 

Public Function PlusPetit(ByVal A As Double, ByVal B As Double) As Double
PlusPetit = (-A * (A <= B) - B * (B < A))
End Function

  
Nbr jours entre 2 dates

  Télécharger 

Public Function DateDifference _
    (ByVal DateDebut As String, ByVal DateFin As String) As Double
'----------------------------------------
'appel : retour=(date début , date fin )
'        double  jj/mm/aaaa   jj/mm/aaaa
'----------------------------------------
Dim A As Integer, M As Integer, J As Integer
Dim Cal, Cal1 As Double
DateVal DateDebut, A, M, J
GoSub DateCalcul
DateDifference = Cal
DateVal DateFin, A, M, J
GoSub DateCalcul
DateDifference = DateDifference - Cal
Exit Function
DateCalcul:
Cal = A
If M <= 2 Then Cal = (Cal - 1)
Cal1 = A
Cal1 = Cal1 * 365
Cal = Cal + J + Cal1 + ((M - 1) * 31)
If M <= 2 Then Cal = Cal - Int(((M * 40) + 230) / 100)
Return
End Function

  
Libellé d'une Date

  Télécharger 

Public Function DateLib(ByVal Dat As String) As String
'-------------------------------------------------
'appel  : l = date_lib ( date )
'         string         jj/mm/aaaa
'retour : libellé date llllllll jjj mmmmmmmmm aaaa
'-------------------------------------------------
Dim J(7), M(12) As String, C1, C2, vA, vM, vJ As Integer
J(1) = "Lundi": J(2) = "Mardi": J(3) = "Mercredi": J(4) = "Jeudi"
J(5) = "Vendredi": J(6) = "Samedi": J(7) = "Dimanche"
M(1) = "Janvier": M(2) = "Février": M(3) = "Mars"
M(4) = "Avril": M(5) = "Mai": M(6) = "Juin"
M(7) = "Juillet": M(8) = "Août": M(9) = "Septembre"
M(10) = "Octobre": M(11) = "Novembre": M(12) = "Décembre"
vA = Val(Right(Dat, 4))    ' JJ/MM/AAAA
vM = Val(Mid(Dat, 4, 2))
vJ = Val(Left(Dat, 2))
If vM <= 2 Then vM = vM + 12: vA = vA - 1
C1 = (vJ - 1) _
    + Int((Int((vA * 5)) / 4)) _
    - Int(vA / 100) _
    + Int(vA / 400) _
    + Int(((vM + 1) * 13) / 5)
C2 = (Int(C1 / 7) * 7)
C1 = C1 - C2
If C1 < 1 Then C1 = 7
DateLib = J(C1) & " "
Select Case Val(Left(Dat, 2))
    Case Is >= 10
        DateLib = DateLib & Left(Dat, 2)
    Case Else
        DateLib = DateLib & Mid(Dat, 2, 1)
        If Val(Left(Dat, 2)) = 1 Then DateLib = DateLib & "er"
End Select
DateLib = DateLib & _
        " " & M(Val(Mid(Dat, 4, 2))) & _
        " " & Right(Dat, 4)
End Function

  
date fin de mois

  Télécharger 

Public Function DateFinMois(ByRef FM() As Integer, ByVal Dat As String)
'----------------------------------------------------------------------
'appel: datefinmois ( table fin de mois (12) , date JJ/MM/AAAA )
'----------------------------------------------------------------------
Dim Aa As Integer, Mm As Integer, Jj As Integer
FM(1) = 31: FM(2) = 28: FM(3) = 31: FM(4) = 30
FM(5) = 31: FM(6) = 30: FM(7) = 31: FM(8) = 31
FM(9) = 30: FM(10) = 31: FM(11) = 30: FM(12) = 31
DateVal Dat, Aa, Mm, Jj
If (Aa Mod 4) = 0 and ( (Aa mod 100) <> 0 or (Aa mod 400) = 0) Then  
            FM(2) = 29
End If
End Function

  
libellé d'un jour

  Télécharger 

Public Function DateJourLib(ByVal No As Integer) As String
'----------------------------------------------
'appel  : libellé = datejourlib ( n° jour )
'n° jour => libellé du jour
'----------------------------------------------
Dim J(7) As String
J(1) = "Lundi": J(2) = "Mardi": J(3) = "Mercredi": J(4) = "Jeudi"
J(5) = "Vendredi": J(6) = "Samedi": J(7) = "Dimanche"
DateJourLib = J(No)
End Function

  
n° jour dans la semaine

  Télécharger 

Public Function DateJourNo(ByVal Dat As String) As Integer
'------------------------------------------------------
'jj/mm/aaaa => n° jour
'appel  : n° jour = datejourno ( date : JJ/MM/AAAA )
'retour : n° jour dans la semaine
'------------------------------------------------------
Dim C2, vA, vM, vJ As Integer
vA = Val(Right(Dat, 4))    ' JJ/MM/AAAA
vM = Val(Mid(Dat, 3, 2))
vJ = Val(Left(Dat, 2))
If vM <= 2 Then
    vM = vM + 12
    vA = vA - 1
End If
DateJourNo = (vJ - 1) _
    + Int((Int((vA * 5)) / 4)) _
    - Int(vA / 100) _
    + Int(vA / 400) _
    + Int(((vM + 1) * 13) / 5)
C2 = (Int(DateJourNo / 7) * 7)
DateJourNo = DateJourNo - C2
If DateJourNo < 1 Then DateJourNo = 7
End Function

  
libellé du mois

  Télécharger 

Public Function DateMoisLib(ByVal No As Integer) As String
'----------------------------------------------
'appel  : libellé = datemoislib ( n° mois )
'n° mois => libellé du mois
'----------------------------------------------
Dim M(12) As String
M(1) = "Janvier": M(2) = "Février": M(3) = "Mars"
M(4) = "Avril": M(5) = "Mai": M(6) = "Juin"
M(7) = "Juillet": M(8) = "Août": M(9) = "Septembre"
M(10) = "Octobre": M(11) = "Novembre": M(12) = "Décembre"
DateMoisLib = M(No)
End Function

  
n° semaine

  Télécharger 

Public Function DateSemaine(ByVal Dat As String) As Integer
'---------------------------------------------------------
'appel  : n° semaine = datesemaine ( date JJ/MM/AAAA )
'---------------------------------------------------------
Dim Aa As Integer, Mm As Integer, Jj As Integer
Dim FM(12) As Integer, n As Integer
DateVal Dat, Aa, Mm, Jj
n = DateJourNo("01/01/" & Right(Dat, 4))
Jj = Jj + n - 1
DateFinMois FM(), Dat
DateSemaine = Jj
If Mm > 1 Then
    For n = 1 To (Mm - 1)
        DateSemaine = DateSemaine + FM(n)
    Next n
End If
DateSemaine = 1 + Int((DateSemaine - 1) / 7)
End Function

  
"JJ/MM/AAAA" vers jj, mm, aaaa

  Télécharger 

Public Function DateVal( _
    ByVal JMA As String, ByRef Aa As Integer, _
    ByRef Mm As Integer, ByRef Jj As Integer)
'----------------------------------------------------------
'éclatement d'une date en valeur
'appel  :  DateVal ( DateDépart , année, mois, jour )
'                    JJ/MM/AAAA   integer's'
'----------------------------------------------------------
Aa = Val(Right(JMA, 4))
Mm = Val(Mid(JMA, 4, 2))
Jj = Val(Left(JMA, 2))
End Function

  
Répertoire, Fichier ou Erreur ?

  Télécharger 

Public Function FichRep(ByVal n As String) As Integer
'------------------------------------------------------------
' dit si  <n> est un répertoire ( 1 ) ou un fichier ( 2 )
'     ou s'il y a eu une erreur ( 0 )
'------------------------------------------------------------
On Error GoTo FichRepErr
Select Case (GetAttr(n) And vbDirectory)
    Case Is = vbDirectory
        FichRep = 1
    Case Else
        FichRep = 2
End Select
Exit Function
FichRepErr:
FichRep = 0
End Function

  
nom de fichier valide ?

  Télécharger 

Public Function NomFichierValide _
    (ByVal Fichier As String, ByVal Appel As Boolean) As Boolean
'--------------------------------------------------------------------------------
' [support:\[répertoire[\sous répertoire ... ]]] nom fichier [ . extension ]
' IF NomFichierValide("fichier",?)=true le nom de fichier est valide
'                                 =false sinon
' on contrôle si [support:\[répertoire[\sous répertoire ... ]]] existe
'             si nom fichier[.extension]                        est autorisé
' appel=true si répertoire\fichier, si fichier=>appel=false
'--------------------------------------------------------------------------------
Dim I As Integer, R, F As String
NomFichierValide = False
If Len(Fichier) = 0 Then Exit Function '====vide
If Appel = False Then GoTo NomFichierValideFich
Select Case InStr(Fichier, "\")
    Case Is = 0
NomFichierValideFich:
        F = Fichier
    Case Else
        For I = Len(Fichier) To 1 Step -1
            If Mid(Fichier, I, 1) = "\" Then
                F = Right(Fichier, Len(Fichier) - I)
                R = Left(Fichier, I)
                If Len(Dir(R, _
                    vbNormal + vbHidden + vbSystem + vbDirectory)) = 0 Then
                        Exit Function '====répertoire n'existe pas
                End If
                Exit For
            End If
        Next I
End Select
If F = String(Len(F), ".") Then Exit Function '====que des "."
If F = Space(Len(F)) Then Exit Function '====que des " "
For I = 1 To Len(F) 'contrôle si caractères interdits
    If Mid(F, I, 1) < " " Then Exit Function
    If InStr("/\[]:|<>+=;," & Chr(34), Mid(F, I, 1)) Then Exit Function
Next I
NomFichierValide = True
End Function

  
Sélection Multiple

  Télécharger 

Public Function PlusieursNoms _
    (ByRef Deb As String, ByRef Rep As String, ByRef Fic As String)
'----------------------------------------------------------------------
' si (par exemple) "CommonDialog1" = "show.open" ==>
'   au retour "CommonDialog1.FileName"
'   = '1 seul fichier     OU
'   = 'répertoire¤fichier1¤fichier2¤fichier3...¤fichiern'
'           avec ¤=chr(0), si plusieurs fichiers
' PlusieursNoms délivre ces noms des fichiers les uns après les autres
' With Commondialog1 ....
'   .Flags = cdlOFNExplorer + cdlOFNHideReadOnly + _
'            cdlOFNAllowMultiselect cdlOFNNoDereferenceLinks
'   .ShowOpen ...
' End With ....
' Appel : r = vbNullString           } ne pas
'         d = CommonDialog1.filename } oublier
'         PlusieursNoms d, r, f      } pour 1er appel
'         While Len(f) > 0
'             ... faire ce que l'on doit avec 'f' ...
'             plusieurs_noms d, r, f } appels pour suivants
'         Wend ...
'----------------------------------------------------------------------
Dim I As Integer
Select Case Len(Deb)
    Case Is = 0                 '«««« répertoire initial vierge »»»»
        Fic = vbNullString
        Rep = vbNullString
    Case Else
        I = InStr(Deb, Chr(0))
        If Len(Rep) = 0 Then    '«««« 1er appel »»»»
            Select Case I
                Case Is = 0     '«««« 1 seul fichier »»»»
                    Fic = Deb
                    Deb = vbNullString
                    Exit Function
                Case Else       '«««« plusieurs fichiers »»»»
                    'deb=répertoire¤fichier1¤fichier2¤fichier3...¤fichiern
                    Rep = Left(Deb, I - 1)
                    'rep=répertoire
                    Deb = Right(Deb, Len(Deb) - I) & Chr(0)
                    'deb=fichier1¤fichier2¤fichier3...¤fichiern¤
                    I = InStr(Deb, Chr(0))
            End Select
        End If
        Fic = Rep & "\" & Left(Deb, I - 1)
        'fic=fichier1                           ou fichier2
        Deb = Right(Deb, Len(Deb) - I)
        'deb=fichier2¤fichier3...¤fichiern¤     ou fichier3...¤fichiern¤
End Select
End Function

  
Nombre Formaté

  Télécharger 

Public Function NombreFormate _
    (ByVal V As Double, _
     ByVal E As Integer, ByVal D As Integer) As String
'--------------------------------------------------
' NombreFormate ( valeur , entiers , décimales ) 
'--------------------------------------------------
Dim A As Integer, S As String
E = E + 1
NombreFormate = (V * (10 ^ D)) / (10 ^ D)
If Left(NombreFormate, 1) = "-" Then
    S = "-"
    NombreFormate = Right(NombreFormate, Len(NombreFormate) - 1)
End If
A = InStr(NombreFormate, ",")
Select Case A
    Case 0              'Ÿ Entiers
        If Len(NombreFormate) < E Then
            NombreFormate = String(E - Len(NombreFormate), " ") & _
                            NombreFormate
        End If
        If D > 0 Then NombreFormate = NombreFormate & _
                                      "," & String(D, "0")
    Case Else           'Ÿ Entiers,Décimales
        Select Case (Len(NombreFormate) - A)
            Case Is < D     'Ÿ pas assez de décimales
                NombreFormate = NombreFormate & _
                                String(D - (Len(NombreFormate) - A), "0")
            Case Is > D     'Ÿ trop de décimales
                NombreFormate = Left(NombreFormate, A + D)
                If Right(NombreFormate, 1) = "," Then
                    NombreFormate = Left(NombreFormate, Len(NombreFormate) - 1)
                End If
        End Select
        If A <= E Then 'Ÿ pas assez d'entiers
            NombreFormate = String(E - A + 1, " ") & _
                            NombreFormate
        End If
End Select   'Ÿ bEntiers,Décimales0
If S = "-" Then
    A = 1
    While Mid(NombreFormate, A, 1) = " "
        A = A + 1
    Wend
    Mid(NombreFormate, A - 1, 1) = S
End If      'Ÿ bSEntiers,Décimales0
End Function

  
Recherche dychotomique

  Télécharger 

Public Function RchDycTab(ByVal argument As String, _
    ByRef tableau() As String, ByVal poste_maxi As Integer) As Integer
'----------------------------------------------------------------------
'appel  : indice = Rch_Dyc_Tab( argument, tableau(),  nbr postes maxi)
'         integer               string    string()    integer
'retour : indice = 0 ou "n° poste" si argument trouvé
'----------------------------------------------------------------------
Dim bi, bs, p As Integer
If argument = tableau(1) Then
    RchDycTab = 1
    Exit Function
End If
If argument < tableau(1) Then
    RchDycTab = 0
    Exit Function
End If
If argument = tableau(poste_maxi) Then
    RchDycTab = poste_maxi
    Exit Function
End If
If argument > tableau(poste_maxi) Then
    RchDycTab = 0
    Exit Function
End If
bi = 0
bs = poste_maxi + 1
RcheTabe:
p = Int(((bi + 1) + (bs - 1)) / 2)
If p = bi Then
    RchDycTab = 0
    Exit Function
End If
If argument < tableau(p) Then
    bs = p
    GoTo RcheTabe
End If
If argument > tableau(p) Then
    bi = p
    GoTo RcheTabe
End If
RchDycTab = p
End Function