Macro XL vers WD / "presse-papier vide ou non valide" alors que non & Redimensionnement objet image

**loliv44** · 11/06/2015, 12h26

Bonjour,

Sous excel, j'ai ma macro (la seule et même unique macro of my life sur laquelle je reviens) qui ouvre un document word et va placer des tableaux convertis en images et que je redimensionne avec :

Code :

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

1
2
3
4
.InlineShapes(1)
        .LockAspectRatio = msoTrue
        .Height = 350 'redimensionne hauteur image
        '.Width = 510 'redimensionne largeur image

Par ailleurs j'ai chipé (sans comprendre davantage) des bouts de macro sur les forums (MERCI !!!!) qui permettent OU de vider le presse-papier OU d'y placer rien, histoire de ne pas avoir un bug récurent de "presse-papier vide" :

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
'sous-macro pour vider le PRESSE-PAPIER et éviter bug de saturation : place un texte "sans texte" dans le PP
Sub Clear_Clipboard()
Dim truc As DataObject
   Set truc = New DataObject
   truc.SetText ""
   truc.PutInClipboard
   Set truc = Nothing
End Sub
 
'variante : vide vraiment le PRESSE-PAPIER
 
Private Sub Commande0_Click()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub

MES 2 PROBLEMES :

1> malgré des DOEVENTS après le COLLER et les 2 astuces précédentes, j'ai de manière aléatoire le bug du "presse-papier vide" qui revient... et qui plante l'export vers le fichier doc
QUE SE PASSE-T-IL & QUE PUIS-JE FAIRE ?

2> le redimensionnement du 92ème tableau-image au 92ème signet (MAIS qui se trouve après entre le 3ème et 4ème signet dans le fichier doc), à la donc 92ème étape de la macro sous excel, ne se fait pas...
QUE SE PASSE-T-IL & QUE PUIS-JE FAIRE ?

Merci d'avance à toutes et tous !!!
Bonne journée

Tout le code fait plus de 60 000 caractères et ne tient pas dans le corps de ce message ; en voici le début (la suite est juste une série de copier-coller-placement sur signet comme ce début) & la fin...

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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
'Référence Microsoft Word 15.0 Object Library chargée dans menu déroulant Outils
'VBA 7.0
'Office 2015
'Excel et Word v.15
 
'-- Déclaration des fonctions API
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
 
 
Option Explicit
 
'sous-macro pour vider le PRESSE-PAPIER et éviter bug de saturation : place un texte "sans texte" dans le PP
Sub Clear_Clipboard()
Dim truc As DataObject
   Set truc = New DataObject
   truc.SetText ""
   truc.PutInClipboard
   Set truc = Nothing
End Sub
 
'variante : vide vraiment le PRESSE-PAPIER
 
Private Sub Commande0_Click()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub
 
 
'macro édition Rapport
 
Sub rapport()
 
'Vide la pile du presse-papier, ça libère la mémoire pour ne pas avoir de bug
Clear_Clipboard
Commande0_Click
 
'Lancement application Word et Ouverture du document-modèle (format .docm) rendu visible
Dim aWord As Word.Application
Dim dWord As Word.Document
Set aWord = CreateObject("Word.Application")
aWord.Visible = True
'chemin EXACT du fichier !!!
Set dWord = aWord.Documents.Open("G:\modèle rapport.docm")
 
'Empèche les messages comme Pas sauver.. Le presse papier est rempli etc..
    'Application.DisplayAlerts = False
 
    'Supprime le rafraichissement de l'écran pour accélérer le processus
    'Application.ScreenUpdating = False
 
