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