Sub EnvoiMail()
Dim A$, B$, C$, D$, Sep$
Dim LaDate As String
Application.DisplayAlerts = False
Sep = "; "
If Sheets("Feuil1").Range("C52") = "OUI" Then
If Range("G46") <> "" Then A = A & Range("G46") '& Sep
If Range("G47") <> "" Then B = B & Range("G47") '& Sep
If Range("G48") <> "" Then C = C & Range("G48") '& Sep
If Range("B46") <> "" Then D = D & Range("B46") '& Sep
Application.DisplayAlerts = False
repertoireAppli = ActiveWorkbook.Path & "\"
Call PrintTest
Dim olapp As Object 'Outlook.Application
Set olapp = CreateObject("Outlook.Application")
Dim msg As Object 'MailItem
Set msg = olapp.CreateItem(olMailItem)
With msg
.To = A & ";" & B
.CC = C & ";" & D
.BCC = ""
.Subject = "Test envoi classeur"
.Body = Sheets("feuil1").Range("B1").Value & Chr(13) & Chr(13) & Sheets("feuil1").Range("B2").Value & Chr(13) & Chr(13)
.Attachments.Add repertoireAppli & "Bon de commande prestation annexe.pdf"
' .Display 'activer cette ligne afin que le message s'affiche avant de partir
.ReadReceiptRequested = True
End With
msg.Send
Set msg = Nothing
Set olapp = Nothing
On Error Resume Next
Kill repertoireAppli & "Bon de commande prestation annexe.pdf"
Else
MsgBox "Formulaire incomplet. Envoi annulé"
End If
End Sub
Sub PrintTest()
Call PrintSheetInPDF(Worksheets("Feuil1"))
End Sub '~PrintTest
Sub PrintSheetInPDF(shSheet As Worksheet)
Dim pdfjob As Object
Dim sPDFName As String
Dim sPDFPath As String
'/// Changer le nom du fichier de sortie sur la ligne ci dessous: ///
sPDFName = "Bon de commande prestation annexe.pdf" ' ThisWorkbook.Name & "_" & shSheet.Name & ".pdf"
sPDFPath = ThisWorkbook.Path
'Check if worksheet is empty and exit if so
shSheet.Select
If IsEmpty(shSheet.UsedRange) Then Exit Sub
' ##############################
' Pas trés propre, mais je n'ai pas réussi à récupérer l'instance de la classe
' PDFCreator.clsPDFCreator avec la fonction GetObject
' Remarque : si la tache "PDFCreator.exe" n'existe pas, la fonction KillTask("PDFCreator.exe") ne fait rien
Call KillTask("PDFCreator.exe")
' ##############################
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
With pdfjob
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Can't initialize PDFCreator.", vbCritical + vbOKOnly, "PrtPDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sPDFPath
.cOption("AutosaveFilename") = sPDFName
.cOption("AutosaveFormat") = 0 ' 0 = PDF
.cClearCache
End With
'Imprime le document en PDF
ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"
'Attend que le document soit entré dans la file d'impression
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False
'Attend que l'impression du document soit terminée
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
With pdfjob
.cDefaultPrinter = DefaultPrinter
.cClearCache
Application.Wait (Now + TimeValue("0:00:3"))
.cClose
End With
Set pdfjob = Nothing
End Sub '~PrintSheetInPDF
Sub KillTask(sAppName As String)
Dim oProcList As Object
Dim oWMI As Object
Dim oProc As Object
'Create WMI object instance:
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
'Create object collection of Win32 processes:
Set oProcList = oWMI.InstancesOf("win32_process")
'Iterate through the enumerated collection:
For Each oProc In oProcList
If UCase(oProc.Name) = UCase(sAppName) Then
oProc.Terminate (0)
End If
Next oProc
Else
'Report Error
MsgBox "Killing """ & sAppName & """ - Can't create WMI Object.", vbOKOnly + vbCritical, "CloseAPP_B"
End If
'Clear out the objects:
Set oProcList = Nothing
Set oWMI = Nothing
End Sub '~KillTask
