Discussion :

[Didouille]

Bonjour,

En ce moment je crée une petite base de données qui permet de mettre à jour les tables liés des bases de données sur un serveur. Je suis arrivé à quelques choses qui tourne. Maintenant je reprend mon code et je remarque des imperfections (parfois très génante!!!)

Dans un de mes modules ACCESS, Je parcours le liste des fichiers mdb sur le serveur. Je met le résultat de ce parcours dans un tableau. Seulement je ne connais pas à l'avance le nombre d'élèments que j'aurai dans ce tableau.

C'est un tableau à 2 dimensions. J'ai essayé avec des

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Redim Preserve

, des

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

UBound

, etc ... Je n'arrive à rien !

Voici (une partie de) mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Dim tablo() As Variant
 
Private Sub scanner(ByVal dossier As Folder)
On Error GoTo Err_scanner
 
For Each fichier In dossier.Files
    If UCase(Right(fichier.Name, 3)) = UCase("mdb") Then
    tablo(i, 0) = fichier.Path
    tablo(i, 1) = Left(fichier.Name, (Len(fichier.Name) - 4))
    i = i + 1
continuer:
    End If
Next
 
For Each sousdossier In dossier.SubFolders
    scanner sousdossier
Next

Comment faire ? Avez vous une idée ?

[pc75]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
i = 0
For Each fichier In dossier.Files 
    If UCase(Right(fichier.Name, 3)) = UCase("mdb") Then 
    redim preserve tablo(i, 0)
    redim preserve tablo(i, 1)
    tablo(i, 0) = fichier.Path 
    tablo(i, 1) = Left(fichier.Name, (Len(fichier.Name) - 4)) 
    i = i + 1 
continuer: 
    End If 
Next

[Didouille]

pc75:
Sur le premier passage dans le tableau, pas de soucis ....
Ca se corse lors du deuxième passage. Il coince sur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

redim preserve tablo(i, 0)

et affiche un message d'erreur "L'indice n'appartient pas à la sélection".
Je cherche d'ou peut venir l'erreur ....

Non .... c'est comme si passé le premier redimensionement il ne veut plus ReDim une autre fois ... Décidément je ne comprends pas plus ...

[pc75]

Re,

A priori, c'est normal. Ci-joint un extrait de MSDN :

Si vous utilisez le mot clé Preserve, vous ne pouvez redimensionner que la dernière dimension du tableau. Vous ne pouvez en aucun cas modifier le nombre de dimensions. Par exemple, si votre tableau n'a qu'une dimension, vous pouvez la modifier puisqu'il s'agit de la dernière et seule dimension. Toutefois, si le tableau compte plusieurs dimensions, seule la taille de la dernière dimension est modifiable si vous souhaitez préserver le contenu du tableau. L'exemple suivant montre comment augmenter la taille de la dernière dimension d'un tableau dynamique sans effacer les données qu'il contient :

ReDim X(10, 10, 10)
. . .
ReDim Preserve X(10, 10, 15)

Il te reste une autre solution :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
i = 0 
For Each fichier In dossier.Files 
    If UCase(Right(fichier.Name, 3)) = UCase("mdb") Then 
       i = i + 1 
    End If 
Next 
 
dim tablo(i, 0) 
dim tablo(i, 1) 
 
i = 0 
For Each fichier In dossier.Files 
    If UCase(Right(fichier.Name, 3)) = UCase("mdb") Then 
    tablo(i, 0) = fichier.Path 
    tablo(i, 1) = Left(fichier.Name, (Len(fichier.Name) - 4)) 
    i = i + 1 
continuer: 
    End If 
Next

PS : Pas testé, mais c'est l'idée

[Shakram]

Si cela ne te gène pas d'inverser les deux indices de ton tableau, je te propose cela :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Dim tablo() As Variant
 
Private Sub scanner(ByVal dossier As Folder)
On Error GoTo Err_scanner
 
reDim tablo(1,0)
 
For Each fichier In dossier.Files
    If UCase(Right(fichier.Name, 3)) = UCase("mdb") Then
        redim preserve tablo(1,ubound(tablo, 2) +1)
        tablo(0,ubound(tablo, 2)) = fichier.Path
        tablo(1,ubound(tablo, 2)) = Left(fichier.Name, (Len(fichier.Name) - 4))
continuer:
    End If
Next
 
For Each sousdossier In dossier.SubFolders
    scanner sousdossier
Next

(le premier fichier sera contenu dans tablo(0,1), et non tablo(0,0)... je te laisse modifier le code si tu veux que cela commence absolument à tablo(0,0))

[Maxence HUBICHE]

je te propose un bout de code tout prêt :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Function ListerDB() As String()
'---------------------------------------------------------------------------------------
' Procedure : ListerDB
' Créée le  : vendredi 30 déc 2005 21:56
' Auteur    : Maxence Hubiche
' Objet     : Cette procédure liste tous les fichiers de bases de données présents sur
'               C:\
'---------------------------------------------------------------------------------------
'
    'ATTENTION !!! Besoin de la bibliothèque Office ...
    Dim lngNbFiles      As Long
    Dim lngCount        As Long
    Dim strListFiles()  As String
    Dim strNomFile      As String
 
    On Error GoTo GestErr
 
    With Application.FileSearch
        .NewSearch
        .LookIn = "C:\"
        .SearchSubFolders = True
        .FileType = msoFileTypeDatabases
        lngNbFiles = .Execute(msoSortByFileName)
 
        If lngNbFiles > 0 Then
            ReDim strListFiles(lngNbFiles, 1)
            For lngCount = 1 To .FoundFiles.Count
                strNomFile = .FoundFiles(lngCount)
                strListFiles(lngCount, 0) = Left(.FoundFiles(lngCount), InStrRev(.FoundFiles(lngCount), "\"))
                strListFiles(lngCount, 1) = Mid(.FoundFiles(lngCount), InStrRev(.FoundFiles(lngCount), "\") + 1)
            Next
        Else
            MsgBox "Aucun fichier trouvé..."
        End If
    End With
    ListerDB = strListFiles
 
Finprog:
    On Error Resume Next
    Exit Function
GestErr:
    Select Case Err.Number
        Case 65000
            MsgBox Err.Description, vbExclamation, "Appli Exemple Listage DB"
        Case Else
            MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite de manière inattendue dans la procédure ListerDB du module Module Module1", vbCritical, "ERREUR INATTENDUE"
    End Select
    Resume Finprog
End Function

[Didouille]

Merci à tout le monde pour vos réponses ...

J'ai retenu la solution de Maxence HUBICHE, je trouve qu'elle optimise bien le code que je vais fournir.

Le petit bout de code est fin prêt, je ne sais pas encore s'il répond à toutes les erreurs, mais la base est là.

Merci encore !!!