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
| Private WithEvents App As Application
Private Sub Workbook_Open()
Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal wb As Workbook)
Call MacroAutoJB
End Sub
Sub MacroAutoJB()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim oWdApp As Object
Dim i As Byte
Dim sChemin As String
Dim wb As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
On Error Resume Next
Dim nom As String
Dim sName As String
Dim sPath As String
On Error Resume Next
Dim j As Integer
j = ActiveSheet.UsedRange.Rows.Count
Dim n As Byte
n = Cells(1, Columns.Count).End(xlToLeft).Column
If ActiveWorkbook.Name Like "Class*.xls" Then
user = Environ("username")
sName = ActiveWorkbook.Name
sPath = "C:\Documents and Settings\" & user & "\My Documents\"
sName = Replace(sName, ".xls", "_Word")
MkDir sName
For j = 2 To j
Set WordApp = CreateObject("word.application") 'ouvre session word
nom = Sheets(1).Cells(j, 2)
mail = Sheets(1).Cells(2, n)
Set WordDoc = WordApp.Documents.Open("C:\Documents and Settings\" & user & "\ClassJb.doc")
Set oWdApp = CreateObject("Word.Application")
Set WordDoc = oWdApp.Documents.Open("C:\Documents and Settings\" & user & "\ClassJb.doc")
For i = 1 To n - 1
'les signets du document Word sont nommés Sig1 , Sig2 , Sig3
WordDoc.Bookmarks("Sig" & i).Range.Text = Cells(j, i) ' enregistre la ligne selectionné
Next i
WordDoc.Bookmarks("Signet").Range.Text = Cells(j, 2)
WordDoc.Bookmarks("Sigmail").Range.Text = Cells(j, n)
On Error Resume Next
nom = Replace(nom, ":", "") ' eliminer les caracteres speciaux dans les nom des DOC pour l enregistrement
nom = Replace(nom, """", "")
nom = Replace(nom, "/", "")
nom = Replace(nom, "\", "")
nom = Replace(nom, "*", "")
nom = Replace(nom, "?", "")
nom = Replace(nom, "<", "")
nom = Replace(nom, ">", "")
nom = Replace(nom, "|", "")
WordDoc.SaveAs Filename:=sPath & sName & "\" & nom & ".doc"
WordApp.Visible = False 'affiche le document Word
oWdApp.Quit
ActiveDocument.Close True
WordApp.Quit
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = nom
objMessage.From = "Server@domain.com"
objMessage.To = mail
objMessage.AddAttachment (sPath & sName & "\" & nom & ".doc")
objMessage.TextBody = "Bonjour" & "" & vbNewLine & " Le document que vous souhaiter l'exporter en document WORD a été envoyer le " & Now & vbNewLine & _
"Ce mail est généré automatiquement" & vbNewLine & _
"" & vbNewLine & _
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "10.168.55.150"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
Next j
ActiveWorkbook.Close
End Sub |
