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
|
Option Explicit
Public pOptions As AdobePDFMakerForOffice.ISettings
Sub Envoi_auto()
Dim File_nm
Dim Email
Dim MyRange
Dim Response
Dim oWord
'Application.OLERequestPendingTimeout = 0
Application.DisplayAlerts = wdAlertsNone
File_nm = ActiveDocument.Name
File_nm = Left(File_nm, Len(File_nm) - 4)
File_nm = "I:\Contrats_pdf_test\" & File_nm & ".pdf"
'recup Email
Set MyRange = ActiveDocument.Range(0, 0)
Set MyRange = MyRange.GoTo(What:=wdGoToPage, Name:="2")
Set MyRange = MyRange.GoTo(What:=wdGoToBookmark, Name:="\page")
Email = MyRange.Sentences(6).Text
Email = Left(Email, Len(Email) - 4)
Email = Right(Email, Len(Email) - 11)
Call Pdf(File_nm, Email)
'lancertempo
Call Duplicata
ActiveDocument.Save
ActiveDocument.Close
'ActivePrinter = DefPrinter
Response = MsgBox("Souhaitez-vous continuez et envoyer par Courriel ce document ?", _
vbYesNo + vbCritical + vbDefaultButton2, "Vérification de l'envoi")
Application.DisplayAlerts = False
If _
Response = vbYes _
Then ' L'utilisateur a choisi Oui.
Call Mail(File_nm, Email)
End If
End Sub
Sub Pdf(File_nm, Email)
'Dim DefPrinter
'DefPrinter = Application.ActivePrinter
'ActivePrinter = "Adobe PDF"
Application.DisplayAlerts = False
'Application.
'.OLERequestPendingTimeout = 0
Set pOptions = Application.COMAddIns(2).Object.GetCurrentConversionSettings()
pOptions.AddTags = False
pOptions.AddLinks = True
pOptions.OutputPDFFileName = File_nm
pOptions.ViewPDFFile = True
Application.COMAddIns(2).Object.CreatePDFEx pOptions
End Sub
Sub Mail(File_nm, Email)
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
'Application.DisplayAlerts = wdAlertsNone
Application.DisplayAlerts = False
On Error Resume Next
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'Set the recipient for the new email
.To = Email
'Set the recipient for a copy
.CC = "MOI@afifi.com"
'Set the subject
.Subject = "Envoi certificat "
'The content of the document is used as the body for the email
.Body = "Bonjour" & vbCrLf & vbCrLf & _
"Veuillez trouver ci-joint le contrat demandé." & vbCrLf & vbCrLf & _
"Merci" & vbCrLf & vbCrLf & _
"" & vbCrLf & _
"" & vbCrLf & vbCrLf & _
"Ce message et toutes les pièces jointes (ci-après le ''message'') sont établis à l'intention exclusive de ses destinataires et sont confidentiels." & vbCrLf & _
"Si vous recevez ce message par erreur, merci de le détruire et d'en avertir immédiatement l'expéditeur." & vbCrLf & _
"Toute utilisation de ce message non conforme à sa destination, toute diffusion ou toute publication, totale ou partielle, est interdite, sauf autorisation expresse." & vbCrLf & _
"L'internet ne permettant & vbCrLf
.Attachments.Add Source:=File_nm
.Send
End With
If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub |
[VBA-W] Message genant : Prog occupé => Basculer vers
Répondre avec citation
???
Envoyé par lorbond
Partager