Bonjour à tous,
Et oui n'étant toujours pas professionnel en VBA, je vais avoir besoin d'un peu d'aide.
Je suis partie sur une base de macro pour convertir mon onglet actif, en PDF avec enregistrement, puis envoie par mail.
Ceci fonctionne parfaitement, mais j'aimerais améliorer quelque point:
- J'enregistre toujours les PDF au même endroit, faudrait qu'elle pointe directement sur le dossier souhaité.
- Que le PDF prenne le nom du fichier excel (je suppose remplacé xSht.Name par ?)
- Et avoir un message, car quand j'insère un ".body" avant mon ".Attachements.Add x Folder" j'ai plus de signature mail.
Merci d'avance.
Voici mon code actuel.
Sub Mail_interne()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "Vous devez spécifier un dossier dans lequel enregistrer le fichier PDF." & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Vous devez spécifier un dossier de destination"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Voulez-vous l'écraser?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "Si vous n'écrasez pas le PDF existant, vous ne pouvez pas continuer." _
& vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Quitter la macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Impossible de supprimer le fichier existant. Veuillez vous assurer que le fichier n'est pas ouvert ou protégé en écriture." _
& vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Impossible de supprimer le fichier"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xFolder, Quality:=xlQualityStandard
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = "mails"
.CC = ""
.Subject = xSht.Name + " pour information - Action préventive"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "La feuille de calcul active ne peut pas être vide"
Exit Sub
End If
End Sub