[XL-2010] vba & word

Bonjour,

J'ai été confronté au même problème mais sur des formats pdf ou dessin. Je l'ai réglé en créant une feuille dédiée aux liens.

Lorsque le fichier est distribué, l'utilisateur doit reconstituer les liens à la première utilisation (voir la diapo jointe).

http://www.developpez.net/forums/att...1&d=1368458892

Pour vous, le code ci-dessous est à modifier pour uniquement reconstituer les liens sur vos fichiers Word. Dans l'exemple, ci-dessous, il s'agit de refaire des liens entre des références d'affaires et des noms de fichiers dont le nom commence par le nom de l'affaire.

Pour vous, il suffit de remplacer D327 par le nom de votre fichier et les extensions par des extensions Word.

Code:

And Mid(MyFile, 1, 4) = "D327"

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
 
Public MyName As String
Public MyFile As String
 
 
Sub ImportDesfichiersPDF()
 
 
    Set Sh = Sheets("Fichiers associés")
 
    On Error Resume Next
    ChDir Sheets("Paramètres").Range("FichiersAssocies").Value
 
    Sh.Activate
    Coordligne = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
 
    FichierAOuvrir = Application.GetOpenFilename("Fichiers (*.pdf;*.gif;*.jpg;*.jpeg;*.tif;*.bmp),*.pdf;*.gif;*.jpg;*.jpeg;*.tif;*.bmp")
 
    If FichierAOuvrir <> False Then
 
       If Coordligne > 1 Then Range(Cells(2, 1), Cells(Coordligne, 1)).EntireRow.Clear
       X = 2
 
        MyName = CurDir
        Call ImporterFichier("pdf")
        Call ImporterFichier("gif")
        Call ImporterFichier("jpg")
        Call ImporterFichier("jpeg")
        Call ImporterFichier("tif")
        Call ImporterFichier("bmp")
 
 
    End If
 
    Set Sh = Nothing
 
 
End Sub
 
 
Sub ImporterFichier(Extension)
 
        MyFile = Dir(MyName & "\*." & Extension)
 
        Do While MyFile <> ""   ' Commence la boucle.
 
            If MyFile <> "" And Mid(MyFile, 1, 4) = "D327" Then
 
                 Sh.Hyperlinks.Add Anchor:=Sh.Cells(X, 2), Address:=CurDir & "\" & MyFile
                 Sh.Cells(X, 1) = "D327/" & Mid(MyFile, 6, 6)
                 Sh.Cells(X, 3) = Right(MyFile, 3)
                 X = X + 1
            End If
 
            MyFile = Dir   ' Extrait l'entrée suivante.
 
        Loop
 
 
End Sub

Nb : Vous n'êtes pas obligé de reconstituer les liens hypertextes mais c'est pratique.

Cordialement.