Generateur de tableaux de nombres pour vb/vba

Télécharger le projet
Commenter

Description

Démo faite sur Excel.
Fichier xls, dll (C et ASM), et txt contenant code de la dll dans zip.
La dll ne génère que des tableaux de Long dans cette démo, chacun étendra selon ses besoins, si problème demander.
Si gros tableau généré en début de procédure et plus utile par la suite, ne pas oublier de lui faire un 'erase'.
Appel SetCurrentDirectory dans Workbook_Open() permet de mettre la dll dans même dossier que le xls.

Source / Exemple : 


' ------------------------ 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 projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (BruNews)