Export graphique vers word

Version imprimable

Bonjour ,

A partir d'un classeur excel je lance une macro créant un document word à partir d'un modèle ".dot"

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
Sub CréerCompteRendu()
    Dim objWord As Word.Application
    Dim Docu    As Word.Document
    Dim NomFichier As String
    Dim CodeAgence As String
    Dim CodeSecteur As String
    Dim Secteur As String
    Dim NomAgence As String
    Dim ChefAgence As String
    Dim j As Integer
 
 CheminRacine = Workbooks("Outil_CDG.xls").Sheets("Paramétrage").Range("CheminRacine").Value
 CheminModèles = Workbooks("Outil_CDG.xls").Sheets("Paramétrage").Range("CheminModèles").Value
 
 
'Blocage du recalcul automatique:
'Application.Calculation = xlCalculationManual
 
   On Error GoTo CréerCompteRendu_Error
    If Range("Choix_CodeAgence").Value = "" Then
        MsgBox _
            "Vous n'avez pas préciser pour quelle agence vous souhaitez travailler!", _
            vbExclamation, "Agence non spécifiée"
        Range("Choix_CodeAgence").Select
        Exit Sub
    End If
 
    'Définition des valeurs des variables
    NomFichier = Range("Choix_CodeAgence").Value & "_CRV_" & Left(Replace(Date, "/", ""), 4) _
        & Right(Year(Now), 2)
    CodeAgence = Range("Choix_CodeAgence").Value
    NomAgence = Range("Choix_NomAgence").Value
    CodeSecteur = Sheets("Menu").Range("Agence_CodeSecteur").Value
    Secteur = Sheets("Menu").Range("Agence_CodeSecteur").Value & "_" & Sheets("Menu").Range("Agence_NomSecteur").Value
 
    Sheets("Paramétrage").Select
 
    ChefAgence = ""
    'On va chercher le nomdu chef d'agence
    For j = 1 To Range("Destinataires").Rows.Count - 1
        If Range("Destinataires").Cells(j, 5).Value = CodeAgence Then
            If Range("Destinataires").Cells(j, 3).Value = "CDA" Or _
                Range("Destinataires").Cells(j, 3).Value = "CDD" Then
                ChefAgence = Range("Destinataires").Cells(j, 1).Value & " " & _
                    Range("Destinataires").Cells(j, 2).Value
            End If
        End If
    Next j
    Sheets("Menu").Select
 
    ' création de l'objet Word
    Set objWord = New Word.Application
 
    ' Word visible
    objWord.Visible = True
    objWord.WindowState = wdWindowStateMaximize
    'ouverture du fichier
    Set Docu = _
        objWord.Documents.Add(CheminModèles & "000_CRV_ddmmyy.dot")
With Docu.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Visite du " & Date
.Headers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment = wdAlignParagraphCenter
'.Footers(wdHeaderFooterPrimary).PageNumbers.Add
End With
 
    ' Insertion de la date
    objWord.ActiveDocument.Bookmarks("DateVisite2").Range.Text = Date
    ' Insertion du nom de l'agence
    objWord.ActiveDocument.Bookmarks("NomAgence").Range.Text = NomAgence
    ' Insertion du nom du chef d'agence
    objWord.ActiveDocument.Bookmarks("NomChefAgence").Range.Text = ChefAgence
 
'Lancement de la macro insérant les graphiques
    objWord.Run "InséreUnGrapheExcelDansWord"
    objWord.Run "InséreUnTableauExcelDansWord"
 
    ' sauvegarde
            Docu.SaveAs _
                FileName:=CheminRacine _
                & CodeAgence & "_" & NomAgence & "\" & Year(Now) & "\" & _
                "Compte_rendu_de_visite" & "\" & NomFichier & ".doc"
 
    ' fermeture du document
    'Docu.Close
    ' quitter Word
    'objWord.Quit
 
    ' libérer la mémoire des variables objet
    Set Docu = Nothing
    Set objWord = Nothing
   On Error GoTo 0
   Exit Sub
CréerCompteRendu_Error:
    MsgBox "Erreur " & Err.Number & " (" & Err.Description & _
        ") ", vbCritical
'délocage du recalcul automatique:
Application.Calculation = xlCalculationAutomatic
 
End Sub

Dans le code ci-dessus les lignes :

Code:

1
2
3
'Lancement de la macro insérant les graphiques
    objWord.Run "InséreUnGrapheExcelDansWord"
    objWord.Run "InséreUnTableauExcelDansWord"

lancent les macros du modèle .dot

Ces macros doivent insèrer dans le document des graphiques et tableaux situés dans un autre classeur :

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
Sub InséreUnGrapheExcelDansWord()
Dim XlAppli
Dim XlCl
Dim Xlfl
Dim Graphe
 
    Set XlAppli = CreateObject("Excel.Application") '< L'appli Excel
    Set XlCl = XlAppli.Workbooks.Open("C:\Documents and Settings\bertaudp\Mes documents\RCM_Auvergne Limousin\RCM_Auvergne Limousin\IRS\RCM_Evolution_IRS.xls") '< le classeur
        XlAppli.Calculate
        'Sleep 5000
        DoEvents
        'Sleep 5000
    Set Xlfl = XlCl.Worksheets("Evo_IRS_Agence") '< la feuille
    Set Graphe = Xlfl.ChartObjects(1) '< Le graphe 1
        Graphe.Chart.ChartArea.Copy
        DoEvents
        Selection.GoTo What:=wdGoToBookmark, Name:="GraphIRS"
        Selection.PasteAndFormat (wdChartPicture) 'Collage avec liaison
        DoEvents
 
    XlCl.Close False 'fermeture du fichier
    DoEvents
 
    'XlAppli.Quit 'Fermeture d'Excel
 
    Set Graphe = Nothing
    Set XlAppli = Nothing
    Set XlCl = Nothing
    Set Xlfl = Nothing
