Copie de tableaux-graphiques d'Excel 2010 vers Word 2010 : je suis bloqué !

**zellinho** · 15/10/2014, 11h04

Bonjour mesdames, messieurs les experts

J'ai besoin de vos lumières car là... je bloque...

Voici mon programme vba Excel :

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
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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
 
 
Option Explicit
Dim debut_tableau As Integer, fin_tableau As Integer
Dim DocWord As Word.Document
Dim AppWord As Word.Application
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
 
'*************************************************************************************************************************************************************
Private Sub Vider_PP()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub
'*************************************************************************************************************************************************************
Sub Test()
 
Set AppWord = CreateObject("word.application") 'ouvre session word
Set DocWord = AppWord.Documents.Open("xxx\test.docx", ReadOnly:=True) 'ouvre document Word
    AppWord.Visible = True 'affiche le document Word
    Application.ScreenUpdating = False
    CopieAIS
    Application.ScreenUpdating = True
End Sub
'*************************************************************************************************************************************************************
Sub CopieAIS()
    CopieTableauxEtGraphDansWord S_InfosEntite, "infos_AIS", "CH", "CW", 1, 23, 368.55  'soit 13 cm
    CopieTableauxEtGraphDansWord S_InfosEntite, "graphs1_AIS", "CH", "CW", 25, 49, 368.55  'soit 13 cm
    CopieTableauxEtGraphDansWord S_InfosEntite, "graphs2_AIS", "CH", "CW", 51, 75, 368.55  'soit 13 cm
    IdentifieLeTableauACopier s_DirAIS, "s_DirAIS"
End Sub
'*************************************************************************************************************************************************************
 Sub IdentifieLeTableauACopier(Onglet As Worksheet, NomSignet As String)
    CopieTableauDansWord Onglet, NomSignet, "IDPROD", 1
    CopieTableauDansWord Onglet, NomSignet, "IDGAR", 2
    CopieTableauDansWord Onglet, NomSignet, "IDOPT", 3
    CopieTableauDansWord Onglet, NomSignet, "IDATT", 4
 
    CopieTableauDansWord Onglet, NomSignet, "compte", 5
    CopieTableauDansWord Onglet, NomSignet, "tarif", 6
    CopieTableauDansWord Onglet, NomSignet, "sinistre", 7
    CopieTableauDansWord Onglet, NomSignet, "qualité service", 8
    CopieTableauDansWord Onglet, NomSignet, "surveillance", 9
    CopieTableauDansWord Onglet, NomSignet, "produit", 10
    CopieTableauDansWord Onglet, NomSignet, "communication", 11
    CopieTableauDansWord Onglet, NomSignet, "recap_motif", 12
 
    CopieTableauDansWord Onglet, NomSignet, "NATURE", 13
    CopieTableauDansWord Onglet, NomSignet, "MTFSUIT", 14
    CopieTableauDansWord Onglet, NomSignet, "CANALREP", 15
End Sub
'*************************************************************************************************************************************************************
 Sub CopieTableauDansWord(Onglet As Worksheet, NomSignet As String, Identifiant As String, NumSignet As Integer)
 
    Dim pastedImage As InlineShape
    Dim largeur_pixel_origine As Variant, largeur_pixel_objectif As Variant
    Dim hauteur_pixel_origine As Variant, hauteur_pixel_objectif As Variant
    Dim coeff_reducteur As Variant, signet As Variant
    Dim Zone As String
 
    CalculTailleTableauPourCopie Onglet, Identifiant
    signet = NomSignet & NumSignet
 
    Zone = "A" & debut_tableau & ":P" & fin_tableau
    Onglet.Activate
    Range(Zone).Select
    Selection.Copy
 
    With AppWord
        .Selection.HomeKey Unit:=wdStory   'envoie en début de page
        'recherche du signet
        .Selection.Goto What:=wdGoToBookmark, Name:=signet
    End With 'les signets du document Word sont nommés Signet1 , Signet2 , Signet3
 
    AppWord.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    Set pastedImage = ActiveDocument.InlineShapes(ActiveDocument.InlineShapes.Count)
 
    largeur_pixel_origine = pastedImage.Width
    hauteur_pixel_origine = pastedImage.Height
    largeur_pixel_objectif = 368.55 'ça fait 13 cm sur le doc word
    coeff_reducteur = largeur_pixel_objectif / largeur_pixel_origine
    hauteur_pixel_objectif = hauteur_pixel_origine * coeff_reducteur
 
    pastedImage.Height = hauteur_pixel_objectif
    pastedImage.Width = largeur_pixel_objectif
 
    If CountClipboardFormats <> 0 Then
        Vider_PP
    End If
