Récupération images de Word

Bonjour,

J'ai des fiches. Elles sont en format Word. Il y a différentes informations + 2 photos. Prenons un exemple simple : je fais des fiches pour ma collection de petites voitures : il y a 2 photos, et une fiche avec différentes caractéristiques notées.

Par macro, j'ouvre Word, copie/collle les informations et ensuite je les compile dans un tableau Excel :

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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
Sub MAJ()
    Dim Chemin As String
    Dim Fichier As String
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
 
    Dim DerniereLignefichiers As Integer
    Dim DerniereLignefiches As Integer
 
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
 
 
    'efface données Liste
    DerniereLignefiches = Sheets("Liste").Range("A65536").End(xlUp).Row
    Range(Cells(2, 1), Cells(DerniereLignefiches, 68)).Select
    Selection.ClearContents
    Range("A2").Select
 
     'efface données Fichiers
     Sheets("Fichiers").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
 
    'Efface données Temp
     Sheets("Temp").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
 
 
    'lecture des fichiers
 
    'Définit le répertoire contenant les fichiers
    Chemin = ThisWorkbook.Path & "\Fiches"
 
    Fichier = Dir(Chemin & "\*.doc")
 
 
 
    Do While Len(Fichier) > 0
       i = i + 1
 
        Sheets("Fichiers").Cells(i, 1) = Fichier
         Fichier = Dir()
    Loop
 
 
    ' Lecture / Ecriture des fiches
 
 
    DerniereLignefichiers = Sheets("Fichiers").Range("A65536").End(xlUp).Row
 
    'Boucle sur fichiers
    For j = 1 To DerniereLignefichiers
 
 
 
    Fichier = ThisWorkbook.Path & "\Fiches\" & Sheets("Fichiers").Cells(j, 1)
 
    'creation session Word
    Set WordApp = New Word.Application
    'pour que word reste masqué pendant l'opération
    WordApp.Visible = False
    'ouverture du fichier Word
    Set WordDoc = WordApp.Documents.Open(Fichier)
 
    'copie le premier tableau Word
    WordDoc.Range.Copy
 
    'Enleve message alerte
    Application.DisplayAlerts = False
 
    'colle
    Sheets("Temp").Paste
        Stop
    'ferme le document Word sans sauvegarde
    WordDoc.Close False
    'ferme l'application Word
    WordApp.Quit
 
    'ajout dans "fiches"
    DerniereLignefiches = Sheets("Liste").Range("A65536").End(xlUp).Row
 
    k = j 'DerniereLignefiches + 1 'incrémente
 
‘Différentes formules’ pour récupérer les cases de word’’’’’’’
 
  'Efface données Temp
     Sheets("Temp").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
 
    Next
 
    MsgBox ("Fini")
End Sub

Mon problème, c'est que j'aimerai pouvoir récupérer le nom des images, ainsi, lorsque j'aurai mon tableau Excel, je ferai un lien hypertexte vers ces images.....

Mais dans mon copier/coller, il me copie bien l'image, mais je n'arrive pas à récupérer leur nom....

Une idée ?

Merci,
A+

Bonjour,

Je ne suis pas du tout un pro de Word, mais, si je fais une analogie avec Excel, une fois le classeur enregistré, le lien vers l'image n'est plus accessible; tu ne peux plus récupérer le chemin car l'image fait partie du fichier Excel (par exemple, tu peux envoyer le fichier par messagerie et les images seront visibles sur un autre ordi.

Merci Daniel.C,

Effectivement, on ne peut pas récupérer le lien, c'est pourquoi je cherche à récupérer le nom et ensuite, je reconstruis le lien (en faisant un lien hypertexte).

C'est pourquoi mon souci est de pouvoir récupérer le nom de l'image.....

A+

Bon, à force de chercher, j'ai trouvé un semblant de réponse :

A l'endroit où je mets mes photos, j'écris le nom de la photo. Avec ma macro, je récupère le nom et fait un lien hypertexte vers le dossier où se trouve les photos.....

Un peu "ancestral" comme manip, mais apparemment, il n'y a pas d'autres solutions....

A+ pour de nouvelles aventures.....:ccool: