Coller en tant qu'image

Version imprimable

Bonjour à tous,

Avec l'aide du forum j'étais parvenu à créer un super code vba qui me permet de créer des plages nommées sur différents onglets qui correspondent à mes sauts de page, puis je lance une macro qui génère un fichier Word puis copie chacune des plages précédemment faites et va les coller les unes à la suite des autres en ajoutant un petit saut de page. :chin:

Dans le code je fais le collage avec ce bout de code :

Code:

1
2
 .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
Placement:=wdInLine, DisplayAsIcon:=False

Mais je ne parviens pas à mettre le mode d'actualisation des liaisons en mode manuel, du coup le fichier word bug puisqu'il actualise en permanence et ça fait tout ramer. :calim2:
Après réflexion je me dis que l’intérêt d'avoir des liaisons est assez limité pour mon utilisation. Du coup je souhaite les enlever. :zekill:
Mais si je passe Link: sur False, ça ne fonctionne pas correctement, ça me copie le même onglet à chaque fois. :weird:

Idem avec

Code:

1
2
'   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False

En fait, il faudrait simplement que ça fasse un copier en tant qu'image comme si je le faisais manuellement. Mais je ne connais pas la modification dans le code a effectuer.

Ci-dessous le code en question :

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
Sub export_excel_to_word()
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
Application.ScreenUpdating = False
 
 
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
      With obj.Selection.PageSetup
        .TopMargin = (20)
        .LeftMargin = (17.5)
        .RightMargin = (20)
        .BottomMargin = (0)
        .HeaderDistance = (0)
        .FooterDistance = (15)
    End With
 
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
      '.PasteAndFormat (wdChartPicture)
        .InsertBreak Type:=6
        End With
     End If
Next
 
For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
    End If
Next
 
For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
    End If
Next
 
newObj.Sections(1).Footers(1).PageNumbers.Add (2)
 
    'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
      ' PageNumberAlignment:=wdAlignPageNumberRight
 
   Application.CutCopyMode = False
    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
Application.ScreenUpdating = True
    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
 
    obj.Activate
    Set obj = Nothing
    Set newObj = Nothing
End Sub

Si besoin je peux vous laisser un fichier exemple.

Merci à tous !

06/12/2019, 14h07
MarcelG

Salut,

Dans cette discussion, j'utilise wordeditor pour copier en image une plage Excel vers un corps de mail Outlook.
Je pense que tu peux adapter.
06/12/2019, 14h18
Anthony47

Salut Marcel,

Merci de ta réponse.

J'ai oublié de préciser que je suis une bille en VBA..
Ce qui fait que je ne sais même pas quel parti de ton code est sensé m'interesser ^^' :oops:
06/12/2019, 14h35
Anthony47

Ok, j'ai tenté de remplacer mon .copy par ton .CopyPicture Appearance:=xlScreen, Format:=xlPicture.

Puis mon .PasteSpecial Link:=False, DataType:=wdPasteBitmap par ton .Paste.

Ça a l'air prometteur !!!

Les images ont pas trop le bon format (il faudrait que leur largeur soit égale à la largeur de la feuille -marges) mais sinon ça a l'air pas mal !

Rebonjour le fil,

Alors, après quelques essaies, la macro s'exécute beaucoup plus rapidement, je n'ai plus les bugs liés aux liaisons et c'est bien plus facile de gérer des images. 8-)

En revanche la macro semble instable. Parfois elle fonctionne, parfois non. Je dirais que sur 10 exécutions, 6 fonctionnent.
Ca à l'air aléatoire, sans que je ne change rien au fichier (ou que je clique ailleurs). :weird:

Quand ça ne fonctionne pas c'est tantôt la ligne du .CopyPicture Appearance:=xlScreen, Format:=xlPicture qui est surlignée et parfois la ligne du .Paste.

Ci-dessous le code en

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
Function exist(feuille As String, nom As String) As Boolean
exist = False
On Error Resume Next
    x = Sheets(feuille).Range(nom).Address
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function
 
Sub export_excel_to_word()
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
Application.ScreenUpdating = False
 
 
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
      With obj.Selection.PageSetup
        .TopMargin = (20)
        .LeftMargin = (17.5)
        .RightMargin = (20)
        .BottomMargin = (0)
        .HeaderDistance = (0)
        .FooterDistance = (15)
    End With
 
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
       ' .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      'Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
     End If
Next
 
For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
        .InsertBreak Type:=6
        End With
    End If
Next
 
For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
        .InsertBreak Type:=6
        End With
    End If
Next
 
newObj.Sections(1).Footers(1).PageNumbers.Add (2)
 
    'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
      ' PageNumberAlignment:=wdAlignPageNumberRight
 
   Application.CutCopyMode = False
    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
Application.ScreenUpdating = True
    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
 
    obj.Activate
    Set obj = Nothing
    Set newObj = Nothing
End Sub

Bonjour Antony, Bonjour le Forum

Je viens d'en faire l'expérience ce matin.

En définitive, mieux vaut enregistrer l'image pour la rapatrier dans le corps de texte.
Or, pour gérer celui-ci, on considére l'éditeur Word
(GetInspector.WordEditor)
J'en ai déduit que l'on pouvait en utiliser les fonctionnalités.

Enregistrement de l'image.

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
101
Public Sub save_img()
 
Dim s As Shape
Dim Champcop As Range
 
With Worksheets("lawks")
 
        .Activate
 
        'Précaution éventuelle
        If .Shapes.Count > 0 Then
                For Each s In .Shapes
                        With s
                                'Debug.Print S.Name
                                .Delete
                        End With
                Next s
        End If
 
        Set Champcop = .Range("corps_mail")
 
