GENERATEUR DE TABLEAUX DE NOMBRES POUR VB/VBA

' ------------------------ WORKBOOK OPEN
Declare Sub SetCurrentDirectoryA Lib "Kernel32.dll" (ByVal pdir As String)
' ------------------------

Declare Function bnTablEstNull Lib "bnArray.dll" (ptbl() As Any) As Long

Declare Function bnTablInt32Alea Lib "bnArray.dll" (ByVal nelems As Long) As Long()
Declare Function bnTablInt32AleaPstf Lib "bnArray.dll" (ByVal nelems As Long) As Long()
 ' PLAGE 24 BITS, 0 => 16777215
Declare Function bnTablInt32TriAZ Lib "bnArray.dll" (ptbl() As Long) As Long
 ' RETOURNE LE NBR ELEMS TRIES OU ZERO SI PAS BON
Declare Function bnTablInt32TriZA Lib "bnArray.dll" (ptbl() As Long) As Long
 ' RETOURNE LE NBR ELEMS TRIES OU ZERO SI PAS BON
Declare Function bnTablInt32INVRS Lib "bnArray.dll" (ptbl() As Long) As Long
 ' RETOURNE LE NBR ELEMS INVERSES OU ZERO SI PAS BON
Declare Function bnTablInt32AleaUnic Lib "bnArray.dll" (ByVal mini As Long, ByVal maxi As Long) As Long()
 ' PLAGE 16 BITS, mini >= 0, maxi <= 65535, maxi >= mini
 ' Sortira tableau valeurs uniques de nelems = (maxi - mini + 1)
Declare Function bnTablInt32AleaBorne Lib "bnArray.dll" (ByVal nelems As Long, ByVal mini As Long, ByVal maxi As Long) As Long()
 ' PLAGE 16 BITS, mini >= 0, maxi <= 65535, maxi >= mini
 ' AUCUN TEST D'UNICITE DES VALEURS QUI SORTENT

' ------------------------
Private Sub Workbook_Open()
  SetCurrentDirectoryA ThisWorkbook.Path
End Sub
' ------------------------

Sub TestInt32()
  Dim tabl() As Long, i As Long, maxi As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32Alea(1000)
  If bnTablEstNull(tabl) Then ' DLL RETOURNE 0 SI MANQUE DE MEMOIRE
    Cells(1, 1) = "DEFAUT MEMOIRE"
    Exit Sub
  End If
  maxi = UBound(tabl)
  For i = 0 To maxi
    Cells(i + 1, 1) = tabl(i)
  Next i
End Sub

Sub TestIn32Positifs()
  Dim tabl() As Long, i As Long, maxi As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32AleaPstf(500)
  If bnTablEstNull(tabl) Then ' DLL RETOURNE 0 SI MANQUE DE MEMOIRE
    Cells(1, 1) = "DEFAUT MEMOIRE"
    Exit Sub
  End If
  maxi = UBound(tabl)
  For i = 0 To maxi
    Cells(i + 1, 1) = tabl(i)
  Next i
End Sub

Sub TrierTablLong()
  Dim tabl() As Long, tries As Long, i As Long, ubnd As Long, r As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32AleaPstf(2000)
'  tries = bnTablInt32TriAZ(tabl) ' RETOURNE LE NBR ELEMS TRIES OU ZERO SI PAS BON
  tries = bnTablInt32TriZA(tabl) ' RETOURNE LE NBR ELEMS TRIES OU ZERO SI PAS BON
  Cells(1, 2) = tries
  If tries = 0 Then Exit Sub
  i = LBound(tabl)
  ubnd = UBound(tabl)
  If tries <> (ubnd - i + 1) Then Exit Sub
  r = 0
  While i <= ubnd
    r = r + 1
    Cells(r, 1) = tabl(i)
    i = i + 1
  Wend
End Sub

Sub ReverseTablLong()
  Dim tabl() As Long, tries As Long, i As Long, ubnd As Long, r As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32AleaPstf(25)
  tries = bnTablInt32TriAZ(tabl) ' RETOURNE LE NBR ELEMS TRIES OU ZERO SI PAS BON
  Cells(1, 2) = tries
  If tries = 0 Then Exit Sub
  i = LBound(tabl)
  ubnd = UBound(tabl)
  If tries <> (ubnd - i + 1) Then Exit Sub
  r = 0
  While i <= ubnd
    r = r + 1
    Cells(r, 1) = tabl(i)
    i = i + 1
  Wend
  tries = bnTablInt32INVRS(tabl) ' RETOURNE LE NBR ELEMS INVERSES OU ZERO SI PAS BON
  Cells(1, 4) = tries
  If tries = 0 Then Exit Sub
  i = LBound(tabl)
  ubnd = UBound(tabl)
  If tries <> (ubnd - i + 1) Then Exit Sub
  r = 0
  While i <= ubnd
    r = r + 1
    Cells(r, 3) = tabl(i)
    i = i + 1
  Wend
End Sub

Sub TestAleaUnic()
  Dim tabl() As Long, i As Long, ubnd As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32AleaUnic(0, 1000) ' TABLEAU DE (max - min + 1) NBR
  If bnTablEstNull(tabl) Then ' DLL RETOURNE 0 SI MANQUE DE MEMOIRE OU ERREUR PARAMS
    Cells(1, 2) = "ERREUR"
    Exit Sub
  End If
  ubnd = UBound(tabl)
  Cells(1, 2) = ubnd + 1
  For i = 0 To ubnd
    Cells(i + 1, 1) = tabl(i)
  Next i
End Sub

Sub TestAleaBorne()
  Dim tabl() As Long, i As Long, ubnd As Long
  Columns("A:D").ClearContents
  tabl = bnTablInt32AleaBorne(1000, 0, 1000) ' TABLEAU DE x NBR COMPRIS ENTRE min ET max INCLUS
  If bnTablEstNull(tabl) Then ' DLL RETOURNE 0 SI MANQUE DE MEMOIRE OU ERREUR PARAMS
    Cells(1, 2) = "ERREUR"
    Exit Sub
  End If
  ubnd = UBound(tabl)
  Cells(1, 2) = ubnd + 1
  For i = 0 To ubnd
    Cells(i + 1, 1) = tabl(i)
  Next i
End Sub

Télécharger le zip

26 octobre 2005 16:40:04 :

Site

08 octobre 2006 14:07:53 :

site