Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Macro qui ralenti mon classeur après exécution

pat66

XLDnaute Impliqué
Bonjour le forum,
Quelqu'un aurez la gentillesse de me dire pourquoi après l'exécution de cette macro qui fonctionne bien, mon classeur est pratiquement paralysé, je dois oublier de décharger quelque chose ?
merci d'avance

Pat66

VB:
Option Explicit
Public Const ParamSendUsing As String = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Public Const ParamServeur As String = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Public Const ParamPort As String = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Public Const ParamIdentificateur As String = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Public Const ParamIdentifiant As String = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Public Const ParamMotDePasse As String = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Public Const ParamSsl As String = "http://schemas.microsoft.com/cdo/configuration/smtpusessl"

Sub EnvoiMailCDO()
Dim CdoMessage, CdoConfig, CdoParam
Dim Var1 As String                                             ' nom
Dim Chemin As String                                     'chemin du fichier
Dim NFichier As String                                      'Nom du fichier
Dim titre As String
Dim strbody As String
Var1 = [D6].Value              
If Var1 = Empty Then
MsgBox "Veuillez préciser le nom et le prénom !", vbYes, "PL"
Exit Sub
End If
Application.ScreenUpdating = False
Dim Sh1 As Worksheet
Set Sh1 = Feuil5 'A adapter si besoin en fonction du codename de la feuille 1
With Sh1.PageSetup
.PrintArea = "A1:N115" 'Zone d'impression à adapter de la feuille 1
.Zoom = False
.FitToPagesWide = 3
.FitToPagesTall = 3
'Réglage des marges
.LeftMargin = Application.InchesToPoints(1.2) 'Marge gauche
.RightMargin = Application.InchesToPoints(0.1) 'Marge droite
.TopMargin = Application.InchesToPoints(0.5) 'Marge haut de page
.BottomMargin = Application.InchesToPoints(0.1) 'Marge bas de page
.Orientation = xlLandscape 'Paysage     ' .Orientation = xlPortrait 'Portrait
End With
Sheets(Array(Sh1.name)).Select

Chemin = Application.ActiveWorkbook.Path   ' 'direction du fichier pdf
'If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin

NFichier = ThisWorkbook.Path & "\" & "PROSPECT" & "-" & Sh1.Range("G3") & "-" & Format(Date, "dd-mm-yyyy") & ".pdf" 'Création du fichier pdf
'Création du fichier PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=NFichier, Quality _
        :=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Set CdoConfig = CreateObject("CDO.Configuration")
    CdoConfig.Load -1
    Set CdoParam = CdoConfig.Fields

    With CdoParam
    .Item(ParamSendUsing) = 2
    .Item(ParamServeur) = [T9].Value
    .Item(ParamPort) = [T10].Value
    .Item(ParamIdentificateur) = "1"
    .Item(ParamIdentifiant) = [T12].Value    'Votre Identifiant
    .Item(ParamMotDePasse) = [T13].Value  'Votre mot de passe
    .Item(ParamSsl) = "true"
    .Update
    End With

    Set CdoMessage = CreateObject("CDO.Message")
    With CdoMessage
        Set .Configuration = CdoConfig
        .From = [T4].Value
        .To = [T5].Value
        .CC = [T6].Value 'destinataires en copie (CC)
        .BCC = [T7].Value 'destinataires en copie cachée (CCI)
        .Subject = "Relevé d'informations" & " " & "de" & " " & [D5] & " " & [G3] & "," & " dossier: " & [T16]
        .TextBody = "Bonjour," & vbNewLine & vbNewLine & "veuillez trouver ci-joint les informations de" & " " & [D5] & " " & [G3] & "," & " dossier: " & [T16] & vbNewLine & vbNewLine & "Cordialement" & vbNewLine & vbNewLine & "PL" & " : " & [T3]

    .Fields("urn:schemas:mailheader:disposition-notification-to") = [T4].Value
    .Fields("urn:schemas:mailheader:return-receipt-to") = [T4].Value
    .Fields.Update
        .AddAttachment NFichier
        .Send
    End With
    MsgBox "Le relevé a bien été envoyé !"
    Kill NFichier
    Set CdoMessage = Nothing
    Set CdoConfig = Nothing
    Set CdoParam = Nothing
    Set Sh1 = Nothing 'Decharge la feuille 1
    Application.ScreenUpdating = True
End Sub
 

patricktoulon

XLDnaute Barbatruc
Bonjour
il ne ralenti pas il bloque tant que le status de cdo n'est pas envoyé
j'utilise cdo depuis des années a ca aété toujours comme ca surtout si tu a des piece jointes il faut que le serveur upload c'est évident
depuis quelques années je vais ca en VBS externe comme ca je ne suis plus ennuyé avec le bloquage cdo en vba
en vbs les code sont quasiment identiques
te reste plus qu'a lancer le le vbs avec argument
et tu a la même chose sauf que vba est libéré
 

pat66

XLDnaute Impliqué
re,
ah ok bien compris, mais je n'y connais rien en VBS externe
Tu me dis que les codes sont quasiment identiques, aurais tu la gentillesse d'adapter mon code ?
En tout cas merci du conseil

Pat66
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…