[WD-2007] Copié Collé Word en VBA [Résolu]

[Lovecr4ft]

Bonjour, ci-dessous mon code qui ne fonctionne pas. J'ai retourné le problème dans tous les sens je ne comprends pas pourquoi cela ne marche pas.

Le code suivant doit faire ceci, aller créer un nouveau document à partir d'un modèle File qui devient FileBis, et dans ce fichier FileBis j'aimerais inclure des documents words dont le chemin est donné par les cases Excels sélectionnées.
Ces fichiers words sont dans le dossier "Codes".

Ce qui marche, j'arrive à copier mon fichier et à construire les chemins de mes documents words correctement, cependant je n'arrive pas à faire le copié collé.

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
Sub incrémente() 'code
 
Dim NDF As String, NDF2 As String, Chemin As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordDoc2 As Word.Document
 
'Chemin des deux fichiers, le modèle et le nouveau
    NDF = ActiveWorkbook.Path & "\File.docx"
    NDF2 = ActiveWorkbook.Path & "\FileBIS.docx"
 
 
    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
 
    'Le document Word ne s'ouvre pas et ne s'affiche pas.
    With WordApp
        .Visible = False
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        .Selection.MoveRight Unit:=wdCell
        .Selection.MoveRight Unit:=wdCell
    End With
 
 
    'Ici je récupère le contenu de mes cellules sélectionnées qui contiennent des CODES, c'est codes correspondent à des fiches Words précréées
    Dim CurCell As Object
      For Each CurCell In Selection
       'ici je crée mon chemin pour pouvoir récupérer le contenu de ma fiche
        Chemin = ActiveWorkbook.Path & "\Codes\" & CurCell.Value & ".docx"
 
      'Ici j'ouvre ma fiche et je copie son contenue pour ensuite le....
        Set WordDoc2 = WordApp.Documents.Open(Chemin, ReadOnly:=False)
         Selection.WholeStory
         Selection.Copy
 
     '....coller dans mon document principal.
         WordDoc.PasteAndFormat (wdPasteDefault)
         WordDoc2.Close False
          Next
 
'Sauvegarde de mon fichier modifié avec un nouveau nom (le fichier de base n'est pas touché.
    WordDoc.Application.ActiveDocument.SaveAs NDF2
    WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
 
    MsgBox ("Fiche créée ")
End Sub

Je me suis inspiré de ce code mais il semble inachevé.

Je ne sais pas où ça coince :/.
Merci d'avance pour vos réponses.

[carden752]

Bonjour,

'Ici j'ouvre ma fiche et je copie son contenue pour ensuite le....
Set WordDoc2 = WordApp.Documents.Open(Chemin, ReadOnly:=False)
Selection.WholeStory
Selection.Copy

