Generateur de tableaux de nombres pour vb/vba

Soyez le premier à donner votre avis sur cette source.

Vue 11 757 fois - Téléchargée 536 fois

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

Codes Sources

A voir également

Ajouter un commentaire

Commentaire

BruNews
Messages postés
21054
Date d'inscription
jeudi 23 janvier 2003
Statut
Modérateur
Dernière intervention
7 novembre 2014
13 -
Oublié de préciser:
bnTablEstNull() permet de tester si tableau non nul en retour de dll, je n'ai pas trouvé le moyen de tester cela en VB, alors je l'ai écrit.

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.