Sauvegarder en PDF/XLSM avec specification du dossier + Envoi Outlook

Le 10/09/2020 à 11:34

Bonjour à tous,

J'ai modifié une macro trouvée en ligne me permettant de sauvegarder mon fichier sous format XLSM en choisissant le chemin puis d'envoyer le même fichier via Outlook en attache d'un email avec format prédéfinit.

Jusque là superbe.

Je souhaiterais savoir s'il est possible de prédéfinir le chemin de sauvegarde lorque la boite de dialogue s'ouvre?

Ou si pas possible de directement définir dans la macro le chemin et garder le Kill xFolder si duplicate?

Je pensais ajouter une dim xPath As String et la reprendre en haut comme ci-dessous mais bon ca ne marche pas :

Dim xPath As String


Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

xPath = "V:\Quality\Waiver (Spot and Pre Approved)"
If xFileDlg.Show = True Then
xFolder = xPath
Else

Si quelqu'un a une solution soit en modifiant la partie selection dossier via boite de dialoge ou en forcant directement l'enregistrement du fichier dans le dossier souhaite.

Merci a vous

Jeremy

Sub Saveasxlsmandsend2()
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
Dim xMemberName As String
Dim xMemberName2 As String
Dim xMemberName3 As String
Dim xFileDate As String

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the Excel file into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If

xMemberName = Range("A3").Value
xMemberName2 = Range("B11").Value
xMemberName3 = Range("D18").Value
xFileDate = Format(Now, "mm-dd-yyyy")

xFolder = xFolder + "/" + xMemberName + " " + "-" + " " + xMemberName2 + " " + "-" + " " + xMemberName3 + " " + "-" + " " + xFileDate + ".xlsm"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing Excel File, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as XSLM file
    xSht.SaveAs Filename:=xFolder, FileFormat:=xlOpenXMLWorkbookMacroEnabled

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = "fabienne.lerda@msc.com;jeremy.franc@msc.com"
        .CC = "joanne.lee@msc.com"
        .Subject = xMemberName + " " + "-" + " " + xMemberName2 + " " + "-" + " " + xMemberName3 + " " + "-" + " " + xFileDate
        .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Fabienne, Jeremy," & _
    "<br><br>" & _
    " We would like to seek for your approval on the waiver for" & " " & ActiveSheet.Range("B11").Value & "." & _
    "<br><br>" & _
    "Thank you in advance for your kind consideration," & _
    .HTMLBody & "</font>"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
Le 10/09/2020 à 15:56

Bonjour,

Je ne suis pas certain d'avoir totalement compris mais j'ai l'impression que votre macro fait déjà le travail !

Soit vous avez une boîte de dialogue où vous sélectionnez le dossier et alors on ne change rien. Soit vous prédéfinissez le chemin sans avoir recours à la boîte de dialogue.

xFolder = "V:\Quality\Waiver (Spot and Pre Approved)" 'saisie statique
'ou bien
xFolder = Range("A1").value 'si le lien se trouve en cellule A1 par exemple

Avec suppression des lignes :

Dim xFileDlg As FileDialog

Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the Excel file into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If

Cdlt,

Le 11/09/2020 à 04:25

Bonjour 3GB,

Cela marche à merveille. Merci beaucoup.

Est-il possible de sauvegarder le fichier dans un fichier spécifique en fonction d'une condition.

Je m'explique, mon fichier est pour mes commerciaux qui demandent des remises pour leurs clients. Ce fichier Excel me permet de standardiser les demandes lors de l'envoi par email et de sauvergarde les demandes dans un fichier spécifique pour la tracabilite.

Je souhaiterais en plus de sauvegarder faire une sauvegarde dans un dossier spécifique en fonction de la date de la demande.

Par exemple si la demande de remise est November 2020 le chemin devrait être :

V:\Quality\Waiver (Spot and Pre Approved)\2020\November

Sachant que la date de la demande est une valeur dans la feuille de calcul est-il possible de mettre en place une telle condition si les dossiers sont deja créés?

Merci pour votre aide

Jeremy

Le 11/09/2020 à 08:55

Bonjour Jeremy,

Est-ce que vous pourriez préciser votre besoin ? Que voulez-vous dans quels cas ? Sauvegarde, copies, emplacements, conditions...

Cdlt,

Le 11/09/2020 à 10:25

Bonjour 3GB,

Je souhaiterais garder la meme macro.

