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
| Option Explicit ' Cellules d'Excel vers tableau Word en VBA
' VBE menu "Tools" > "References" [x] Microsoft Word 8.0 Object Library
' ============ Description de la feuille Excel ============
Public Const nameSheetFact = "faits_constates"
Public Const rowFactStat = 14
Public Const colFactIsbn = 3 ' Contrats ISBN
Public Const colFactTitle = colFactIsbn + 1 ' Contrats Titre
Public Const nameSheetBlow = "coups_blessures"
Public Const rowBlowStat = 14
Public Const colBlowOther = 2 ' Contrats autre
' ============ Description du document Word ============
' VBE menu "Outils" > "Propriété de VBA Project" > "Arguments de compilation conditionnelle"
' isNetwork=1 pour un accès réseau. isNetwork=0 ou non défini pour un accès local
#If isNetwork = 1 Then
Public Const filenameDoc = "R:\PREVENTION ET SECURITE\NOUVELLE STRUCTURE\TABLEAUX DE BORD\MODAT Indicateurs\Modat Ind en cours\Année 2011\Docs_pierre\test_vba\Fenouillet_test11.doc"
#Else
' Test en local
Public Const filenameDoc = "C:\Users\You\Documents\Excel\Developpez\peter11\test11.doc"
#End If
Public Const isCopyDoc = True ' Copie le document dans un document temporaire
Public Const nameDocTmp = "Tmp.doc" ' Document Word temporaire de travail
Public Const indDocTableStat = 2 ' Seconde table dans le document
Public Const colDocIsbn = 1 ' Première colonne de la seconde table
Public Const colDocTitle = colDocIsbn + 1
Public Const colDocOther = colDocTitle + 1
Sub RemplirTableauWordDepuisDonneesExcel()
Dim wordApp As Word.Application, wordDoc As Word.Document, isDocSaved As Boolean
Dim contrats_ISBN As String, contrats_Titre As String, contrats_autre As String
Dim strNameDoc As String
If isCopyDoc Then If Not WordCopy(filenameDoc, WordTmp()) Then Exit Sub
Set wordApp = New Word.Application
Application.DisplayAlerts = True
wordApp.ShowMe
wordApp.Visible = True
strNameDoc = IIf(isCopyDoc, WordTmp(), filenameDoc)
If WordOpen(strNameDoc, wordApp, wordDoc) Then
With Sheets(nameSheetFact) ' Copie les données Excel
contrats_ISBN = .Cells(rowFactStat, colFactIsbn).Value
contrats_Titre = .Cells(rowFactStat, colFactTitle).Value
End With
contrats_autre = Sheets(nameSheetBlow).Cells(rowBlowStat, colBlowOther).Value
If WordTable(wordDoc, contrats_ISBN, contrats_Titre, contrats_autre) Then
isDocSaved = WordSave(wordDoc, strNameDoc)
End If
End If
wordApp.Quit
If isCopyDoc Then
If isDocSaved Then WordCopy WordTmp(), filenameDoc
' On Error Resume Next: Kill WordTmp(): On Error GoTo 0 ' Delete the temporary doc
End If
Set wordApp = Nothing
End Sub
Function WordTmp() As String
WordTmp = ThisWorkbook.Path + "\" + nameDocTmp
End Function
'Ouvre le document Word
Function WordOpen(ByVal strFilename As String, ByVal wordApp As Word.Application, _
ByRef wordDoc As Word.Document) As Boolean
WordOpen = False
On Error Resume Next
Set wordDoc = wordApp.Documents.Open(strFilename, ReadOnly:=False)
If Err.Number <> 0 Then Warning "1000: Impossible d'ouvrir " + strFilename: Exit Function
On Error GoTo 0
WordOpen = True
End Function
Function WordSave(wordDoc As Word.Document, ByVal strFilename As String) As Boolean
WordSave = False
On Error Resume Next
wordDoc.Application.ActiveDocument.Save
If Err.Number <> 0 Then
Warning "2000: Impossible de sauver " + strFilename: Exit Function
End If
On Error GoTo 0
WordSave = True
End Function
Function WordCopy(ByVal strFileSrc As String, ByVal strFileDest As String) As Boolean
On Error Resume Next
FileCopy strFileSrc, strFileDest
If Err.Number = 0 Then
WordCopy = True
Else
Warning "3000: Impossible de copier " + strFileSrc + vbCrLf + _
" dans " + strFileDest
WordCopy = False
End If
On Error GoTo 0
End Function
' Remplir la table n° indDocTableStat du document
Function WordTable(wordDoc As Word.Document, ByVal contrats_ISBN As String, _
ByVal contrats_Titre As String, ByVal contrats_autre As String) As Boolean
Dim lineLastDoc As Long
WordTable = False
If wordDoc.Tables.Count < indDocTableStat Then
Warning "4000: Impossible de trouver la table n° " & indDocTableStat & _
" dans le document Word"
Exit Function
End If
With wordDoc.Tables(indDocTableStat) ' Colle les données dans Word
.Rows.Add
lineLastDoc = .Rows.Count ' la dernière ligne ajoutée
.Cell(lineLastDoc, colDocIsbn).Range.InsertAfter contrats_ISBN
.Cell(lineLastDoc, colDocTitle).Range.InsertAfter contrats_Titre
.Cell(lineLastDoc, colDocOther).Range.InsertAfter contrats_autre
End With
WordTable = True
End Function
Sub Warning(ByVal strMsg As String) 'Common error management
Const lenErr = 4 ' Number of digits of the error code beginning the message
If Err.Number <> 0 Then
strMsg = strMsg + vbCrLf + "Error " + Str(Err.Number) + ": " + Err.Description
End If
MsgBox Mid(strMsg, lenErr + 3), vbExclamation, "Excel to Word warning " + Left(strMsg, lenErr)
End Sub |
