Ouvrir une boite de dialogue pour sélectionner un fichier dans mon code

Version imprimable

Bonjour tout le monde,

J'ai un code VBA où je veux s'il ne trouve pas le fichier word concerné dans le chemin indiqué qu'il m'ouvre une boîte de dialogue pour pour pouvoir le sélectionner. Je veux savoir si c'est possible d'avoir un code qui prend en considération le nouveau chemin pour les utilisations ultérieurs pour que je ne sois pas obligé de l'indiquer dans mon code VBA. Merci infiniment.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub publipost() Dim wdApp As Word.Application Dim wdDoc As Word.Document Set wdApp = New Word.Application wdApp.Visible = True Set wdDoc = wdApp.Documents.Open("C:\Users\PC\Desktop\ACCESS\SUBROGATION\test\lettre.docx") With wdDoc.MailMerge .OpenDataSource Name:="C:\Users\PC\Desktop\ACCESS\SUBROGATION\test\SUBROGATION 2021 Finale - Copie.accdb", SQLStatement:="SELECT * FROM [RPUBLI]" .Destination = wdSendToPrinter .SuppressBlankLines = True .Execute End With wdDoc.Close False Set wdDoc = Nothing wdApp.Quit Set wdApp = Nothing End Sub

Vous pouvez tester ce code (après adaptation de votre répertoire):

Code:

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Sub OuvrirDocWord()
 
    Dim Chemin, CheminAlternatif As String
    Chemin = "C:\Users\PC\Desktop\ACCESS\SUBROGATION\test\lettre.docx"
    CheminAlternatif = "C:\Users\PC\Desktop\ACCESS\SUBROGATION\"    'A modifier à souhait *************
 
    'Vérifier l'information du répertoire indiqué
    If IsNull(Chemin) Or Chemin = "" Then
        MsgBox "Veuillez vérfier l'existence du répertoire : " & vbCrLf & _
                "'" & Chemin & "'", vbInformation, "Répertoire Inconnu"
        Exit Sub
    Else
        'Vérifier l'existencce du document indiqué
        If Dir(Chemin) = "" Then
            MsgBox "Le Document spécifié n'existe pas sous le répertoire indiqué !" & vbCrLf & _
                    "Veuillez choisir le bon dossier manuellement !", _
                   vbExclamation, "Document Inexistant"
            'Choix manuel du fichier voulu
            RepertoireAlternatif CheminAlternatif
        Else
            OuvrirDocument (Chemin)
        End If
    End If
End Sub
 
Function RepertoireAlternatif(ByVal myPath As String) As Boolean
' nécessite la référence "Microsoft Office 16.0 Object Library" ou +haut.
 
    Dim fDialog As Object
    Dim varFile As Variant
    Dim SelectedFile As String
    Dim myMsg As String
 
    SelectedFile = ""
    Set fDialog = Application.FileDialog(1)
 
    With fDialog
       .AllowMultiSelect = False
       .InitialFileName = myPath
       .Title = "Veuillez choisir le fichier à ouvrir"
       .filters.Clear
       .filters.Add "All Files", "*.Doc*"
 
        If .Show = True Then
            For Each varFile In .SelectedItems
                SelectedFile = varFile
                RepertoireAlternatif = True
            Next
        Else
           MsgBox "Vous n'avez choisi aucun fichier.", vbOKOnly, "Choix du fichier à traiter"
           RepertoireAlternatif = False
        End If
    End With
 
    If RepertoireAlternatif = True Then OuvrirDocument SelectedFile
End Function
 
Sub OuvrirDocument(strDocName As String)
    Dim objApp As Object
 
    'Ouvrir le document sélectionné
 
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = True
    objApp.Documents.Open strDocName
    MsgBox "Le document est ouvert !", vbOKOnly, "Document Ouvert"
 
End Sub

20/04/2021, 15h47
thebestone