End Sub

L'import fonctionne seulement mon graphique n'est pas recalculé : une de ses valeurs sources est contenue dans mon premier classeur (celui dans lequel je lance la création du compte-rendu!).
Il faudrait que je puisse faire recalculé mon graphique avant de le copier pour l'insérer!
Quelqu'un à une idée ? (j'ai essayé Sleep et Application.Calculate sans succès!)

26/08/2008, 15h57
Daranc

Salut
ne peut tu pas lier le graphique à la source de données?
26/08/2008, 16h57
e040098k

Non car je génère 20 compte rendu à la suite et donc 20 graphique différent!
27/08/2008, 08h34
Godzestla

Bonjour,

as-tu essayé la démarche inversée , à savoir ouvrir ton modèle word depuis excel et puis revenir en excel ou tu exécutes un code VBA qui ouvre ton fichier excel avec le graphe et le copie dans dans le document word ouvert.

Avec ce système, il devrait calculer ton graphique.

J'ai bien essayé ca mais il me met une erreur (Erreur 1004 : erreur définie par l'application ou par l'objet)sur la ligne :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Application.Workbooks.Open ("C:\Documents and Settings\bertaudp\Mes documents\RCM_Auvergne Limousin\RCM_Auvergne Limousin\IRS\RCM_Evolution_IRS.xls") '< le classeur
DoEvents
 
Sheets("Evo_IRS_Agence").Select '< la feuille
Set Graphe = Sheets("Evo_IRS_Agence").ChartObjects(1) ' Graphe.Chart.ChartArea.Copy
DoEvents
 
objWord.Activate
 
objWord.ActiveDocument.Bookmarks("GraphIRS").Select
Selection.PasteSpecial DataType:=wdPasteBitmap
'Selection.Paste 'AndFormat (wdChartPicture) 'Collage image
DoEvents

27/08/2008, 11h00
Godzestla

Je ne vois pas sur quelle ligne tu as l'erreur.

peux-tu repréciser ?

merci.
27/08/2008, 11h33
e040098k

Excuses moi!

J'ai une erreur au moment de coller, sur cette ligne :

Code:

Selection.PasteSpecial DataType:=wdPasteBitmap

Salut essaie ceci.

Code:

1
2
 
objWord.PasteSpecial DataType:=wdPasteBitmap

Attention que si tu boucles sur ce code, tes différents paste vont se cumuler et bonjour la cata :aie:.

Si c'est le cas, il faut supprimer le résultat du pastespecial après avoir sauvé/imprimé.... le document word.

Voici un exemple avec bouclage. Reviens si tu ne comprends pas .

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
For Idx = 2 To lrow
            ....
            Bonus_Word.Bookmarks("Target").Range.PasteSpecial _
             Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine
            Bonus_Word.PrintOut
            ' Clear at "Target" bookmark position
            'Remove Inserted Contents at "Target" bookmark
             With Bonus_Word.Bookmarks("Target")
               Bookstart = .Start
               Bookend = .End
             End With
 
            Set Myrange = Bonus_Word.Range(Start:=Bookstart, End:=Bookend)
              Myrange.Delete
            End If
 
 
    Next Idx

27/08/2008, 14h39
e040098k

Ca ne fonctionne toujours pas! :cry:
27/08/2008, 14h54
Godzestla
peux-tu essayer la syntaxe que je propose dans mon exemple avec bouclage.
Code:

1 2 3 Bonus_Word.Bookmarks("Target").Range.PasteSpecial _ Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine
donc pour toi, quelques changements :
* tu enlèves ton select du bookmark qui se trouve avant et tu le met dans l'instruction pastespecial
* tu remplaces wdPasteBitmap par wdPasteOLEObject
*..

a voir si les autres parametres sont nécessaires.

Si cela ne marche pas, montre moi tout ton code.
28/08/2008, 14h20
ouskel'n'or

Tu dois remplacer Selection par l'objet Application. Si ObjWord est le document, ça ne peut pas fonctionner.
Ensuite, pour coller une "image" de ton graphe, et non ton graphe, c'est

Code:

WdApp.PasteAndFormat (wdChartPicture)

où wdApp est l'instance de l'application.
A toutes fins utiles ;)

Je n'ai pas enregistré tout de suite mais tu as plusieurs problèmes. Word ne reconnais pas les argument passés depuis Excel, tu dois utiliser leurs valeurs.
Par exemple, pour atteindre le signet, tu dois mettre -1 et non "wdGoToBookmark"
De même Placement:=0 insère le graphe sur la ligne du signet.
Je te mets un code qui fonctionne
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub CopierCollerGrapheDansWord() Dim FL1 As Worksheet Dim WdApp As Object Dim WdDoc Set FL1 = Worksheets("Feuil1") Set WdApp = CreateObject("Word.Application") Set WdDoc = WdApp.Documents.Open(Filename:="D:\Doc\Doc1.doc") DoEvents WdApp.Visible = False WdApp.Selection.GoTo What:=-1, Name:="Signet" FL1.Shapes(FL1.Shapes.Count).Copy WdApp.Selection.PasteSpecial Link:=False, DataType:=3, _ Placement:=0 DoEvents WdDoc.Close True DoEvents WdApp.Quit Set WdApp = Nothing Set WdDoc = Nothing End Sub
L'objet copié est un "Shape", ici le dernier créé.
Tu sauras adapter ? ;)

28/08/2008, 23h17
e040098k

:king: Nikel ! Ta solution focntionne à merveille, c'est pile poil ce dont j'avais besoins !

MERCI !!!!!