Diverses fonctions VBA

Function LettresExcel(sLettres As String) As Long
Dim sLettre1 As String, sLettre2 As String, sLettre3 As String
Dim iNum1 As Integer, iNum2 As Integer, iNum3 As Integer
Dim lResult As Long
 
    sLettres = UCase(sLettres)
 
    Select Case Len(sLettres)
    Case 0
        LettresExcel = 0
    Case 1
        sLettre3 = Left$(sLettres, 1)
    Case 2
        sLettre2 = Left$(sLettres, 1)
        sLettre3 = Right$(sLettres, 1)
    Case 3
        sLettre1 = Left$(sLettres, 1)
        sLettre2 = Mid$(sLettres, 2, 1)
        sLettre3 = Right$(sLettres, 1)
    Case Else
        LettresExcel = 0
    End Select
 
    If sLettre1 = "" Then iNum1 = 0 Else iNum1 = Asc(sLettre1) - 64
    If sLettre2 = "" Then iNum2 = 0 Else iNum2 = Asc(sLettre2) - 64
    If sLettre3 = "" Then iNum3 = 0 Else iNum3 = Asc(sLettre3) - 64
 
    lResult = ((26 * 26) * iNum1) + (26 * iNum2) + iNum3
    ' max Office 2007 = XFD
    If lResult > 16384 Then lResult = 0
 
    LettresExcel = lResult
 
End Function

    ' msoFileDialogFilePicker   msoFileDialogFolderPicker
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Sélection de ..."
        .ButtonName = "&Choisir"
        .AllowMultiSelect = False
 
        '.DialogType
 
        'msoFileDialogViewProperties
        '.InitialView = msoFileDialogViewSmallIcons
 
        .Filters.Add "Tableurs", "*.xls; *.xlsx; *.xlsb", 1
        .Filters.Add "Documents", "*.doc?", 2
 
        .FilterIndex = 1
        '.InitialFileName="Lettres*.doc"
 
        .Show
 
        ' Display paths of each file selected
        For lngCount = 1 To .SelectedItems.Count
            MsgBox .SelectedItems(lngCount)
        Next lngCount
 
    End With
 
    '============= VARIANTE ===============
    Dim vFich As Variant
    vFich = Application.GetOpenFilename("Tableurs (*.xls), *.xls")
    If vFich <> False Then
        MsgBox "Fichier " & vFich
    End If

Sub ModificationRequetes()
Dim sOld As String, sNew As String
Dim sSQL As String, sSQLold As String, sSQLNew As String
Dim QRY As QueryDef, iCpt As Integer
Dim sMess As String
 
    ' Texte à remplacer
    'sOld = "T_référentiel_Agences_2010"
    sOld = InputBox("Saisir l'ancien terme à remplacer dans toutes les requêtes", "Modification des requêtes de la base")
    If Trim$(sOld) = "" Then Exit Sub
 
    ' Texte de remplacement
    'sNew = "T_référentiel_Agences_2011"
    sNew = InputBox("Saisir le nouveau terme de remplacement", "Modification des requêtes de la base")
    If Trim$(sNew) = "" Then Exit Sub
 
    DoCmd.Hourglass True
    For Each QRY In CurrentDb.QueryDefs
        sSQLold = QRY.SQL
        If InStr(1, sSQLold, sOld, vbTextCompare) > 0 Then
            sSQLNew = Replace(sSQLold, sOld, sNew, 1, -1, vbTextCompare)
            QRY.SQL = sSQLNew
 
            sMess = sMess & QRY.Name & vbCrLf
            iCpt = iCpt + 1
        End If
    Next QRY
 
    DoCmd.Hourglass False
 
    MsgBox iCpt & " requêtes ont été modifiées :" & vbCrLf & sMess
 
End Sub

Sub ListeRequetes()
Dim sNomFic As String, NoF As Integer
Dim QRY As QueryDef
Dim sMess As String
 
    DoCmd.Hourglass True
    sNomFic = CurrentDb.Name
    sNomFic = Replace(sNomFic, ".accdb", " REQUETES.csv", 1, -1)
 
    NoF = FreeFile()
    Open sNomFic For Output As #NoF
    ' Ligne d'en-tête
    sMess = "Requête" & Chr(9) & "Date de mise à jour" & Chr(9) & "Date de création" & Chr(9) & "Type" '& vbCrLf
    Print #NoF, sMess
 
    For Each QRY In CurrentDb.QueryDefs
 
        sMess = QRY.Name & Chr(9) & QRY.Properties("LastUpdated").Value & Chr(9) & _
            QRY.Properties("DateCreated").Value & Chr(9) & LireType(QRY.Type)
        Print #NoF, sMess
 
    Next QRY
    Close #NoF
 
    DoCmd.Hourglass False
    MsgBox "Le fichier " & sNomFic & " a été créé."
 
