Page 1 sur 1
Array fonctions
Publié:
28 Mars 2006 à 21:00par Michael DELIQUE
- Code : Tout sélectionner
Public Function ArrayDim(wvrArray As Variant) As Integer
'renvois le nombre de dimension du tableau passé en paramètre
'Déclaration Variable
Dim i As Integer
On Error Goto ErreurHandle
ArrayDim = 0
'controle de la variable tableau
Select Case Datatype(wvrArray)
Case 8704
' c'est bien une variable tableau à taille dynamique
Case 8192,8200
'varibale tableau à taille fixe
Case Else
Error 9999, "''wvrArray'' ne contient une variable tableau, datatype = "+Cstr(Datatype(wvrArray))
' Exit Function
End Select
On Error 9 Resume Next 'détecte la fin du tableau
On Error 200 Resume Next 'si le tableau n'a aucune dimension
While True
i = Ubound(wvrArray,ArrayDim +1)
If Err Then
Exit Function
End If
ArrayDim = ArrayDim +1
Wend
Exit Function
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo(1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+"."+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
ArrayDim = 0
Exit Function
End Function
Publié:
12 Sep 2008 à 09:14par Michael DELIQUE
- Code : Tout sélectionner
Function Identical(o As Variant, n As Variant)
Dim i As Integer
Dim ov As Variant, nv As Variant
On Error Goto onerror
' If Typename(o)<>Typename(n) Then Exit Function
Select Case Typename(o)
Case "NOTESITEM":
If o.Type <> n.Type Then Exit Function
ov= o.values
nv= n.values
Case Else
ov= o
nv= n
End Select
' If Typename(ov) <> Typename(nv) Then Exit Function
If Isarray(ov) Xor Isarray(nv) Then Exit Function
If Isarray(ov) Then
If Ubound(ov)<>Ubound(nv) Then Exit Function
For i=0 To Ubound(ov)
' If Typename(ov(i)) <> Typename(nv(i)) Then Exit Function
If ov(i)<>nv(i) Then Exit Function
Next
Else
If ov<>nv Then Exit Function
End If
Identical= True
exitsub:
Exit Function
onerror:
Resume exitsub
End Function
Publié:
05 Oct 2008 à 13:15par Michael DELIQUE
- Code : Tout sélectionner
Public Sub ArrayAdd(wvrArray As Variant, wnbIndex As Integer,wvrValue As Variant)
'wvrArray = le tableau à traiter (ne fonctionne que sur les tableau à 1 dimension
'wnbIndex = la position (numero de l'indexe) ou l'on veut insérer la valeur
'wvrValue = la valeur à inserer (String, number,ou autre valeur)
'Déclaration Variables
Dim nbUSize As Integer
Dim nbLSize As Integer
Dim i As Integer
On Error Goto ErreurHandle
'controle de la variable tableau
Select Case Datatype(wvrArray)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
Case 8192
Error 9999, "'''wvrArray'' contient un tableau à taille fixe, seul un tableau dynamique peut être traité."
Exit Sub
Case Else
Error 9999, "''wvrArray'' ne contient un tableau à taille dynamique, datatype = "+Cstr(Datatype(wvrArray))
Exit Sub
End Select
nbUSize = Ubound(wvrArray)+1
nbLSize = Lbound(wvrArray)
'controle de la position dns l'indexe
If wnbIndex<nbLSize Then
'on ne peut pas modifier la valeur basse
wnbIndex = nbLSize
Elseif wnbIndex> nbUSize Then
'on ne peut rajouté qu'une seule ligne
wnbIndex = nbUSize
End If
Redim Preserve wvrArray(nbLSize To nbUSize)
If wnbIndex = nbUSize Then
wvrArray(nbUSize) = wvrValue
Else
For i = nbUSize To (wnbIndex + 1) Step -1
wvrArray(i) = wvrArray(i - 1)
Next i
wvrArray(wnbIndex) = wvrValue
End If
i = 0
nbUSize = 0
Exit Sub
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Sub
End Sub
Publié:
05 Oct 2008 à 13:16par Michael DELIQUE
- Code : Tout sélectionner
Public Sub ArrayDeleteIndex(wvrArray As Variant, wnbIndex As Integer)
'wvrArray = le tableau à traiter (ne fonctionne que sur les tableau à 1 dimension
'wnbIndex = la position (numero de l'indexe) que l'on veut supprimer
'Déclaration Variables
Dim nbUSize As Integer
Dim nbLSize As Integer
Dim i As Integer
On Error Goto ErreurHandle
'controle de la variable tableau
Select Case Datatype(wvrArray)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
Case 8192
Error 9999, "'''wvrArray'' contient un tableau à taille fixe, seul un tableau dynamique peut être traité."
Exit Sub
Case Else
Error 9999, "''wvrArray'' ne contient un tableau à taille dynamique, datatype = "+Cstr(Datatype(wvrArray))
Exit Sub
End Select
nbUSize = Ubound(wvrArray)-1
nbLSize = Lbound(wvrArray)
'controle de la position dns l'indexe
If wnbIndex<nbLSize Then
'on ne peut pas modifier la valeur basse
wnbIndex = nbLSize
Elseif wnbIndex> nbUSize Then
'on ne peut rajouté qu'une seule ligne
wnbIndex = nbUSize
End If
If wnbIndex < nbUSize Then
For i = wnbIndex To nbUSize
If i < nbUSize Then
wvrArray(i) = wvrArray(i + 1)
End If
Next i
End If
wvrArray(nbUSize) = ""
Redim Preserve wvrArray(nbLSize To nbUSize)
i = 0
nbUSize = 0
nbLSize = 0
Exit Sub
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Sub
End Sub
Publié:
05 Oct 2008 à 13:18par Michael DELIQUE
- Code : Tout sélectionner
Sub ArrayReverse(vrTable As Variant)
'inverse le contenue du tableau
'Déclaration Variables
Dim nbUbound As Long
Dim nbLbound As Long
Dim vrValue As Variant
On Error Goto ErreurHandle
If Not Isarray(vrTable) Then
Exit Sub
End If
nbLBound = Lbound(vrTable)
nbUBound = Ubound(vrTable)
If nbLBound = nbUBound Then
Exit Sub
End If
While nbLBound < nbUBound
vrValue = vrTable(nbLBound)
vrTable(nbLBound) = vrTable(nbUBound)
vrTable(nbUBound) = vrValue
vrValue = Null
nbLBound = nbLBound + 1
nbUBound = nbUBound - 1
Wend
Exit Sub
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo(1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+"."+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Sub
End Sub
Publié:
05 Oct 2008 à 13:19par Michael DELIQUE
- Code : Tout sélectionner
Public Sub ArrayDeleteValue(wvrArray As Variant, wValue As String)
'wvrArray = le tableau à traiter (ne fonctionne que sur les tableau à 1 dimension
'wvalue = la valeur que l'on veut supprimer
'Déclaration Variables
Dim nbUSize As Integer
Dim nbLSize As Integer
Dim i As Integer
Dim nbIndex As Integer
On Error Goto ErreurHandle
'controle de la variable tableau
Select Case Datatype(wvrArray)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
Case 8192
Error 9999, "'''wvrArray'' contient un tableau à taille fixe, seul un tableau dynamique peut être traité."
Exit Sub
Case Else
Error 9999, "''wvrArray'' ne contient un tableau à taille dynamique, datatype = "+Cstr(Datatype(wvrArray))
Exit Sub
End Select
nbUSize = Ubound(wvrArray)
nbLSize = Lbound(wvrArray)
For i = nbLSize To nbUSize
If (wvrArray(i) = wValue) Then
nbIndex = i
End If
Next
For i = nbIndex To nbUSize
If i < nbUSize Then
wvrArray(i) = wvrArray(i + 1)
End If
Next i
wvrArray(nbUSize) = ""
Redim Preserve wvrArray(nbLSize To nbUSize)
i = 0
nbUSize = 0
nbLSize = 0
Exit Sub
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Sub
End Sub
Publié:
05 Oct 2008 à 13:21par Michael DELIQUE
- Code : Tout sélectionner
Public Function ArrayEgal(wvrArray1 As Variant, wvrArray2 As Variant, nbTaille As Long) As Integer
'détermine si 2 tableaux sont égaux
'nbTaille <1 teste tout le tableau si non teste la tableau jusqu'a la valeur indiqué
'Declaration Variables
Dim nbLBound1 As Long
Dim nbLBound2 As Long
Dim nbUBound1 As Long
Dim nbUBound2 As Long
Dim nbIndex As Long
Dim i As Long
On Error Goto ErreurHandle
ArrayEgal = False
'controle de la variable tableau
Select Case Datatype(wvrArray1)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray1) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
End Select
'controle de la variable tableau
Select Case Datatype(wvrArray2)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray2) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
End Select
nbLBound1 = Lbound(wvrArray1)
nbLBound2 = Lbound(wvrArray2)
If Typename(wvrArray1(nbLBound1)) <> Typename(wvrArray2(nbLBound2)) Then
Exit Function
End If
nbUBound1 = Ubound(wvrArray1)
nbUBound2 = Ubound(wvrArray2)
nbIndex = nbUBound1-nbLBound1
If nbTaille < 1 Then
If nbLBound1 <> nbLBound2 Then
Exit Function
End If
If nbUBound1 <> nbUBound2 Then
Exit Function
End If
Else
If Abs(nbTaille) < nbIndex Then
nbIndex = Abs(nbTaille)
End If
End If
Select Case Ucase(Trim(Typename(wvrArray1(i))))
Case "NOTESDOCUMENT","NOTESVIEW"
For i = nbLBound1 To nbIndex
If wvrArray1(i).UniversalID <> wvrArray2(i).UniversalID Then
Exit Function
End If
Next
Case Else
For i = nbLBound1 To nbIndex
If wvrArray1(i) <> wvrArray2(i) Then
Exit Function
End If
Next
End Select
ArrayEgal = True
Exit Function
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
ArrayEgal = False
Exit Function
End Function
Publié:
05 Oct 2008 à 13:22par Michael DELIQUE
- Code : Tout sélectionner
Function ArrayMixte(wvrArray1 As Variant, wvrArray2 As Variant) As Variant
'mix 2 array
Dim array () As Variant
Dim nbIndex As Integer
Dim nbUbound As Integer
On Error Goto ErreurHandle
Select Case Datatype(wvrArray1)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray1) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
End Select
'controle de la variable tableau
Select Case Datatype(wvrArray2)
Case 8704
' c'est bien une variable tableau à taille dynamique
If ArrayDim(wvrArray2) > 1 Then
Error 9999,"Seul les tableaux a 1 dimension sont traités"
End If
End Select
If Isempty(wvrArray1) Then
If Isempty(wvrArray2) Then
ArrayMixte = array
Exit Function
Else
ArrayMixte = wvrArray2
Exit Function
End If
Else
If Isempty(wvrArray2) Then
ArrayMixte = wvrArray1
Exit Function
End If
End If
nbIndex = Lbound(wvrArray1)
nbUbound = nbIndex-1+(Ubound(wvrArray1)-Lbound(wvrArray1)+1)+(Ubound(wvrArray2)-Lbound(wvrArray2)+1)
Redim array(nbIndex To nbUbound)
Forall value1 In wvrArray1
array(nbIndex) = value1
nbIndex = nbIndex+1
End Forall
Forall value2 In wvrArray2
array(nbIndex) = value2
nbIndex = nbIndex+1
End Forall
ArrayMixte = array
Erase array
Exit Function
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
ArrayMixte = Null
Exit Function
End Function
Publié:
17 Avr 2009 à 07:45par Michael DELIQUE
- Code : Tout sélectionner
Public Function ArrayList(vrValue As Variant, wnbLbound As Integer) As Variant
'converti une liste en array et un array en list
Dim array () As Variant
Dim nbLbound As Integer
Dim nbUbound As Integer
Dim lstValue List As Variant
On Error Goto ErreurHandle
Select Case Datatype(vrValue)
Case 2078 'liste
Select Case Datatype(wnbLbound)
Case 0,1,9,10 ' EMPTY,NULL,OLE object or NOTHING
nbLBound = 0
Case Else
If wnbLbound <> 0 Then
nbLBound = 1
Else
nbLBound = 0
End If
End Select
nbUBound = nbLBound-1
Forall Value In vrValue
nbUBound = nbUBound+1
End Forall
Redim array(nbLBound To nbUbound)
nbLBound = nbLBound - 1
Forall value In vrValue
nbLBound = nbLBound+1
array(nbLbound) = value
End Forall
ArrayList = array
Erase array
Exit Function
Case 8,192, 8,704 ' array
nbLbound = Lbound(vrValue)-1
Forall value In vrValue
nbLbound = nbLbound +1
lstValue(nbLbound) = value
End Forall
ArrayList = lstValue
Erase lstValue
Case Else
ArrayList = vrValue
Exit Function
End Select
Exit Function
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
ArrayList = Null
Exit Function
End Function