Discussion :

[Thierry_ZT]

Bonjour,

J'ai une requête me sortant plusieurs enregistrements avec 3 champs: F1 / F2 / Fichiers joints
F1 correspond au fabricant
F2 correspond à la référence
Fichiers joints correspond aux fichiers joints de cette référence

Je souhaite pouvoir créer un dossier sur mon disque par fabricant avec un sous dossier par référence et y extraire les fichiers joints.

J'ai déjà réussi à pouvoir sélectionner le dossier de destination mais après je sèche.

Voici ma fonction pour la sélection du dossier par défaut

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
Function BrowseFolder(Title As String, _
        Optional InitialFolder As String = vbNullString, _
        Optional InitialView As Office.MsoFileDialogView = _
            msoFileDialogViewList) As String
    Dim V As Variant
    Dim InitFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = Title
        .InitialView = InitialView
        If Len(InitialFolder) > 0 Then
            If Dir(InitialFolder, vbDirectory) <> vbNullString Then
                InitFolder = InitialFolder
                If Right(InitFolder, 1) <> "\" Then
                    InitFolder = InitFolder & "\"
                End If
                .InitialFileName = InitFolder
            End If
        End If
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            V = vbNullString
        End If
    End With
    BrowseFolder = CStr(V)
End Function

Et l'appel de la fonction

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
Private Sub Export_Click()
On Error GoTo Err_créer_dossier_Click
 
Dim rq As dao.Recordset
Dim rslt As Currency
Dim str As String
 
Dossier = BrowseFolder("Choisissez votre répertoire:") & "\TEST"
 
MsgBox Dossier
 
MkDir Dossier
 
Exit_créer_dossier_Click:
Exit Sub
 
Err_créer_dossier_Click:
MsgBox Err.Description
Resume Exit_créer_dossier_Click
End Sub

Merci d'avance pour votre aide.

[marot_r]

Bonjour.

Ici ma solution à ce problème :

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
50
51
Public Sub CreerUneHierarchieDeRepertoires(prmCheminAccesFichier As String)
 
    On Error GoTo Err_CreerUneHierarchieDeRepertoires
 
    Dim cheminAccesFichier As String: cheminAccesFichier = EpurerCheminFichier(prmCheminAccesFichier)
 
    '=== Gère le disque/serveur
    Dim disqueServeur As String
 
    If prmCheminAccesFichier Like "?:*" Then
            'il y a un mappage
            disqueServeur = Left(cheminAccesFichier, 2)
            cheminAccesFichier = Mid(cheminAccesFichier, 4)
    ElseIf prmCheminAccesFichier Like "\\*" Then
            'On utilise un nom de serveur
            disqueServeur = Left(cheminAccesFichier, InStr(3, cheminAccesFichier, "\") - 1)
            cheminAccesFichier = Mid(cheminAccesFichier, Len(disqueServeur) + 2)
        Else
            Error 5 'Ne devrait jamais se produire en prod
    End If
    '--- Gère le disque/serveur
 
    'Récupère la liste des répertoires qui compose le chemin
    Dim nomRepertoire As Variant: nomRepertoire = Split(cheminAccesFichier, "\")
 
    Dim Chemin As String
 
    Chemin = disqueServeur
 
    Dim i As Long: For i = LBound(nomRepertoire) To UBound(nomRepertoire)
        Chemin = Chemin & "\" & nomRepertoire(i)
        MkDir Chemin
    Next i
 
Exit_CreerUneHierarchieDeRepertoires:
    Exit Sub
 
Err_CreerUneHierarchieDeRepertoires:
    Select Case Err.Number
        Case 75
            'OK, le répertoire existe déjà passe au suivant
            Resume Next
 
        Case Else
            Err.Raise Err.Number
 
    End Select
 
    Resume Exit_CreerUneHierarchieDeRepertoires
 
End Sub

Tu lui passes le chemin à créer et il s'occupe de tout.

A+

[Thierry_ZT]

Merci marot pour ta réponse rapide mais il manque la fonction: EpurerCheminFichier

Pourrais-tu me la fournir stp

Cordialement

[marot_r]

Désolé la voici :

Code :

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

1
2
3
4
5
6
7
8
9
10
Public Function EpurerCheminFichier(prmChemin As String) As String
    'Supprime les espaces non significatifs et le \ à la fin du chemin
    Dim result As String: result = Trim(prmChemin)
 
    If Right(result, 1) = "\" Then
        result = Left(result, Len(result) - 1)
    End If
 
    EpurerCheminFichier = result
End Function

A+