End Sub
 
Function LireType(lConst As Long) As String
    Select Case lConst
        Case dbQAction: LireType = "Action"
        Case dbQAppend: LireType = "Ajout"
        Case dbQCompound: LireType = "Composé"
        Case dbQCrosstab: LireType = "Analyse croisée"
        Case dbQDDL: LireType = "Définition de données"
        Case dbQDelete: LireType = "Suppression"
        Case dbQMakeTable: LireType = "Création de table"
        Case dbQProcedure: LireType = "Procédure"
        Case dbQSelect: LireType = "Sélection"
        Case dbQSetOperation: LireType = "Union"
        Case dbQUpdate: LireType = "Mise à jour"
    End Select
End Function
 
Sub ListeTables()
Dim sNomFic As String, NoF As Integer
Dim TBL As TableDef
Dim sMess As String
 
    DoCmd.Hourglass True
    sNomFic = CurrentDb.Name
    sNomFic = Replace(sNomFic, ".accdb", " TABLES.csv", 1, -1)
 
    NoF = FreeFile()
    Open sNomFic For Output As #NoF
    ' Ligne d'en-tête
    sMess = """Table""" & Chr(9) & """Date de mise à jour""" & Chr(9) & """Date de création""" & Chr(9) & """Connexion""" '& vbCrLf
    Print #NoF, sMess
 
    For Each TBL In CurrentDb.TableDefs
 
        sMess = """" & TBL.Name & """" & Chr(9) & """" & TBL.Properties("LastUpdated").Value & """" & Chr(9) & _
            """" & TBL.Properties("DateCreated").Value & """" & Chr(9) & """" & TBL.Connect & """"
 
        ' Enlever les ;
        sMess = Replace(sMess, ";", "", 1, -1, vbTextCompare)
 
        Print #NoF, sMess
 
    Next TBL
    Close #NoF
 
    DoCmd.Hourglass False
    MsgBox "Le fichier " & sNomFic & " a été créé."
 
End Sub

Function Arrondi(ByVal dVal As Double, ByVal iNbr As Integer) As Double
     Arrondi = (Int((dVal * (10 ^ iNbr)) + 0.5)) / (10 ^ iNbr)
End Function

Function FiltreNomFichier(Texte As String) As String
Dim i As Integer, L As String, Lasc As Integer, NewTexte As String
    For i = 1 To Len(Texte)
        L = Mid$(Texte, i, 1)
        Lasc = Asc(L)
        Select Case Lasc
            Case 34: L = "_"    ' "
            Case 42: L = "_"    ' *
            Case 44: L = "_"    ' ,
            Case 47: L = "_"    ' /
            Case 58: L = "_"    ' :
            Case 59: L = "_"    ' ;
            Case 60: L = "_"    ' <
            Case 62: L = "_"    ' >
            Case 63: L = "_"    ' ?
            Case 92: L = "_"    ' \
            Case 124: L = "_"   ' |
        End Select
        NewTexte = NewTexte & L
    Next
    FiltreNomFichier = NewTexte
    End Function

Function FiltreAccentsMAJ(ByVal sTxt As String) As String
Dim i As Integer, L As String, v As Integer, NewTexte As String
    For i = 1 To Len(sTxt)
        L = Mid$(sTxt, i, 1)
        v = Asc(L)
        'Lettre A
        If (v >= 192 And v <= 197) Or (v >= 224 And v <= 229) Then v = 65
        'Lettre E
        If (v >= 200 And v <= 203) Or (v >= 232 And v <= 235) Then v = 69
        'Lettre I
        If (v >= 204 And v <= 207) Or (v >= 236 And v <= 239) Then v = 73
        'Lettre O
        If (v >= 242 And v <= 246) Or (v >= 210 And v <= 214) Or (v = 240) Then v = 79
        'Lettre U
        If (v >= 217 And v <= 220) Or (v >= 249 And v <= 252) Then v = 79
        'Lettre Y
        If (v = 221) Or (v = 253) Or (v = 255) Then v = 78
        'Lettre C
        If (v = 199) Or (v = 231) Then v = 69
        'Lettre N
        If (v = 209) Or (v = 241) Then v = 78
        L = Chr(v)
        NewTexte = NewTexte & L
    Next
    'Mise en majuscule pour les lettres non traitées
    FiltreAccentsMAJ = UCase(NewTexte)
End Function