'chapitre I : SYNTHESE - 3 tableaux
'Copie les 3 Tableaux de synthèse  depuis Excel onglet "DIAG"
Sheets("DIAG").Select
Range("Y348:AH361").Select
Selection.Copy
 
    'Cherche Signet1 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet1"
    DoEvents
 
    'Colle Tableau 1 à Signet1
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'autres collages possibles
    'aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, DisplayAsIcon:=False
    'aWord.Selection.PasteAndFormat (wdPasteDefault) 'copie en format tableau / ajuste à la largeur de la page word POURRIE
 
    'mise en page du Tableau 1 selon sa taille
    aWord.Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    DoEvents
    With dWord.InlineShapes(1)
        .LockAspectRatio = msoTrue
        .Height = 350 'redimensionne hauteur image
        '.Width = 510 'redimensionne largeur image
        '.ConvertToShape
    End With
    'dWord.Shapes(1).Left = wdShapeCenter
    'dWord.Shapes(1).Rotation = 90
    'ActiveDocument.Shapes(1).ConvertToInlineShape
 
Sheets("DIAG").Select
Range("B303:K324").Select
Selection.Copy
 
    'Cherche Signet2 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet2"
    DoEvents
 
    'Colle à Signet2
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'autres collages possibles
    'aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, DisplayAsIcon:=False
    'aWord.Selection.PasteAndFormat (wdPasteDefault) 'copie en format tableau / ajuste à la largeur de la page word POURRIE
 
    'mise en page selon sa taille
    aWord.Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    DoEvents
    With dWord.InlineShapes(2)
        .LockAspectRatio = msoTrue
        .Height = 450 'redimensionne hauteur image
        '.Width = 510 'redimensionne largeur image
        '.ConvertToShape
    End With
 
Sheets("DIAG").Select
Range("B325:K346").Select
Selection.Copy
 
    'Cherche Signet3 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet3"
    DoEvents
 
    'Colle à Signet3
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'autres collages possibles
    'aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, DisplayAsIcon:=False
    'aWord.Selection.PasteAndFormat (wdPasteDefault) 'copie en format tableau / ajuste à la largeur de la page word POURRIE
 
    'mise en page selon sa taille
    aWord.Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    DoEvents
    With dWord.InlineShapes(3)
        .LockAspectRatio = msoTrue
        .Height = 450 'redimensionne hauteur image
        '.Width = 510 'redimensionne largeur image
        '.ConvertToShape
    End With
 
Clear_Clipboard
Commande0_Click
 
'chapitre II : ALEA(S)& LOCALISATION DES FACES EXPOSEES
'Copie Tableau depuis Excel onglet "aléa Surpression"
Sheets("aléa Surpression").Select
Range("B4:V56").Select
Selection.Copy
 
    'Cherche Signet4 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet4"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page selon sa taille
    With dWord.InlineShapes(4)
        '.LockAspectRatio = msoFalse
        .LockAspectRatio = msoTrue
        .Height = 400 'redimensionne hauteur image
        '.Width = 200 'redimensionne largeur image
    End With
 
Clear_Clipboard
Commande0_Click
 
'Chapitre III : Localisation des Menuiseries
'Pas de tableau
'insérer dessins, photos et références fenêtres
Sheets("Localisation F & PF").Select
Range("C11:Q56").Select
Selection.Copy
 
    'Cherche Signet5 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet5"
 
    'Colle à Signet5
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page selon sa taille
    With dWord.InlineShapes(5)
        '.LockAspectRatio = msoFalse
        .LockAspectRatio = msoTrue
        .Height = 400 'redimensionne hauteur image
        '.Width = 150 'redimensionne largeur image
    End With
 
'Chapitre  : Fiches Travaux
 
'Vide la pile du presse-papier, ça libère la mémoire pour ne pas avoir de bug
    Clear_Clipboard
    Commande0_Click
 
'FT Ouverture 1 Façade a
Sheets("FTA").Select
Range("C3:H25").Select
Selection.Copy
 
    'Cherche Signet6 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet6"
 
    'Colle à Signet6
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(6)
        '.LockAspectRatio = msoTrue
        .Width = 550 'redimensionne largeur image
    End With
 