End With
 
Dim lechart As Object, hPicAvail As Long
 
Dim texte_date As String, name_img As String
 
texte_date = Format(Date, "yyyymmdd")
name_img = "Image_monjob_" & texte_date & ".jpg"
fullname_img = ThisWorkbook.Path & "\" & name_img
 
'----------------------
 
'suppression des images précédentes créées dans le répertoire
'necessite d'activer la reference Microsoft Scripting RunTime
 
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.file
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(ThisWorkbook.Path)
 
For Each FileItem In SourceFolder.Files
 
        With FileItem
               'Debug.Print .Name
               If InStr(.Name, "jpg") > 0 Then
                     If InStr(.Name, name_img) = 0 Then Kill .Path
               End If
        End With
 
Next FileItem
 
Set SourceFolder = Nothing
Set Fso = Nothing
 
'----------------------
 
Application.ScreenUpdating = False
 
With Worksheets("lawks")
 
    Set lechart = .ChartObjects.Add(0, 0, 1, 1).Chart
 
         CreateObject("htmlfile").parentwindow.clipboardData.clearData ("Text")  'on vide le clipboard entre chaque copie pour tester vraiment le available
 
        With lechart.Parent
 
                 .Width = Champcop.Width
                 .Height = Champcop.Height
                 .Left = Champcop.Left + Champcop.Width + 20:
 
                 Champcop.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
                 .Select
 
                 Do
                       DoEvents
                 Loop Until .Chart.Pictures.Count = 0
 
                 .Chart.Paste
 
                 Do
                       DoEvents
                 Loop While .Chart.Pictures.Count = 0
 
                 With .Chart
                       .Export FileName:=fullname_img, FilterName:="jpg"
                       '.Pictures(1).Delete    'on delete a chaque fois l'image collée (important si les champcops capturées sont differentes en terme de dimension)
                 End With
 
                 .Delete
 
           End With
 
      Set lechart = Nothing
 
End With
 
End Sub

Ne pas oublier d'activer la référence

Citation:

Micosoft Scripting.Runtime

Ici, la méthode Export revient à enregistrer l'image créée.

D'autre part.
Veiller à affecter une portée module à la variable du nom de l'image.
Autrement dit, en entête de module

Code:

Dim fullname_img As String

En 1er lieu (avant la sauvegarde de l'image), gérer l'item

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
With MonItem
        .To = L_dest
        .Subject = "salut_mercatog"
        .cc = L_copie
        .Categories = "Daily"
        ‘.Attachments.Add nom complet (avec répertoire) du document à attacher
        Application.wait (Now + TimeValue("0:00:01"))
        .Display
 
        'copie du corps de texte dans le corps de message
        Call save_img
 
        '------------------------------------------------------------------------------------
        On Error Resume Next
        AppActivate objet_mail & " - Message (HTML)" ' Active Outlook
        AppActivate objet_mail & " - Message" ' Active Outlook
        On Error GoTo 0
 
        Set édit_ol = .GetInspector
        Set wdDoc = édit_ol.WordEditor
 
        With wdDoc
                'New 10 Décembre 2019
                .InlineShapes.AddPicture FileName:=fullname_img

L'image nommée fullname_img sera ainsi importée dans le corps de texte par cette dernière ligne de code.

10/12/2019, 13h37
Anthony47

1 pièce(s) jointe(s)

Bonjour Marcel,

Merci de ta réponse, et content de voir qu'il y a une solution !

Par contre.. Tu m'as complètement perdu :mouarf:

Désolé, mais je suis une bille en VBA :oops:

Tu penses que tu pourrais me mettre tout ça sur mon fichier exemple ?
10/12/2019, 13h47
MarcelG

Salut,

Citation:

Tu penses que tu pourrais me mettre tout ça sur mon fichier exemple ?

Ce ne serait pas te rendre service, Antony.

Il te suffit juste d'adapter le code que je t'ai proposé pour quelques lignes.
Pour cela, tu le parcours dans ses grandes lignes.
Puis tu suis mes indications.
10/12/2019, 15h03
Anthony47

Salut Marcel,

Ecoute c'est bien venu de ta part, mais j'ai jamais progresser comme ça ^^'

Si je savais comment appliquer ce que tu me dis je l'aurais fait

1- "Or, pour gérer celui-ci, on considére l'éditeur Word
(GetInspector.WordEditor)" Que dois-je en faire ?

2- "Enregistrement de l'image." Je met ce bout de code où ?

3- Je vois que c'est en rapport avec des mails et outlook ..?

4- "Veiller à affecter une portée module à la variable du nom de l'image.
Autrement dit, en entête de module" - Comment je fais ça ?

5- "Dim fullname_img As String" Faut que je mette ça où ? Dans entête de module ? C'est où ?

6- "En 1er lieu (avant la sauvegarde de l'image), gérer l'item" Idem, je met ça ou ? Pourquoi ça parle de outlook ?

Voilà :mrgreen:
10/12/2019, 15h19
MarcelG

Salut,

Dans ces conditions, il ne faut pas aller plus loin.

Tu peux consulter cette discussion pour obtenir des liens vers des tutoriels de base
10/12/2019, 15h44
Anthony47

Ok, merci quand même. :aie:

Pour ceux que ça peut aider, j'ai corriger mes bug avec une attente qui vérifie que l'image a bien était collée.

Code:

1
2
3
4
5
With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With