Toutefois lorsque le fichier est sauvegardé je souhaiterais que le chemin de sauvegarde soit conditionné par la date.

Exemple :

  1. si la date sur mon feuille de calcul est 11 Nov 2020 (en B6) je souhaiterais que la sauvegarde se fasse selon le chemin : V:\Quality\Waiver (Spot and Pre Approved)\2020\November
  2. si la date sur mon feuille de calcul est 11 Dec 2020 (en B6) je souhaiterais que la sauvegarde se fasse selon le chemin : V:\Quality\Waiver (Spot and Pre Approved)\2020\December
  3. si la date sur mon feuille de calcul est 11 Mar 2021 (en B6) je souhaiterais que la sauvegarde se fasse selon le chemin : V:\Quality\Waiver (Spot and Pre Approved)\2021\March

Les dossiers etant bien entendu deja créés je souhaite que le chemin de sauvegarde varie en fonction du mois et de l'année pour etre sauvegarder dans le bon dossier.

Est-ce un peu plus clair?

Merci a vous

Jeremy

Le 11/09/2020 à 10:29

Oui, très clair !

Donc, finie la sélection d'un dossier via la boite de dialogue ? Tu veux juste un enregistrement en fonction de la date ?

Je regarde ça...

Le 11/09/2020 à 10:31

Cependant, je te conseillerais d'avoir des dossiers 2001, ..., 2012. C'est plus simple pour le suivi chronologique...

Le 11/09/2020 à 10:35

En fait en supprimant la variable FileDialog selon tes recommendations la boite dialogue n'est plus nécessaire vu que je veux imposer a lutilisateur l'enregistrement dans un dossier precis, et maitenant en fonction de la date et du mois renseigne en B6.

Les dossier sont ranges chronologiquement par annnee, et chaque annee par mois

Merci

Le 11/09/2020 à 11:04

Voici un premier essai. J'ai un peu bricolé ton code également. Il faudra ajuster certaines range dans le code où je prévois que les adresses mail soient saisies sur la feuille excel directement.

Sub Saveasxlsmandsend2()

Dim xOutlookObj As Object, xEmailObj As Object
Dim xSht As Worksheet
Dim xUsedRng As Range
Dim xSaveDate$, xFolder$, xName1$, xName2$, xName3$, xDate$, xFilename$
Dim xDest1$, xDest2$, xDestCC$
Dim xYesorNo As Integer

'------------------------------------------------------------------------------------
'INITIALIZATION OF VARIABLES
Set xSht = ActiveSheet
Set xUsedRng = xSht.UsedRange

If Application.CountA(xUsedRng.Cells) = 0 Then
    MsgBox "The active worksheet cannot be blank", vbCritical, "Exiting Macro"
    GoTo TheEnd
End If

With xSht
    xSaveDate = .Range("B6").Value
    xFolder = "V:\Quality\Waiver (Spot and Pre Approved)\" & _
    Format(xSaveDate, "YYYY") & "\" & Application.Proper(Application.Text(xSaveDate, "MMMM"))
    xName1 = .Range("A3").Value
    xName2 = .Range("B11").Value
    xName3 = .Range("D18").Value
    xDest1 = .Range("").Value '  "fabienne.lerda@msc.com" CHOISIR UNE RANGE APPROPRIÉE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    xDest2 = .Range("").Value '  "jeremy.franc@msc.com" <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    xDestCC = .Range("").Value '  "joanne.lee@msc.com" <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
End With
xDate = Format(Now, "mm-dd-yyyy")
xFilename = xFolder & "\" & xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate & ".xlsm"

