logo ferr
Macros pour Calc

Bordure

Cellule

Date

Feuille

Fichier

Ligne

Texte

Bordure
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Cellule
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Date
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Feuille
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Fichier
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Ligne
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Texte
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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
Codé avec la version 6.0.6.2 (x64) de LibreOffice
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