[Basic] Fonctions utiles pour bases de données

martinbrait · Message par **martinbrait** » 08 avr. 2017 18: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

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

CHECKPOINT DEFRAG

'compacter la base

Code : Tout sélectionner

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

'===========================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

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

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

'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

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

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

'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

'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

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

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

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 !

Message par **Churay** » 09 avr. 2017 17: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.

[Basic] Fonctions utiles pour bases de données

[Basic] Fonctions utiles pour bases de données

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