[Basic] Fonctions utiles pour bases de données

Discussions et questions sur tout ce qui concerne la programmation tous langages et tous modules confondus.

Modérateur: Vilains modOOs

Règles du forum
:alerte: Balisage obligatoire dans cette section !
Aidez-nous à vous aider au mieux en balisant correctement votre question : reportez-vous sur les règles de cette section avant de poster !

[Basic] Fonctions utiles pour bases de données

Messagepar martinbrait » 08 Avr 2017 19:26

Bonjour,

Quelques fonctions très utiles.
En voyez vous d'autres ?
Remarques... critiques...

'=======================
administration SQL :
'=======================

en mode SQL direct Depuis la console SQL de LibreOffice base,

'réinitialiser une séquence autonum de table
Code : Tout sélectionner   AgrandirRéduire
ALTER TABLE "la table concernée" ALTER COLUMN " ID concerné"(nom de clé primaire") RESTART WITH 1


'défragmenter une table
Code : Tout sélectionner   AgrandirRéduire
CHECKPOINT DEFRAG


'compacter la base
Code : Tout sélectionner   AgrandirRéduire
SHUTDOWN COMPACT




'========================
' fonctions personnalisées
'dans les versions actuelles openoffice, libreoffice,
'impossibilité d'utiliser ces fonctions dans des requêtes SQL.
'copier les champs des tables dans calc et utiliser les fonctions sous calc.
'=======================
'
'supprime toutes accentuations ou cédilles.
'récupère uniquement les caractères ascii correspondant, pour préparer des mails, par exemple
Code : Tout sélectionner   AgrandirRéduire
'===========================STRING HELPER==========================

Public Function MajSansAccentNiCedille$(ByVal Chaine$)
'Auteur : Thierry POURTIER
Const VAccent = "àáâãäåéêëèìíîïðòóôõöùúûüç", VSsAccent = "aaaaaaeeeeiiiioooooouuuuc"
Dim Bcle&
'Dim Bcle As String
For Bcle = 1 To Len(VAccent)
Chaine = Replace(Chaine, Mid(VAccent, Bcle, 1), Mid(VSsAccent, Bcle, 1))
Next Bcle
MajSansAccentNiCedille$ = Chaine
End Function




'auteur : martinbrait
'corrige des phrases passées en paramètre,
'selon les règles de typographie de la langue française
Code : Tout sélectionner   AgrandirRéduire
Public Function FrenchTypo(strChaine As String)
Dim i As Integer
'ponctuation et espaces
'applicable nécessairement APRES le passage
'd'un formatage plus grossier
'des sauts de lignes et retours chariots

'on passe un ensemble de corrections magiques,
'dans un certain ordre pour assurer le parfait
'respect des règles typographiques du français;

'simple initialisation de la chaine,
'pour que le traitement des espaces
'aient effectivement tout leur sens !
For i = 1 To 15
strChaine = Replace(strChaine, "  ", " ")
Next
'pas d'espace avant, un espace après
' dans la pratique les espaces excedentaires sont souvent doublés !!!
' suppression des mauvaises pratiques
For i = 1 To 2
    strChaine = Replace(strChaine, " .", ".")
    strChaine = Replace(strChaine, " ,", ",")
    strChaine = Replace(strChaine, " ...", "...")
    strChaine = Replace(strChaine, " )", ")")
    strChaine = Replace(strChaine, " ]", "]")
   
   
   
    strChaine = Replace(strChaine, "( ", "(")
    strChaine = Replace(strChaine, "[ ", "[")
Next

'ajout d'un espace, pour compenser les coolitudes, des étourdis
strChaine = Replace(strChaine, ".", ". ")
strChaine = Replace(strChaine, ",", ", ")
strChaine = Replace(strChaine, "...", "... ")
strChaine = Replace(strChaine, ")", ") ")
strChaine = Replace(strChaine, "]", "] ")



'un espace avant pas d'espace après
strChaine = Replace(strChaine, "(", " (")
strChaine = Replace(strChaine, "[", " [")

'compensation des espaces excédentaires éventuellement générés
For i = 1 To 2
strChaine = Replace(strChaine, ".  ", ". ")
strChaine = Replace(strChaine, ",  ", ", ")
strChaine = Replace(strChaine, "...  ", "... ")
strChaine = Replace(strChaine, ")  ", ") ")
strChaine = Replace(strChaine, "]  ", "] ")
strChaine = Replace(strChaine, "  (", " (")
strChaine = Replace(strChaine, "  [", " [")
Next

'ponctuations avec espace avant, espace après.
'Pour simplifier la démarche, on part du principe d'oublis possibles,
'que l'on compensera en supprimant les éventuels espaces double, générés
strChaine = Replace(strChaine, "-", " - ")
strChaine = Replace(strChaine, ":", " : ")
strChaine = Replace(strChaine, ";", " ; ")
strChaine = Replace(strChaine, "!", " ! ")
strChaine = Replace(strChaine, "?", " ? ")
strChaine = Replace(strChaine, ">", " > ")
strChaine = Replace(strChaine, "%", " % ")
strChaine = Replace(strChaine, "<", " < ")

'compensation des double-espaces potentiellement générés
For i = 1 To 2
    'double-espaces à gauche
    strChaine = Replace(strChaine, "  -", " -")
    strChaine = Replace(strChaine, "  :", " :")
    strChaine = Replace(strChaine, "  ;", " ;")
    strChaine = Replace(strChaine, "  !", " !")
    strChaine = Replace(strChaine, "  ?", " ?")
    strChaine = Replace(strChaine, "  >", " >")
    strChaine = Replace(strChaine, "  %", " %")
    strChaine = Replace(strChaine, "  <", " <")
   
    'double-espaces à droite
    strChaine = Replace(strChaine, "-  ", "- ")
    strChaine = Replace(strChaine, ":  ", ": ")
    strChaine = Replace(strChaine, ";  ", "; ")
    strChaine = Replace(strChaine, "!  ", "! ")
    strChaine = Replace(strChaine, "?  ", "? ")
    strChaine = Replace(strChaine, ">  ", "> ")
    strChaine = Replace(strChaine, "%  ", "% ")
    strChaine = Replace(strChaine, "<  ", "< ")
Next

FrenchTypo = strChaine
End Function


'Optimiser la saisie d'un champ mémo
'pourrait être exécuté préalablement à la fonction french typo
Code : Tout sélectionner   AgrandirRéduire
Public Function CompressionLigneContinueMemo(strChaine As String)
'auteur : martinbrait
Dim txt As String
Dim i As Integer
            'conversion des retours a la ligne
            txt = Replace(strChaine, Chr(13) & Chr(10), " ")
            txt = Replace(txt, Chr(10), " ")
            txt = Replace(txt, Chr(13), " ")
           
            'conversion des tabulations excedentaires
            For i = 1 To 5
            txt = Replace(txt, Chr(9), " ")
            Next
           
            'suppression des espaces excédentaires
            '
            For i = 1 To 15
            txt = Replace(txt, "  ", " ")
            Next
            CompressionLigneContinueMemo = Trim(txt)
End Function



'Vérifier si la chaine saisie est un mail
'retourne 1 si vrai, 0 si faux
Code : Tout sélectionner   AgrandirRéduire
'retourne 1 si vrai, 0 si faux
Function Check_Mail (mail As String) As Integer
   Dim oTextSearch as Object
   Dim oSearchOpts as Object
   Dim oResult as Object

   oTextSearch = createUnoService("com.sun.star.util.TextSearch")
   oSearchOpts = CreateUnoStruct("com.sun.star.util.SearchOptions")
   oSearchOpts.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
   oSearchOpts.searchFlag = com.sun.star.util.SearchFlags.REG_NOSUB
     ' REG_NOSUB est le flag pour que ça renvoie juste vrai ou faux,
     ' REG_EXTENDED permettrait d'avoir plus d'infos
   oSearchOpts.searchString = "^[^@]+@[^@]+\.[^@]+$"
   oTextSearch.setOptions(oSearchOpts)

   oResult = oTextSearch.searchForward( mail, 0, Len(mail) )

   Check_Mail = oResult.subRegExpressions
End Function



'SECURITE :
'Générateur de mots de passe
Code : Tout sélectionner   AgrandirRéduire
Function MOTDEPASSE(Optional Longueur, Optional Nbre_chiffres, Optional Nbre_symboles, Optional iduser) As String

'ATTENTION: OPENOFFICE ET LIBREOFFICE,
'NE [JAMAIS] TYPER LES VARIABLES A L'ENTREE
'POUR QUE FONCTIONNE LE PARAMETRE OPTIONNEL
'POUR AUTANT DE PARAMETRES OPTIONNELS EXISTANTS !!!

'L'ABSENCE DE PARAMETRE DOIT ETRE AVEC DES SUITES DE VIRGULES SANS AUCUNE APOSTROPHE
' exemple : Essai (5,,,,)


'AUTRE REMARQUE
'le seul fait qu'un userid soit envoyé dans le paramètre d'envoi,
'fait que la requête est relancée systématiquement,
'car l'id est changeante.
'BASE optimise la requête et ne rentre q'une fois dans le générateur de mot de passe.
'Afin de forcer le passage systématique dans ton générateur,
'il suffit de lui transmettre un argument lors de l'appel de ta fonction (un iduser par exemple).


If IsMissing(Longueur) Then
Longueur = 10
End If

If IsMissing(Nbre_chiffres) Then
Nbre_chiffres = 2
End If

If IsMissing(Nbre_symboles) Then
Nbre_symboles = 2
End If

If IsMissing(iduser) Then
iduser = 0
End If


' Déclaration des constantes '
' On limite à 10 le nombre maximal de chiffres et de symboles '
Const maxChiffres = 10
Const maxSymboles = 10

' Déclaration des variables '
Dim i, j, n, debut, fin As Long
Dim strLettres, strChiffres, strSymboles, strChaine, strMot As String
Dim varTab, varTemp As Variant

' Chaînes de caractères contentant lettres, chiffres et symboles '
strLettres = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
strChiffres = "0123456789"
strSymboles = "@#&§%$£€(){}[]\`~_<>=+-*/!?;.:"
strChaine = strLettres & strChiffres & strSymboles

' On limite le nombre total de chiffres '
If Nbre_chiffres > maxChiffres Then
    Nbre_chiffres = maxChiffres
' On limite le nombre total de chiffres à la longueur du mot de passe '
ElseIf Nbre_chiffres > Longueur Then
    Nbre_chiffres = Longueur
End If

If (Nbre_symboles + Nbre_chiffres) > Longueur Then
    Nbre_symboles = Longueur - Nbre_chiffres
' On limite le nombre total de symboles '
ElseIf Nbre_symboles > maxSymboles Then
    Nbre_symboles = maxSymboles
' On limite le nombre total de symboles à la longueur du mot de passe '
ElseIf Nbre_symboles > Longueur Then
    Nbre_symboles = Longueur
End If

' On redéfinit la taille du tableau en fonction de la longueur du mot de passe '
ReDim varTab(Longueur)

' Si l’argument Nbre_chiffres est renseigné '
If Nbre_chiffres > 0 Then
    ' On détermine les positions de début et de fin de la chaîne '
    debut = CLng(Len(strLettres) + 1)
    fin = CLng(debut + Len(strChiffres) - 1)
    ' Boucle permettant de stocker les chiffres dans un tableau '
    For i = 1 To Nbre_chiffres
        varTab(i) = Mid(strChaine, (Rnd() * (fin - debut) + debut), 1)
    Next i
End If

' Si l’argument Nbre_symboles est renseigné '
If Nbre_symboles > 0 Then
    ' On détermine les positions de début et de fin de chaîne '
    debut = CLng(Len(strLettres + strChiffres) + 1)
    fin = CLng(debut + Len(strSymboles) - 1)
    ' Boucle permettant de stocker les symboles dans un tableau '
    For i = 1 To Nbre_symboles
        varTab(CLng(i + Nbre_chiffres)) = Mid(strChaine, (Rnd() * (fin - debut) + debut), 1)
    Next i
End If

' Si la longueur du mot de passe est supérieure au nombre de chiffres et symboles '
If (Longueur > (Nbre_symboles + Nbre_chiffres)) Then
    ' Boucle permettant de stocker les lettres dans un tableau '
    For i = 1 To (Longueur - (Nbre_symboles + Nbre_chiffres))
        varTab(CLng(i + Nbre_chiffres + Nbre_symboles)) = Mid(strChaine, (Rnd() * (Len(strLettres) - 1) + 1), 1)
    Next i
End If

' Tri aléatoire du tableau contenant lettres, chiffres et symboles '
Randomize
For n = LBound(varTab) To UBound(varTab)
    j = CLng(((UBound(varTab) - n) * Rnd) + n)
    If n <> j Then
        varTemp = varTab(n)
        varTab(n) = varTab(j)
        varTab(j) = varTemp
    End If
Next n

' Reconstitution du mot de passe après tri aléatoire '
For i = LBound(varTab) To UBound(varTab)
    strMot = strMot & varTab(i)
Next i

' On renvoie le mot de passe '
MOTDEPASSE = strMot

End Function

'et ton code SQL de cette manière tu pourras générer un mot de passe différent à chaque utilisateur :
'Update Users
'Set Users.[1STPWD] = MOTDEPASSE([iduser])
'WHERE (((USERS.[1STPWD]) IS NULL));


Sub TestMdp()
MsgBox MOTDEPASSE(15, ,, 1)
End Sub





'Dernière occurence d'un caractère dans une chaîne
Code : Tout sélectionner   AgrandirRéduire
Function LastOccurence(strString As String, strCharacter As String) As Integer

    Dim intPosition As Integer
   
    intPosition = 1
   
    While intPosition <= Len(strString) And strCharacter <> "" And InStr(intPosition, strString, strCharacter) <> 0
        intPosition = InStr(intPosition, strString, strCharacter)
        LastOccurence = intPosition
        intPosition = intPosition + 1
    Wend
End Function

Extraire des nombres entiers et décimaux (sans mots)
Code : Tout sélectionner   AgrandirRéduire
'Auteur : martinbrait
Function ExtraireNombres(strChaine As String)
Dim i As Integer
Dim atemp As Variant
Dim temp As String

temp="" 'initialisation de la variable de resultats

strChaine = " " & strChaine & " " 'je transforme la chaine pour voir tous les atomes
strChaine = Replace(stChaine,Chr(9)," ") 'je transforme la chaine pour ne pas passer à côté des séparateur tabulation


atemp = split(strChaine," ")

For i = LBound(atemp) To UBound(atemp)
   'Msgbox atemp(i)
   'Msgbox atemp(i)
   If IsNumeric(Left(atemp(i),1)) Then
      If Len(temp)=0 Then
      temp = atemp(i)
      Else
      temp = temp & ";" & atemp(i)
      End If
   End if
Next
ExtraireNombres = temp

End Function



Extraire des mots (sans nombres)
Code : Tout sélectionner   AgrandirRéduire
'Auteur : martinbrait
Function ExtraireMots(strChaine As String)
Dim i As Integer
Dim atemp As Variant
Dim temp As String

temp="" 'initialisation de la variable de resultats

strChaine = " " & strChaine & " " 'je transforme la chaine pour voir tous les atomes
strChaine = " " & strChaine & " " 'je transforme la chaine pour voir tous les atomes
strChaine = Replace(stChaine,Chr(9)," ") 'je transforme la chaine pour ne pas passer à côté des séparateur tabulation


atemp = split(strChaine," ")

For i = LBound(atemp) To UBound(atemp)
   'Msgbox atemp(i)
   'Msgbox atemp(i)
   If Not IsNumeric(Left(atemp(i),1)) Then
      If Len(temp)=0 Then
      temp = atemp(i)
      Else
      temp = temp & ";" & atemp(i)
      End If
   End if
Next
temp = Replace(strChaine,";;",";")
If Len(temp)>1 Then
'supprime le dernier point virgule du séparateur
temp = Left(temp,Len(temp)-1)
End If
ExtraireMots = temp

End Function



Détecte si la chaîne passée en paramètre,
contient accents ou cédilles
Code : Tout sélectionner   AgrandirRéduire
Public Function ContientAccentsOuCedilles(ByVal Chaine$)As Boolean
'Auteur : Thierry POURTIER
Dim bAnswer As Boolean
Dim aAccent As Variant
'initialisation
bAnswer = False

Const VAccent = "à;á;â;ã;ä;å;é;ê;ë;è;ì;í;î;ï;ð;ò;ó;ô;õ;ö;ù;ú;û;ü;ç"
aAccent = Split(VAccent,";")

Dim Bcle&
'Dim Bcle As String
For Bcle = 1 To UBound(aAccent)
If Instr(1,Chaine,aAccent(Bcle))>0 Then
bAnswer = True
End If
Next Bcle
ContientAccentsOuCedilles = bAnswer
End Function




Sub TestChaine()
Msgbox ContientAccentsOuCedilles("Martin")
End Sub 

'Déterminer si atome en majuscules (V1)
Code : Tout sélectionner   AgrandirRéduire
Function EstMajuscule(sMot$) as boolean
   sRet = False
   If sMot = UCase(sMot) Then sRet = True
   EstMajuscule = sRet
End Function


'Déterminer si atome en majuscules (V2)
Code : Tout sélectionner   AgrandirRéduire
Function EstEnMajuscule(CeMot As String)As Boolean
Dim i As Integer
Dim vCemot As Variant

If Len(CeMot)>0 Then
EstEnMajuscule = True' tant qu'aucun code ascii de la trame <65, >90
For i = 1 To Len(CeMot)
        If Asc(Mid(CeMot,i,1))>90 or Asc(Mid(CeMot,i,1))<65 Then
        EstEnMajuscule = False
        Exit For
   End If
Next
Else'gestion d'exception
EstEnMajuscule=""'on ne donne pas de réponse quand la chaîne traitée est initialement vide
EndIf
End Function



Merci et à bientôt !
Dernière édition par martinbrait le 02 Juil 2017 14:07, édité 11 fois.
LibreOffice version 5.1.6.2
Windows 10
+
LibreOffice version 4.3.6.2.0
Windows 7

#HSQL Database Engine 1.8.0
version=1.8.0


Bonjour, merci et à bientôt !
Avatar de l’utilisateur
martinbrait
InconditiOOnnel
InconditiOOnnel
 
Message(s) : 751
Inscrit le : 09 Avr 2013 08:15
Localisation : T'as pas dit bonjour, merci et à bientot !

Re: [Base] Fonctions utiles pour bases de données

Messagepar Churay » 09 Avr 2017 18:09

Bonjour,

La balise [Basic] me semblerait plus adaptée puisqu'il n'y a aucune instruction|méthode utilisée qui soit spécifique à Base.
cOOordialement
---
AOO 4.0.1 W7-PRO & LO 5.1.6.2 Debian 7.8 & Ubuntu 16.04 LTS
---
F1 : ça aide...
XRay + SDK :super:
---
Quand le NOT CONFIRMED sera corrigé (OOo et LO) , je serai heureux...
Avatar de l’utilisateur
Churay
ManitOOu
ManitOOu
 
Message(s) : 2668
Inscrit le : 30 Avr 2009 05:54
Localisation : CATALUNYA


Retour vers Macros et API

Qui est en ligne ?

Utilisateur(s) parcourant ce forum : Aucun utilisateur inscrit et 3 invité(s)