End Sub
 
'*************************************************************************************************************************************************************
Sub CopieTableauxEtGraphDansWord(Onglet As Worksheet, NomSignet As String, _
                                    ColDebut As String, ColFin As String, _
                                    LigneDebut As Integer, LigneFin As Integer, _
                                    DimensionCible As Variant)
 
    Dim pastedImage As InlineShape
    Dim largeur_pixel_origine As Variant, largeur_pixel_objectif As Variant
    Dim hauteur_pixel_origine As Variant, hauteur_pixel_objectif As Variant
    Dim coeff_reducteur As Variant
    Dim Zone As String
 
    Zone = ColDebut & LigneDebut & ":" & ColFin & LigneFin
    Onglet.Activate
    Range(Zone).Select
    Selection.Copy
 
    With AppWord
        .Selection.HomeKey Unit:=wdStory   'envoie en début de page
        'recherche du signet
        .Selection.Goto What:=wdGoToBookmark, Name:=NomSignet
    End With 'les signets du document Word sont nommés Signet1 , Signet2 , Signet3
 
    AppWord.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    Set pastedImage = ActiveDocument.InlineShapes(ActiveDocument.InlineShapes.Count)
 
    largeur_pixel_origine = pastedImage.Width
    hauteur_pixel_origine = pastedImage.Height
    largeur_pixel_objectif = DimensionCible 'ça fait 13 cm sur le doc word
 
    coeff_reducteur = largeur_pixel_objectif / largeur_pixel_origine
    hauteur_pixel_objectif = hauteur_pixel_origine * coeff_reducteur
 
    pastedImage.Height = hauteur_pixel_objectif
    pastedImage.Width = largeur_pixel_objectif
 
    If CountClipboardFormats <> 0 Then
        Vider_PP
    End If
End Sub
 
'*************************************************************************************************************************************************************
Sub CalculTailleTableauPourCopie(Onglet As Worksheet, sujet As Variant)
Dim i As Integer, TailleMax As Integer, Id As String
debut_tableau = 0
fin_tableau = 0
 
 
TailleMax = Onglet.Cells(1, 20).Value
 
i = 1
Do While i <= TailleMax
    If Onglet.Cells(i, 19) = sujet Then
        If Onglet.Cells(i, 18) = "debut_tableau" Then
            debut_tableau = i
        End If
 
        Id = Left(Onglet.Cells(i, 3).Value, 14)
        If Onglet.Cells(i, 18) = "debut_tableau" And Id = "Pas de données" Then
            fin_tableau = i
            Exit Do
        End If
 
        If Onglet.Cells(i, 18) = "fin_tableau" Then
            fin_tableau = i
            Exit Do
        End If
    End If
i = i + 1
Loop
 
End Sub
'*************************************************************************************************************************************************************

Il me met comme erreur :

Erreur d'exécution 4605:
Cette méthode ou propriété n'est pas disponible car le Presse-papiers est vide ou non valide

à cet endroit :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub CopieTableauxEtGraphDansWord(Onglet As Worksheet, NomSignet As String, _
                                    ColDebut As String, ColFin As String, _
                                    LigneDebut As Integer, LigneFin As Integer, _
                                    DimensionCible As Variant)
 
...
 
    AppWord.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
...
 
End Sub

Il peut me faire ça après voir copier-coller quelques tableaux d'excel vers word... J'ai l'impression qu'il n'y a pas de règles....

Ce que je fais pour ce que cela re-marche, je vais dans excel, je re-sélectionne le tableau que je veux copier, je copie, et je fais poursuivre la macro.... du coup, il (excel vba) voit qu'il y a qqchose dans le presse-papier et continue comme si de rien n'était.... jusqu'au prochain bug....
Je vois qu'il sélectionne bien le tableau que je veux copier, mais j'ai l'impression qu'il ne veut pas garder en copie le tableau à copier sur word... je n'arrive pas à trouver la solution...

Qui peut m'aider ?

en vous remerciant !

PS : j'ai posé la question sur le forum Excel, mais on m'a dit de venir la poser ici. J'ai modifier entre tps mon pgm (lien vers le forum excel vba : http://www.developpez.net/forums/d14...0-suis-bloque/)

**zellinho** · 15/10/2014, 13h56

J'ai résolu le pb.

**rlesouef** · 07/01/2015, 19h18

Bonjour,
Est ce qu'on pourrait savoir comment le pbm a été résolu?
Merci

Copie de tableaux-graphiques d'Excel 2010 vers Word 2010 : je suis bloqué ! [WD-2010]

VBA Word

Discussions similaires

Partager

Partager