Merci Zekraoui_Jakani pour ta réponse. J'ai une petite demande si ça t'embête pas, comme je suis encore novice est ce que tu peux intégrer le code que tu as proposé dans le mien comme ça je n'aurai qu'à modifier le chemin.
J'ai essayé seul mais je n'arrive pas. Merci infiniment.

Je n'ai pas pu tester la partie 'publipostage' car je n'ai pas accès à la source !!

Code:

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
Sub OuvrirDocWord()
 
    Dim Chemin, CheminAlternatif As String
    Chemin = "C:\Users\PC\Desktop\ACCESS\SUBROGATION\test\lettre.docx"
    CheminAlternatif = "C:\Users\PC\Desktop\ACCESS\SUBROGATION\"    'A modifier à souhait *************
 
    'Vérifier l'information du répertoire indiqué
    If IsNull(Chemin) Or Chemin = "" Then
        MsgBox "Veuillez vérfier l'existence du répertoire : " & vbCrLf & _
                "'" & Chemin & "'", vbInformation, "Répertoire Inconnu"
        Exit Sub
    Else
        'Vérifier l'existencce du document indiqué
        If Dir(Chemin) = "" Then
            MsgBox "Le Document spécifié n'existe pas sous le répertoire indiqué !" & vbCrLf & _
                    "Veuillez choisir le bon dossier manuellement !", _
                   vbExclamation, "Document Inexistant"
            'Choix manuel du fichier voulu
            RepertoireAlternatif CheminAlternatif
        Else
            OuvrirDocument (Chemin)
        End If
    End If
End Sub
 
Function RepertoireAlternatif(ByVal myPath As String) As Boolean
' nécessite la référence "Microsoft Office 16.0 Object Library" ou +haut.
 
    Dim fDialog As Object
    Dim varFile As Variant
    Dim SelectedFile As String
    Dim myMsg As String
 
    SelectedFile = ""
    Set fDialog = Application.FileDialog(1)
 
    With fDialog
       .AllowMultiSelect = False
       .InitialFileName = myPath
       .Title = "Veuillez choisir le fichier à ouvrir"
       .filters.Clear
       .filters.Add "All Files", "*.Doc*"
 
        If .Show = True Then
            For Each varFile In .SelectedItems
                SelectedFile = varFile
                RepertoireAlternatif = True
            Next
        Else
           MsgBox "Vous n'avez choisi aucun fichier.", vbOKOnly, "Choix du fichier à traiter"
           RepertoireAlternatif = False
        End If
    End With
 
    If RepertoireAlternatif = True Then OuvrirDocument SelectedFile
End Function
 
Sub OuvrirDocument(strDocName As String)
    Dim objApp As Object
    Dim wdDoc As Object
    Dim myMsg As String
 
    'Ouvrir le document sélectionné
    Set objApp = CreateObject("Word.Application")
    Set wdDoc = objApp.Documents.Open(strDocName)
    objApp.Visible = True
'    objApp.Documents.Open strDocName
    myMsg = "Le document '" & strDocName & "' est ouvert !" & vbCrLf & vbCrLf
    myMsg = myMsg & "Le publipostage est prêt à êre lancé !"
    MsgBox myMsg, vbOKOnly, "Document Ouvert"
 
    'Lancer le publipostage
    With wdDoc.MailMerge
        .OpenDataSource name:="C:\Users\PC\Desktop\ACCESS\SUBROGATION\test\SUBROGATION 2021 Finale - Copie.accdb", _
            SQLStatement:="SELECT * FROM [RPUBLI]"
        .Destination = wdSendToPrinter
        .SuppressBlankLines = True
        .Execute
    End With
 
    wdDoc.Close False: Set wdDoc = Nothing
    objApp.Quit: Set objApp = Nothing
 
End Sub

20/04/2021, 19h43
thebestone

Merci infiniment pour votre effort Zekraoui_Jakani, le code marche très bien.