Ici tu sélectionnes le contenu de ton document (pas celui que tu as ouvert il n'est pas activé)
Essayes en rajoutant Worddoc2.Activate

Code :

1
2
3
4
 Set WordDoc2 = WordApp.Documents.Open(Chemin, ReadOnly:=False)
         WordDoc2.Activate
         Selection.WholeStory
         Selection.Copy

[Lovecr4ft]

Merci pour ta réponse
J'ai placé ta ligne mais ça ne fonctionne pas :/.
Est-ce que cela ne viendrait pas du fait que dans mon document il y est du texte ET une IMAGE?
Le PasteAndFormat me semble pas bon également, vu que je ne précise pas où je colle mon information. Sachant que j'aimerais insérer le contenu de mon fichier Codes\XXXX.docx à la fin.
Je ne sais pas où ça coince

[Lovecr4ft]

Bon,
j'ai voulu tester autrement. Et là où ça coince c'est dans le copier coller.
J'ai fait ce code "test" qui me permettrait (conditionnel) de copier un document File (son contenu), de le coller dans un document vierge, et de sauvegarder ce document dans FileBis. Mais ceci ne marche pas. Pourtant les fichiers s'ouvrent. (j'ai passé en Visible True pour voir ce qui se passe).

Dans le code précédent (1ère discussion), j'ai mis en Visible True aussi, et mes document CODES s'ouvrent aussi mais le copier coller ne marche pas non plus. Donc si j'arrive à voir pourquoi coince le copier coller je pourrais le faire pour tout.

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
 
Sub incrémente() 'code
 
Dim NDF As String, NDF2 As String, Chemin As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordDoc2 As Word.Document
 
    Set WordApp = CreateObject("Word.Application")
 
 
    NDF = ActiveWorkbook.Path & "\File.docx"
    NDF2 = ActiveWorkbook.Path & "\FileBIS.docx"
 
 
    On Error Resume Next
    Set WordDoc2 = WordApp.Documents.Add(DocumentType:=wdNewBlankDocument)
    Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
 
    With WordApp
        .Visible = True
       ' .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        '.Selection.MoveRight Unit:=wdCell
       ' .Selection.MoveRight Unit:=wdCell
    End With
 
    WordDoc.Activate
    Selection.WholeStory
    Selection.Copy
    WordDoc.Close
    Set WordDoc = Nothing
    WordDoc2.Activate
    Selection.PasteAndFormat (wdPasteDefault)
 
WordDoc2.Application.ActiveDocument.SaveAs NDF2
  ' WordApp.Application.Quit
   'Set WordDoc = Nothing
  ' Set WordApp = Nothing
 
    MsgBox ("Fiche créée ")
End Sub

Encore merci d'avance pour votre aide.

[Lovecr4ft]

J'ai réussi .
Et comme vraiment c'est très beau, je mets mon code pour les générations futures etc etc .
Donc en fait. Pour que ça marche il fallait appliquer mes fonction de copier coller
dans WordApp sinon il ne comprenait pas qu'il travaillait dans Word.

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
Sub incrémente() 'code
 
Dim NDF As String, NDF2 As String, Chemin As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordDoc2 As Word.Document
 
    Set WordApp = CreateObject("Word.Application")
 
 
    NDF = ActiveWorkbook.Path & "\File.docx"
    NDF2 = ActiveWorkbook.Path & "\FileBIS.docx"
 
 
    On Error Resume Next
    Set WordDoc2 = WordApp.Documents.Add(DocumentType:=wdNewBlankDocument)
    Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
 
    With WordApp
        .Visible = True
       ' .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        '.Selection.MoveRight Unit:=wdCell
       ' .Selection.MoveRight Unit:=wdCell
    End With
 
    WordDoc.Activate
     'Ici le copier est enfin possible ;)
     With WordApp
          .Selection.WholeStory
          .Selection.Copy
     End With
 
    WordDoc2.Activate
      'Et on peut enfin coller :).
With WordApp
         .Selection.PasteAndFormat (wdPasteDefault)
         End With
 
 
 
 
 
    Dim CurCell As Object
      For Each CurCell In Selection
         Chemin = ActiveWorkbook.Path & "\Codes\" & CurCell.Value & ".docx"
         Set WordDoc = WordApp.Documents.Open(Chemin, ReadOnly:=False)
         'CurCell.Value = Chemin
         WordDoc.Activate
'Ici aussi ;)     
   With WordApp
          .Selection.WholeStory
          .Selection.Copy
     End With
         WordDoc2.Activate
       'Idem ici:mrgreen:
    With WordApp
         .Selection.PasteAndFormat (wdPasteDefault)
         End With
          Next
 
   WordDoc2.Application.ActiveDocument.SaveAs NDF2
  ' WordApp.Application.Quit
   'Set WordDoc = Nothing
  ' Set WordApp = Nothing
 
    MsgBox ("Fiche créée ")
End Sub

Pour que le pilotage soit "invisible" pour l'utilisateur, passer l'argument Visible en False.
Bonne journée!!!