'FT Ouverture 2 Façade a
Sheets("FTA").Select
Range("C27:H49").Select
Selection.Copy
 
    'Cherche Signet7 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet7"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(7)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
'FT Ouverture 3 Façade a
Sheets("FTA").Select
Range("C51:H73").Select
Selection.Copy
 
    'Cherche Signet8 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet8"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(8)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
'FT Ouverture 4 Façade a
Sheets("FTA").Select
Range("C75:H97").Select
Selection.Copy
 
    'Cherche Signet9 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet9"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(9)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
'Vide la pile du presse-papier, ça libère la mémoire pour ne pas avoir de bug
    Clear_Clipboard
    Commande0_Click
 
'FT Ouverture 5 Façade a
Sheets("FTA").Select
Range("C99:H121").Select
Selection.Copy
 
    'Cherche Signet10 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet10"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(10)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
'Vide la pile du presse-papier, ça libère la mémoire pour ne pas avoir de bug
    Clear_Clipboard
    Commande0_Click
 
'FT Ouverture 6 Façade a
Sheets("FTA").Select
Range("C123:H145").Select
Selection.Copy
 
    'Cherche Signet11 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet11"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(11)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
'Vide la pile du presse-papier, ça libère la mémoire pour ne pas avoir de bug
    Clear_Clipboard
    Commande0_Click

ET LA FIN QUI VISE DES SIGNETS DANS LE RAPPORT WORD QUI NE SE TROUVE PAS à LA SUITE DES PRECEDENTS (MAIS C'EST POSSIBLE, NON ?!) :

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
'SYNTHESE : ajout du nouveau tableau - priorisation
Sheets("DIAG").Select
Range("AK303:AS325").Select
Selection.Copy
 
    'Cherche Signet92 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet92"
    DoEvents
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(92)
        '.LockAspectRatio = msoTrue
        .Width = 50 'redimensionne largeur image
    End With
 
'Chapitre : Fiche travaux COUVERTURES GE/PE
Sheets("FTGE").Select
Range("C3:H25").Select
Selection.Copy
 
    'Cherche Signet93 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet93"
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(93)
        '.LockAspectRatio = msoTrue
        .Width = 250 'redimensionne largeur image
    End With
 
'Chapitre PRIORISATION : ajout du nouveau tableau - priorisation
Sheets("DIAG").Select
Range("AK303:AS325").Select
Selection.Copy
 
    'Cherche Signet94 dans le rapport-modèle
    aWord.Selection.Goto What:=wdGoToBookmark, Name:="Signet94"
    DoEvents
 
    'Colle
    DoEvents
    aWord.Selection.PasteSpecial , Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
 
    'mise en page du Tableau selon sa taille
    With dWord.InlineShapes(94)
        '.LockAspectRatio = msoTrue
        .Width = 500 'redimensionne largeur image
    End With
 
 
 
 
 
 
 
'Sauvegarde du rapport ainsi créé sous nom standard SORTIE RAPPORT & nom
Application.CutCopyMode = False
Sheets("administrative").Select
aWord.Visible = True
aWord.ActiveDocument.SaveAs "G:\SORTIE RAPPORT -" & Sheets("administrative").Range("C29") & ".docm"
aWord.ScreenUpdating = True
 
'fin de la macro !
End Sub

**loliv44** · 16/06/2015, 13h22

Je reviens vous demander un coup de main !?! Merci pour celles/ceux qui s'y colleront !

Ceci dit

> pour mon premier problème "presse-papier vide ou non valide" :
J'ai blindé le code de "DoEvents" à chaque sélection de cellules / copier / coller : 1 doevents pour chaque opération...

C'est lourd mais ça semble tenir pour le moment ; si vous avez plus léger, je suis preneur !

> pour la taille de l'image en signet ; c'est toujours bancal...

Macro XL vers WD / "presse-papier vide ou non valide" alors que non & Redimensionnement objet image

Macros et VBA Excel

Discussions similaires

Partager

Partager