'------------------------------------------------------------------------------------
'CHECK IF FILE ALREADY EXISTS
'<<<<<<<<<<<<<<<<<<<<<JE CROIS QUE CE CADRE N'EST PAS NÉCESSAIRE CAR SAVEAS ENREGISTRE LA DERNIERE VERSION ET ECRASE LA PRECEDENTE
If Len(Dir(xFilename)) > 0 Then
    xYesorNo = MsgBox(xFilename & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFilename
    Else
        MsgBox "if you don't overwrite the existing Excel File, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        GoTo TheEnd
    End If
End If

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
xSht.SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

'------------------------------------------------------------------------------------
'CREATE OUTLOOK EMAIL
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .to = xDest1 & ";" & xDest2 '<<<<<<<<<
    .CC = xDestCC ' <<<<<<<<<<<<<
    .Subject = xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Fabienne, Jeremy," & _
    "<br><br>" & _
    " We would like to seek for your approval on the waiver for" & " " & xName2 & "." & _
    "<br><br>" & _
    "Thank you in advance for your kind consideration," & "</font>"
    '.HTMLBody & "</font>"
    .Attachments.Add xFilename
    '.send
End With

TheEnd:
Set xUsedRng = Nothing: xSht = Nothing
Set xEmailObj = Nothing: xOutlookObj = Nothing

End Sub

En tout cas, la question de l'enregistrement en fonction de la date devrait être réglée.

Le 11/09/2020 à 11:06

Un second essai sans vérifier que le fichier existe...

Sub Saveasxlsmandsend2()

Dim xOutlookObj As Object, xEmailObj As Object
Dim xSht As Worksheet
Dim xUsedRng As Range
Dim xSaveDate$, xFolder$, xName1$, xName2$, xName3$, xDate$, xFilename$
Dim xDest1$, xDest2$, xDestCC$
Dim xYesorNo As Integer

'------------------------------------------------------------------------------------
'INITIALIZATION OF VARIABLES
Set xSht = ActiveSheet
Set xUsedRng = xSht.UsedRange

If Application.CountA(xUsedRng.Cells) = 0 Then
    MsgBox "The active worksheet cannot be blank", vbCritical, "Exiting Macro"
    GoTo TheEnd
End If

With xSht
    xSaveDate = .Range("B6").Value
    xFolder = "V:\Quality\Waiver (Spot and Pre Approved)\" & _
    Format(xSaveDate, "YYYY") & "\" & Application.Proper(Application.Text(xSaveDate, "MMMM"))
    xName1 = .Range("A3").Value
    xName2 = .Range("B11").Value
    xName3 = .Range("D18").Value
    xDest1 = .Range("").Value '  "fabienne.lerda@msc.com" CHOISIR UNE RANGE APPROPRIÉE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    xDest2 = .Range("").Value '  "jeremy.franc@msc.com" <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    xDestCC = .Range("").Value '  "joanne.lee@msc.com" <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
End With
xDate = Format(Now, "mm-dd-yyyy")
xFilename = xFolder & "\" & xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate & ".xlsm"

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
On Error Resume Next
xSht.SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

'------------------------------------------------------------------------------------
'CREATE OUTLOOK EMAIL
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .to = xDest1 & ";" & xDest2 '<<<<<<<<<
    .CC = xDestCC ' <<<<<<<<<<<<<
    .Subject = xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Fabienne, Jeremy," & _
    "<br><br>" & _
    " We would like to seek for your approval on the waiver for" & " " & xName2 & "." & _
    "<br><br>" & _
    "Thank you in advance for your kind consideration," & "</font>"
    '.HTMLBody & "</font>"
    .Attachments.Add xFilename
    '.send
End With

TheEnd:
Set xUsedRng = Nothing: xSht = Nothing
Set xEmailObj = Nothing: xOutlookObj = Nothing

End Sub

En gérant toutefois les éventuels problèmes lors du saveas si fichier ouvert ou protégé.

Le 14/09/2020 à 06:12

Bonjour 3GB,

J'ai essayé ta dernière macro:

  1. Pour les destinataires/copie de l'email pas besoin de le definir en tant que valeur car ils sont identiques a chaque envoi donc je les supprime en tant que variable
  2. Pour l'enregistrement, le format "MMMM" correspond-il aux mois en anglais ou en francais ?
  3. J'ai essayé la macro le fichier est juste sauvegardé dans V:\Quality\Waiver (Spot and Pre Approved)\ mais ne suit pas la direction du fichier YYYY et MMM.

Format cellule B6

image

Format chemin :

image

Merci de ton aide.

Jeremy

Le 14/09/2020 à 08:00

Bonjour jeremy,

1 - D'accord, très bien, tu peux supprimer les variables et remettre les chaines avec les mails dans .to et .cc

2 - En principe, avec Application.text, le mois est retourné en anglais. C'est aussi pour cette raison que je suggérais de choisir des dossiers avec un nom de mois numérique. A tous les points de vue, c'est préférable.

3 - Il faut au préalable que les dossiers soient créés. A première vue, c'est le cas. Le problème réside dans le fait que le dossier est en majuscule chez toi et en nom propre dans le code

si la date sur mon feuille de calcul est 11 Nov 2020 (en B6) je souhaiterais que la sauvegarde se fasse selon le chemin : V:\Quality\Waiver (Spot and Pre Approved)\2020\November

Il faut donc remplacer (dans l'affectation de la ligne xFolder)

Application.Proper(Application.Text(xSaveDate, "MMMM"))

par

Ucase(Application.Text(xSaveDate, "MMMM"))

Cdlt,

Le 14/09/2020 à 08:04

Je précise qu'ici, le dossier sera censé porter le nom SEPTEMBER

Le 14/09/2020 à 08:57

Hello,

Toujours pas :

  • Chemin créé :
image
  • Cellule Excel => September 14th 2020
image
  • VBA :
Set xSht = ActiveSheet
Set xUsedRng = xSht.UsedRange

If Application.CountA(xUsedRng.Cells) = 0 Then
    MsgBox "The active worksheet cannot be blank", vbCritical, "Exiting Macro"
    GoTo TheEnd
End If

With xSht
    xSaveDate = .Range("B6").Value
    xFolder = "V:\Quality\Waiver (Spot and Pre Approved)\Spot Basis Waiver Approval" & _
    Format(xSaveDate, "YYYY") & "\" & UCase(Application.Text(xSaveDate, "MMMM"))
    xName1 = .Range("A3").Value
    xName2 = .Range("B11").Value
    xName3 = .Range("D18").Value

End With
xDate = Format(Now, "mm-dd-yyyy")
xFilename = xFolder & "\" & xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate & ".xlsm"

J'obtiens toujours le message d'erreur.

Si on part sur du numerique i.e (SEPTEMBER = 09 pour le nom de fichier) ca donnerait quoi sur la macro ?

Format(xSaveDate, "MM")?

Merci de ton aide

image
Le 14/09/2020 à 18:57

Salut jeremy,

Oui, c'est ça, format(xSaveDate, "MM") donnerait 01, ..., 12.

Là, ce n'est pas le dossier qui pose problème mais le fichier. C'est une boite de dialogue issue du code :

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
On Error Resume Next
xSht.SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

Ça veut dire en principe qu'un fichier du même nom est probablement ouvert ou protégé lors de l'exécution. Mais ici, c'est le SaveAs qui bloque (enregistrer sous une feuille !)

Essaie de la sorte :

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
On Error Resume Next
xSht.Copy 'copie dans nouveau classeur
with Activeworkbook
    .SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
    .close 'fermeture
end with
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

Cdlt,

Le 21/09/2020 à 06:56

Bonjour 3GB,

Ca marche merci beaucoup.

Deux autres petites questions :

1. J'ai inseré un autre module qui fonctionne plus ou moins de la meme facon mais qui cette fois au lieu de sauvegarder en XLSM, le fait en PDF.

Mon probleme c'est que dans le fichier Excel initial l'utilisateur peut avoir besoin d'inserer des documents en attache sur le fichier. Lorsque l'on convertit le classeur en PDF on ne peut plus cliquer sur le lien du fichier en attache. As tu une solution pour cela?

2. Pour la sauvegarde sur un fichier specifique, est-il possible par macro de sauvegarder un fichier sur un dossier specifique mais sur le cloud (en l'occurence SharePoint)?

Merci pour ton aide

Jeremy

Le 21/09/2020 à 10:07

Bonjour jeremy,

Je suis content que ça marche.

Honnêtement, je n'ai pas les réponses à tes 2 questions donc je pense que tu devrais créer 2 nouveaux posts, mais :

1 - Je pense que c'est "compliqué". Il faudrait peut-être essayer dans un 1er temps, en utilisant la méthode .exportasfixedformat, en mettant le paramètre includedocproperties sur True.
Si ça ne marche pas, on peut essayer avec la méthode Printout avec les paramètres suivants : Activeprinter:="PDFCreator", PrintToFile:=True, PrToFileName:=NomFichier.

Si ça ne marche toujours pas, poster un nouveau sujet sera le moyen le plus rapide d'obtenir éventuellement une solution.

2 - Je pense que c'est possible et assez simple. Tu devrais y parvenir avec un post ou une recherche internet assez rapidement. Quand j'aurai le temps, si tu n'as pas trouvé de réponse, je regarderai ce point.

Bonne journée,

Le 22/09/2020 à 11:11

Merci beaucoup pour ton aide.

Je vais me debrouiller pour les deux derniers points avec les pistes et autres articles sur internet.
Bonne semaine a toi.

Rechercher des sujets similaires à "sauvegarder pdf xlsm specification dossier envoi outlook"