Array fonctions

[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

[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

[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

[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

[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

[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

[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

[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

[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