Bordure
Cellule
Colonne
Date
Feuille
Fichier
Filtre
Ligne
Tableau
Texte
sub BordureGrille(document as object,num_feuille as integer,x1 as long,y1 as long,x2 as long,y2 as long, _
affiche as boolean,optional epaisseur as long, optional couleur as long)
'Affiche ou supprime une grille de bordures pour une plage de cellules
'=> On ne peut pas directement écrire dans la structure TableBorder2.
' Il faut modifier une structure temporaire puis la transmettre
'document : classeur où se trouve la feuille
'num_feuille : index de la feuille contenant la plage de cellules
'(x1,y1) : coin supérieur gauche de la plage de cellules. Exemple : A1=(0,0)
'(x2,y2) : coin inférieur droit de la plage de cellule. Exemple : E1=(4,0)
'affiche : true pour afficher la grille, false pour la supprimer
'epaisseur : paramètre optionnel pour l'épaisseur du trait (en 1/100 de mm)
'couleur : paramètre optionnel pour la couleur du trait (noir par défaut)
dim feuille as object
dim plageCellule as object
dim bordureActuelle as object
dim bordureNouvelle as new com.sun.star.table.BorderLine2
dim i as integer
feuille=document.Sheets(num_feuille)
plageCellule=feuille.getCellRangeByPosition(x1,y1,x2,y2)
bordureActuelle=plageCellule.TableBorder2
'Récupération des paramètres en cours
bordureActuelle.ISLeftLineValid=true
bordureActuelle.ISRightLineValid=true
bordureActuelle.ISTopLineValid=true
bordureActuelle.ISBottomLineValid=true
bordureActuelle.ISHorizontalLineValid=true
bordureActuelle.ISVerticalLineValid=true
'Prise en compte des paramètres optionnels
if (affiche=true) then
if IsMissing(couleur) then bordureNouvelle.color=0 else bordureNouvelle.color=couleur
if IsMissing(epaisseur) then bordureNouvelle.LineWidth=5 else bordureNouvelle.LineWidth=epaisseur
else
bordureNouvelle.color=0
bordureNouvelle.LineWidth=0
endif
'Mise à jour des paramètres des bordures
bordureActuelle.LeftLine=bordureNouvelle
bordureActuelle.RightLine=bordureNouvelle
bordureActuelle.TopLine=bordureNouvelle
bordureActuelle.BottomLine=bordureNouvelle
bordureActuelle.HorizontalLine=bordureNouvelle
bordureActuelle.VerticalLine=bordureNouvelle
'Transmission des nouveaux paramètres
plageCellule.TableBorder2=bordureActuelle
end sub
sub CelluleCentrer(document as object,num_feuille as integer,x as long, y as long)
'Centre horizontalement le contenu de la cellule
' document : document dans lequel se trouve la cellule
' num_feuille : numéro de feuille du document
' x,y : colonne et ligne de la cellule (la numérotation débute à 0)
dim cellule as object
cellule=document.Sheets(num_feuille).GetCellByPosition(x,y)
cellule.HoriJustify=com.sun.star.table.CellHoriJustify.CENTER
end sub
sub CelluleCopier(document as object,feuille1 as integer,x1 as long,y1 as long,x2 as long,y2 as long, _
feuille2 as integer,x3 as long,y3 as long)
'Copie une plage de cellules (contenu, style et format) dans le même classeur
'La numérotation des feuilles, des lignes et des colonnes débute à 0
'document : document contenant les cellules à copier
'feuille1 : feuille contenant les cellules à copier
'(x1,y1) : coordonnées du coin supérieur gauche de la plage à copier
'(x2,y2) : coordonnées du coin inférieur droit de la plage à copier
'feuille2 : feuille existante dans laquelle sont recopiées les cellules
'(x3,y3) : coordonnées du coin supérieur gauche de la feuille où la plage de cellules sera recopiée
dim adresse_source as object
dim adresse_destination as object
dim feuille_source as object
dim feuille_destination as object
feuille_source=document.Sheets(feuille1)
adresse_source=feuille_source.getCellRangeByPosition(x1,y1,x2,y2).rangeAddress 'Sélection de la plage à copier
feuille_destination=document.Sheets(feuille2)
adresse_destination=feuille_destination.getCellByPosition(x3,y3).cellAddress 'Sélection de la cellule pour la recopie
feuille_destination.copyRange(adresse_destination,adresse_source) 'Recopie de la plage de cellules
end sub
sub CelluleEffacer(document as object,num_feuille as integer,x1 as long,y1 as long,optional x2 as long,optional y2 as long)
' Efface le contenu et la mise en forme d'une cellule ou d'une plage de cellules
' La hauteur et la largeur des cellules ne sont pas affectées.
' La numérotation des feuilles, des lignes et des colonnes débute à 0.
' En entrée
' document : document contenant les cellules à effacer
' num_feuille : feuille contenant les cellules à effacer
' (x1,y1) : coordonnées de la cellule à effacer ou du coin supérieur gauche de la plage de cellules à effacer
' (x2,y2) : coordonnées du coin inférieur droit de la plage de cellules à effacer (optionnel)
' Pour tout effacer, il faut additionner les valeurs suivantes :
' -Valeur numérique=1
' -Date ou heure=2
' -Chaîne de caractères=4
' -Annotation=8
' -Formule=16
' -Mise en forme autre que celle via la feuille de style=32
' -Style de la cellule=64
' -Objet de dessin=128
' -Mise en forme du contenu de la cellule=256
' -Mise en forme dans la cellule=512
dim feuille as object
dim cellule as object
feuille=document.sheets(num_feuille)
if IsMissing(x2) or IsMissing(y2) then cellule=feuille.GetCellByPosition(x1,y1) else cellule=feuille.GetCellRangeByPosition(x1,y1,x2,y2)
cellule.clearContents(1023)
end sub
Sub CelluleFiger(document as object,num_feuille as integer,x as long,y as long)
'Fige les lignes et les colonnes précédant la cellule spécifiée d'une feuille visible
'La numérotation des feuilles, lignes et colonnes débutent à 0.
'Si x vaut 0, les colonnes sont libérées.
'Si y vaut 0, les lignes sont libérées.
'En entrée
'document : document contenant la feuille
'num_feuille : index de la feuille
'x,y : colonne et ligne de la cellule de référence
dim controleur as object
dim feuille as object
feuille=document.sheets(num_feuille)
controleur=document.CurrentController
controleur.select(feuille)
controleur.freezeAtPosition(x,y)
End Sub
sub ColonneResultatFiltre(document as object,num_feuille as integer,x as long,y as long,resultat())
' Récupère dans le tableau resultat les valeurs affichées dans la colonne x après application d'un filtre
' Toutes les données sont récupérées à partir de la cellule (x,y). Les cellules vides sont ignorées.
' La numérotation des feuilles, des lignes et des colonnes débute à 0
' En entrée
' document : document contenant les cellules à récupérer
' num_feuille : indice de la feuille contenant les cellules à récupérer
' (x,y) : coordonnées de la première cellule à récupérer
' En sortie
' resultat : tableau de type variant débutant à l'indice 0, rempli avec le contenu des cellules visibles et non vides ;
' si le tableau est vide, ubound(resultat)=-1
dim curseur as object
dim feuille as object
dim groupe_plage_cellule as object 'Ensemble des plages de cellules visibles après application du filtre
dim plage_cellule_avant_filtre as object 'Ensemble des cellules avant application du filtre
dim plage_cellule_apres_filtre as object 'Une des plages de cellules contenue dans groupe_plage_cellule
dim i as long
dim j as long
dim k as long
dim ligne_max as long
dim nb_cellule as long
dim aux as variant
feuille=document.Sheets(num_feuille)
redim resultat()
'Recherche de l'indice de la dernière ligne qui n'est pas vide, affichée ou non
curseur=feuille.createCursor
curseur.gotoEndOfUsedArea(false)
ligne_max=curseur.RangeAddress.EndRow
'Sélection des cellules visibles dans la colonne x
plage_cellule_avant_filtre=feuille.getCellRangeByPosition(x,y,x,ligne_max)
groupe_plage_cellule=plage_cellule_avant_filtre.queryVisibleCells()
'Détermination du nombre de cellules filtrées en parcourant les plages de cellules composant groupe_plage_cellule
for i=0 to ubound(groupe_plage_cellule.RangeAddresses)
nb_cellule=nb_cellule+groupe_plage_cellule.RangeAddresses(i).EndRow-groupe_plage_cellule.RangeAddresses(i).StartRow+1
next i
'Copie du contenu des cellules non vides dans le tableau resultat
if nb_cellule>0 then
redim resultat(nb_cellule-1) 'La dimension du tableau inclut les cellules vides
for i=0 to ubound(groupe_plage_cellule.RangeAddresses) 'On parcourt les plages de cellules générées par le filtre
plage_cellule_apres_filtre=groupe_plage_cellule(i)
aux=plage_cellule_apres_filtre.DataArray 'DataArray renvoie un tableau de lignes contenant un tableau de cellules
for j=0 to ubound(aux) 'On parcourt les lignes de la plage de cellules
if aux(j)(0)<>"" then 'Comme on traite une seule colonne, il n'y a qu'une cellule par ligne
resultat(k)=aux(j)(0)
k=k+1
end if
next j
next i
if k<>nb_cellule then
redim preserve resultat(k-1) 'Le tableau est redimensionné pour éliminer les cellules vides
end if
end if
end sub
function DimanchePaques(annee as integer) as date
'Calcul de la date du dimanche de Pâques (formulaire de Delambre)
'Source : https://www.imcce.fr/newsletter/docs/lesdatesdepaques.pdf
'En entrée
'annee : à partir de 1583
'En sortie
'date du dimanche de Pâques
dim a as integer,b as integer,c as integer,d as integer,e as integer
dim f as integer,g as integer,h as integer,i as integer,k as integer
dim l as integer,m as integer,n as integer,p as integer
a=annee mod 19
b=annee\100
c=annee mod 100
d=b\4
e=b mod 4
f=(b+8)\25
g=(b-f+1)\3
h=((19*a)+b-d-g+15) mod 30
i=c\4
k=c mod 4
l=(32+(2*e)+(2*i)-h-k) mod 7
m=(a+(11*h)+(22*l))\451
n=(h+l-(7*m)+114) \ 31
p=(h+l-(7*m)+114) mod 31
DimanchePaques=dateserial(annee,n,p+1)
end function
sub FeuilleCopier(document as object,feuille1 as integer,feuille2 as integer)
'Copie le contenu entier d'une feuille dans une autre feuille existante du même classeur
'La numérotation des feuilles débute à 0
'document : document contenant la feuille à copier
'feuille1 : feuille contenant les cellules à copier
'feuille2 : feuille dans laquelle sont recopiées les cellules
dim adresse_source as object
dim adresse_destination as object
dim feuille_source as object
dim feuille_destination as object
feuille_source=document.Sheets(feuille1)
adresse_source=feuille_source.rangeAddress 'Sélection de la feuille
feuille_destination=document.Sheets(feuille2)
adresse_destination=feuille_destination.getCellByPosition(0,0).cellAddress 'Sélection de la cellule pour la recopie
feuille_destination.copyRange(adresse_destination,adresse_source) 'Recopie du contenu de la feuille
end sub
sub FeuilleCreer(document as object,nom_feuille as string,position as integer,masquer as boolean,optional erreur as integer)
'Crée une feuille dans un classeur.
'En entrée
' document : document contenant la feuille à créer
' nom_feuille : nom de la feuille à créer
' position : position de la feuille à créer (0 est la position la plus à gauche)
' masquer : true=la feuille créée est masquée / false=la feuille est visible
'En sortie
' erreur (optionnel) : variable optionnelle renvoyant 0 en cas de succès ou un code d'erreur
on local error goto anomalie
if position<0 then position=0
document.sheets.insertNewByName(nom_feuille,position)
if masquer then document.sheets(position).IsVisible=false
if IsMissing(erreur)=false then erreur=0
exit sub
anomalie:
if IsMissing(erreur)=false then erreur=Err
end sub
sub FeuilleDupliquer(document as object,source as string,destination as string,position as integer,masquer as boolean,optional erreur as integer)
'Duplique une feuille dans le même classeur.
'En entrée
' document : document contenant la feuille à dupliquer
' source : nom de la feuille à dupliquer.
' destination : nom de la feuille dupliquée
' position : position de la feuille dupliquée (0 est la position la plus à gauche)
' masquer : true=la feuille dupliquée est masquée / false=feuille visible
'En sortie
' erreur (optionnel) : variable optionnelle renvoyant 0 en cas de succès ou un code d'erreur
on local error goto anomalie
if position<0 then position=0
document.sheets.copyByName(source,destination,position)
if masquer then document.sheets(position).IsVisible=false
if IsMissing(erreur)=false then erreur=0
exit sub
anomalie:
if IsMissing(erreur)=false then erreur=Err
end sub
sub ReinitialiserFeuille(document as object,num_feuille as integer)
'Réinitialise la feuille en la supprimant et en la recréant au même emplacement avec le même nom
'document : document contenant la feuille
'num_feuille : index de la feuille à réinitialiser (l'index de la première feuille vaut 0)
dim feuille as object
dim nom_feuille as string
dim nb_feuille as integer
nb_feuille=document.sheets.count
if (num_feuille<0) or (num_feuille+1>nb_feuille) then exit sub 'Vérifie l'existence de la feuille
feuille=document.sheets(num_feuille)
if nb_feuille=1 then
nom_feuille=feuille.name
feuille.name=" " 'Renomme la feuille à supprimer pour pouvoir la recréer
document.sheets.insertNewByName(nom_feuille,num_feuille+1) 'Insertion avant suppression car un classeur doit avoir au moins une feuille
document.sheets.removeByName(" ") 'Supprime la feuille renommée
end if
if nb_feuille>1 then
nom_feuille=feuille.name
document.sheets.removeByName(nom_feuille)
document.sheets.insertNewByName(nom_feuille,num_feuille) 'La nouvelle feuille a pour index num_feuille
end if
end sub
sub FeuilleRenommer(document as object,nom_ancien as string,nom_nouveau as string,masquer as boolean,optional erreur as integer)
'Renomme une feuille d'un classeur.
'En entrée
' document : document contenant la feuille à renommer
' nom_ancien : nom de la feuille à renommer
' nom_nouveau : nouveau nom de la feuille
' masquer : true=la feuille renommée est masquée / false=la feuille est visible
'En sortie
' erreur (optionnel) : variable optionnelle renvoyant 0 en cas de succès ou un code d'erreur
dim feuille as object
dim position as integer
on local error goto anomalie
feuille=document.sheets.getByName(nom_ancien)
feuille.name=nom_nouveau
if masquer then feuille.IsVisible=false
if IsMissing(erreur)=false then erreur=0
exit sub
anomalie:
if IsMissing(erreur)=false then erreur=Err
end sub
sub RetrouverNumeroFeuille(document as object,nom_feuille as string,num_feuille as integer)
'Recherche le numéro de la feuille dans le document à partir de son nom
'document : document contenant la feuille
'nom_feuille : nom de la feuille
'num_feuille : retourne le numéro de la feuille s'il y a une correspondance, -1 dans le cas contraire
dim feuille as object
num_feuille=-1
if document.sheets.hasByName(nom_feuille) then
feuille=document.sheets.getByName(nom_feuille)
num_feuille=feuille.RangeAddress.Sheet
end if
end sub
sub SupprimerFeuille(document as object,num_feuille as integer)
'Supprime la feuille du classeur
'document : document contenant la feuille
'num_feuille : index de la feuille à supprimer (l'index de la première feuille vaut 0)
dim feuille as object
dim nb_feuille as integer
nb_feuille=document.sheets.count
if nb_feuille=1 then exit sub 'Un classeur doit contenir au moins une feuille !
if (num_feuille<0) or (num_feuille+1>nb_feuille) then exit sub 'Vérifie l'existence de la feuille
feuille=document.sheets(num_feuille)
document.sheets.removeByName(feuille.name)
end sub
sub SupprimerFeuilleSauf(document as object,nom_feuille as string)
'Supprime toutes les feuilles du classeur sauf celle nommée nom_feuille
'document : document contenant la feuille
'nom_feuille : Nom de la seule feuille du classeur qui ne sera pas supprimée. Sensible à la casse
dim feuille as object
dim nb_feuille as integer
dim i as integer
nb_feuille=document.sheets.count
if nb_feuille=1 then exit sub 'Un classeur doit contenir au moins une feuille !
for i=nb_feuille to 1 step -1
feuille=document.sheets(i-1) 'l'index de la première feuille vaut 0 et non 1
if (feuille.name<>nom_feuille) and (document.sheets.count>1) then
document.sheets.removeByName(feuille.name)
end if
next i
end sub
function CheminDocument(document as object) as string
'Retourne au format URL le chemin du fichier associé à document
'Le chemin se termine par le caractère / (ex : file:///C:/Users/martin/Desktop/)
dim aux as string
dim car as string
dim i as integer
aux=document.getlocation()
i=len(aux)
do
car=Mid(aux,i,1)
i=i-1
loop until car="/" or i=0
if car="/" then CheminDocument=Mid(aux,1,i+1) else CheminDocument=""
end function
sub FichierDecouper(source as string,destination as string,nb as long,entete as boolean,optional erreur as integer)
'Découpe un fichier texte en plusieurs fichiers de nb lignes
'Le nom des fichiers créés est suffixé par un nombre incrémenté.
'ATTENTION : les caractères de fin de lignes dans les fichiers créés dépendent de l'OS utilisé
'Exemple : si source="c:\temp\test.txt et destination=c:\temps\resultat.txt
' alors génèration des fichiers c:\temp\resultat_00001.txt, c:\temp\resultat_00002.txt...
'En entrée
'source : fichier à découper (chemin absolu impératif)
'destination : fichier résultat (chemin absolu impératif).
'nb : nombre de lignes par fichier créé.
'entete : true => la première ligne du fichier source est recopiée dans chaque fichier créé.
'En sortie
'erreur : variable optionnelle renvoyant 0 en cas de succès ou un code d'erreur
dim cheminfic as string 'Chemin du fichier créé
dim ligne as string 'Contenu d'une ligne
dim ligne1 as string 'Ligne en-tête
dim extension as string 'Extension du fichier créé
dim nomfic as string 'Nom du fichier créé sans son chemin ni son extension
dim suffixe as string 'Suffixe du nom du fichier créé
dim chaine() as string
dim compteur as integer 'Compte le nombre de fichiers créés
dim j as integer
dim NumeroFic1 as integer 'Fichier source
dim NumeroFic2 as integer 'Fichier créé
dim i as long 'Compteur du nombre de lignes écrites
if nb<1 then exit sub
on local error goto ErreurLireFichier
'Recherche du chemin, du nom et de l'extension du fichier de destination
source=convertToUrl(source)
destination=convertToUrl(destination)
chaine=split(destination,"/")
j=ubound(chaine)
nomfic=chaine(j)
cheminfic=mid(destination,1,len(destination)-len(nomfic))
chaine=split(nomfic,".")
j=ubound(chaine)
if j>0 then
extension="."+chaine(j)
nomfic=mid(nomfic,1,len(nomfic)-len(extension))
end if
'Génération des fichiers
NumeroFic1=freefile
open source for input as #NumeroFic1
if (entete) and (not eof(#NumeroFic1)) then line input #NumeroFic1,ligne1
While not eof(#NumeroFic1)
NumeroFic2=freefile
compteur=compteur+1
suffixe="_"+format(compteur,"00000")
open cheminfic+nomfic+suffixe+extension for output as #NumeroFic2
if entete then
i=i+1
print #NumeroFic2,ligne1
end if
while (i<nb) and (not eof(#NumeroFic1))
i=i+1
line input #NumeroFic1,ligne
print #NumeroFic2,ligne
wend
close #NumeroFic2
i=0
wend
close #NumeroFic1
if IsMissing(erreur)=false then erreur=0
exit sub
'Récupération du code erreur si la génération des fichiers a échoué
ErreurLireFichier:
if IsMissing(erreur)=false then erreur=Err
end sub
function NomFichierSansExtension(chemin_fichier as variant) as string
'Retourne le nom du fichier sans son chemin ni son extension
'En entrée, chemin_fichier peut être une chaîne de caractères ou une variable objet associée au fichier
dim aux as string
dim car as string
dim nom as string
dim i as long
dim j as long
dim nb as long
dim obj as object
nom=""
if VarType(chemin_fichier)=9 then
obj=chemin_fichier
aux=obj.getlocation()
else
aux=convertToUrl(chemin_fichier)
end if
nb=len(aux)
if nb>0 then
if Mid(aux,nb,1)="/" then nb=nb-1 'Si "/" est le dernier caractère
i=nb
j=nb
do
car=Mid(aux,i,1)
i=i-1
if (car=".") and (j=nb) then j=i 'Si extension détectée
loop until (car="/") or (i=0)
if car="/" then nom=mid(aux,i+2,j-i-1)
end if
NomFichierSansExtension=nom
end function
sub AutofiltreCreer(document as object,num_feuille as integer,x1 as long,y1 as long,x2 as long,y2 as long,nom as string)
'Crée un autofiltre
'document : document contenant l'autofiltre
'num_feuille : numéro de la feuille contenant l'autofiltre
'(x1,y1) : coordonnées du coin supérieur gauche de la plage des en-têtes
'(x2,y2) : coordonnées du coin inférieur droit de la plage des en-têtes
'nom : nom de l'autofiltre (plusieurs autofiltres possibles mais avec des noms différents)
dim feuille as object
dim libelle_champ as object
dim plage_cellule as object
if document.DatabaseRanges.hasByName(nom) then 'L'autofiltre existe déjà ? Si oui...
plage_cellule=document.DatabaseRanges.getByName(nom) '... Sélection de la base de données
plage_cellule.Autofilter=false '... Suppression de l'autofiltre
document.DatabaseRanges.removeByName(nom) '... Suppression de la base de données associée
end if
feuille=document.sheets(num_feuille)
libelle_champ=feuille.getCellRangeByPosition(x1,y1,x2,y2) 'La plage des en-têtes est définie...
document.DatabaseRanges.addNewByName(nom,libelle_champ.getRangeAddress()) '... puis elle est nommée.
plage_cellule=document.DatabaseRanges.getByName(nom) 'Création de la base de données...
plage_cellule.Autofilter=true '... puis activation de l'autofiltre.
end sub
function DerniereLigneNonVide(document as object,num_feuille as integer) as long
'Retourne le numéro de la dernière ligne de la feuille qui n'est pas vide ou -1 si la feuille est vide
'La numérotation des feuilles, lignes et colonnes débutent à 0
'ATTENTION : une cellule formatée, par exemple avec une bordure ou une couleur d'arrière-plan, est considérée comme non vide
'En entrée
'document : document contenant la feuille
'num_feuille : index de la feuille
dim cellule as object
dim curseur as object
dim feuille as object
dim colonne as long
dim ligne as long
feuille=document.Sheets(num_feuille)
curseur=feuille.createCursor 'Création d'un curseur pour se déplacer dans l'objet feuille
curseur.gotoEndOfUsedArea(false)
ligne=curseur.RangeAddress.EndRow
colonne=curseur.RangeAddress.EndColumn
if ligne=0 and colonne=0 then 'Possibilité que la feuille soit vide si ligne et colonne valent 0
cellule=feuille.GetCellByPosition(colonne,ligne)
if cellule.GetType()=EMPTY then ligne=-1
end if
DerniereLigneNonVide=ligne
end function
sub InsererLigneApres(document as object,ByVal numfeuille as integer,ByVal numligne as long,ByVal nbligne as long)
'Insère une à plusieurs lignes vides apres la ligne sélectionnée
' document : document dans lequel on insère les lignes vides
' numfeuille : numéro de feuille du document dans lequel on insère les lignes vides (la numérotation débute à 0)
' numligne : numéro de la ligne apres lequel on insère les lignes vides (la numérotation débute à 0)
' nbligne : nombre de lignes vides à insérer
dim ensembleLigne as object
dim maxligne as long
numligne=numligne+1
ensembleLigne=document.Sheets(numfeuille).Rows
maxligne=ensembleLigne.Count-1
if numligne>=0 and nbligne>0 and numligne+nbligne<=maxligne then
ensembleLigne.insertByIndex(numligne,nbligne)
end if
end sub
sub InsererLigneAvant(document as object,ByVal numfeuille as integer,ByVal numligne as long,ByVal nbligne as long)
'Insère une à plusieurs lignes vides avant la ligne sélectionnée
' document : document dans lequel on insère les lignes vides
' numfeuille : numéro de feuille du document dans lequel on insère les lignes vides (la numérotation débute à 0)
' numligne : numéro de la ligne avant lequel on insère les lignes vides (la numérotation débute à 0)
' nbligne : nombre de lignes vides à insérer
dim ensembleLigne as object
dim maxligne as long
ensembleLigne=document.Sheets(numfeuille).Rows
maxligne=ensembleLigne.Count-1
if numligne>=0 and nbligne>0 and numligne+nbligne<=maxligne then
ensembleLigne.insertByIndex(numligne,nbligne)
end if
end sub
Function TableauDim(tableau()) as variant
'Retourne dans un tableau à 2 dimensions (dont les index débutent à 1) toutes les bornes inférieures
'et supérieures du tableau en entrée
'Exemple : si tableau est dimensionné ainsi : (0 to 4,-1 to 1)
' alors TableauDim(1,1)=0, TableauDim(1,2)=4, TableauDim(2,1)=-1 et TableauDim(2,2)=1
dim aux as new collection
dim i as long
dim j as long
dim k as long
dim borne() as long 'Tableau à 2 dimensions
on local error goto fin_dimension 'Pas de fonction pour connaître le nombre de dimensions...
while true '...alors sortie de la boucle lorsque lbound génère une erreur
i=i+1
aux.add(lbound(tableau,i)) 'Borne inférieure d'une dimension du tableau en entrée
aux.add(ubound(tableau,i)) 'Borne supérieure d'une dimension du tableau en entrée
wend
fin_dimension:
j=aux.count/2
if j>0 then
redim borne(1 to j,1 to 2)
for i=1 to j
borne(i,1)=aux.item(k+1)
borne(i,2)=aux.item(k+2)
k=k+2
next i
end if
TableauDim()=borne()
end function
sub TriShellMetzner(tableau() as variant)
'Trie le tableau en entrée par ordre croissant des données
'La comparaison s'effectue entre deux éléments séparés par un écart égal à la moitié de la taille du tableau.
dim ecart as long
dim i as long
dim j as long
dim k as long
dim m as long
dim n as long
dim r as long 'Valeur pour un changement de repère à 1 comme indice minimal du tableau
dim x as variant
dim sortie as boolean
n=ubound(tableau)-lbound(tableau)+1
if n<2 then exit sub 'Le tableau doit contenir au moins deux éléments pour être trié '
r=1-lbound(tableau)
ecart=n
do
ecart=ecart\2
j=1
k=n-ecart
do
i=j
sortie=false
do
m=i+ecart
if tableau(i-r)>tableau(m-r) then
x=tableau(i-r)
tableau(i-r)=tableau(m-r)
tableau(m-r)=x
i=i-ecart
else
sortie=true
end if
loop until (i<1) or (sortie=true)
j=j+1
loop until j>k
loop until ecart=1
end sub
function InsererTexte(source as string, ajout as string,byval position as integer) as string
'Insère la sous-chaîne ajout dans la chaîne de caractères source avant la position indiquée
'Exemple : insererTexte(123456789,"moi",2) => 1moi23456789
dim debut as string
dim fin as string
if position<1 then position=1
debut=mid(source,1,position-1)
fin=mid(source,position)
InsererTexte=debut+ajout+fin
end function
function SepMillierEntier(nombre as string) as string
'Ajoute un séparateur des milliers à un entier relatif stocké sous forme de texte
'et supprime les 0 placés devant.
'Pas de contrôle du nombre en entrée.
const separateur=" "
dim signe as integer
dim i as long,j as long,k as long,max as long
dim aux as string,car as string
i=1
max=len(nombre)
car=Mid(nombre,1,1)
if car="-" then signe=1
while (Mid(nombre,i+signe,1)="0") and (i+signe<max) 'Suppression des zéros placés devant le nombre
i=i+1
wend
k=(max-(i+signe)+1) mod 3 'Calcul de la position du premier séparateur
if k=0 then k=3
for j=i+signe to max
if k=0 then 'Ajout d'un séparateur des milliers
aux=aux+separateur
k=2
else
k=k-1
end if
car=Mid(nombre,j,1)
aux=aux+car
next j
if signe=1 then aux="-"+aux 'Ajout du signe
SepMillierEntier=aux
end function