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 |
Partager