Simplifier une macro

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour a tous,
J'ai grâce à plusieurs aides développé cette macro, le probleme est qu'elle est trop lourde et je suis sûr que la moitié n'est pas utile. Quelqu'un peut-il m'aider à la simplifier svp (car j'ai certain beug de lancement d'outlook et je me demande si ce n'est pas du au volume de la macro...). Merci

Code:

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
Sub test_lien_PDF() 'Devis
With ActiveSheet.PageSetup
    .Orientation = xlLandscape
 
Worksheets("Demande de réparation").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:="C:\Users\TECH\Desktop\enregistrement PDF.pdf", _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
 
        If .Orientation = xlLandscape Then
 
        .Orientation = xlPortrait
        End If
 
        .Orientation = xlLandscape
        End With
 
Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim olFormatHTML As String
    FileAttach = "C:\Users\TECH\Desktop\enregistrement PDF.pdf" _
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
     strbody = "Information sur la mise à jour"
    On Error Resume Next
        With OutMail
            Select Case Sheets("Demande de réparation").Range("C3") ' <= la valeur à tester
   Case Is = "Test"
      .To = "Test@hotmail.fr"
            .Bcc = ""
            .Subject = "Demande de réparation"
            .BodyFormat = olFormatHTML
          .HTMLBody = "Bonjour, <BR><BR>Ce message vous informe que     " & Worksheets("Demande de réparation").Cells(3, "C") & "      a enregistré la pièce      " & Worksheets("Fiche de réparation").Cells(2, "I") & "       dans le fichier réparation materiel .<BR><BR>" _
            & "<A href=" & """" & "\\Nom_serveur\Repertoire\nom_ficihier.xls" & """" & "></A>" & Chr(10) & "<BR><BR>Cordialement"
            .Attachments.Add Réparation_matériel_test2
            .Attachments.Add (FileAttach)
            .OriginatorDeliveryReportRequested = False
            .ReadReceiptRequested = False
            .Display
 
 
        End With
            On Error GoTo 0
 
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub

Bonjour,
Code:

1 2 3 4 5 6 7 8 With ActiveSheet.PageSetup .Orientation = xlLandscape '... If .Orientation = xlLandscape Then .Orientation = xlPortrait End If .Orientation = xlLandscape End With
Je traduis en français :

Orienter la page en paysage.
Si la page est orientée en paysage, alors l'orienter en portrait.
Orienter la page en paysage.

Tu es d'accord, que dans tous les cas la page sera orientée en paysage à la fin, non ? La première ligne suffit.
Code:

1 2 3 Select Case Sheets("Demande de réparation").Range("C3") ' <= la valeur à tester Case Is = "Test" '...
Il manque le End Select. D'autre part, il n'est pas vraiment intéressant de faire un Select Case pour une seule condition. Utilise plutôt une condition If.

A quoi te sert le On Error Resume Next ? En général, ce n'est pas bon signe d'utiliser ceci, il vaut mieux essayer "d'attraper" les erreurs et les gérer plutôt que de les cacher par un On Error Resume Next. D'ailleurs, si tu l'enlèves et que tu lances ta macro, cela te permettra de repérer si, en effet, il y a des erreurs dans ta macro : et si oui, lesquelles et où. Cela te permettra de mieux les gérer.

Il y a peut-être d'autres simplifications à faire, mais je suis moins à l'aise avec le reste de ton code, alors je laisse d'autres personnes tenter leurs chances ;)

19/06/2017, 09h00
babuf

Merci riaolle,

Pour l’orientation je suis d'accord que ça ne sert pas...
En revanche pour Le select case de l'adresse mail je n'ai pas une mais 15 conditions donc pas le choix ... ( je ne voulais juste pas afficher les adresses mail j'ai donc simplifié...).
Pour le on erreur pas la moindre idée je le supprime et je te dis si ça marche toujours.

Merci beaucoup pour les points que tu as souligné .
19/06/2017, 09h06
babuf

J'ai bien une erreur ^^

"incompatibilité de type" à ce niveau .BodyFormat = olFormatHTML
19/06/2017, 09h29
riaolle

olFormatHTML est une constante de BodyFormat prédéfinie, il ne faut donc pas le définir comme une variable. Enlève ta ligne

Code:

Dim olFormatHTML As String

Pour la suite, je peux pas trop t'aider, parce que je connais pas trop les fonctions que tu utilises, mais d'autres personnes passeront par là ;)

une dernière question...

j'ai ce code pour ouvrir outlook
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Dim SessionOutlook, myOlApp Const Chemin As String = "C:\Program Files\Microsoft Office\Office12\OUTLOOK" On Error Resume Next Set Appli = GetObject(, "Outlook.Application") If Appli Is Nothing Then SessionOutlook = Shell(Chemin, 1) Else myOlApp.Quit SessionOutlook = Shell(Chemin, 1) End If
il fonctionne mais affiche outlook sur l’écran comment faire pour juste l’avoir en barre de tache en bas ( ou encore mieux qu'il fonctionne en arrière plan et donc qu'on ne le voit pas du tout???

19/06/2017, 10h23
joe.levrai

Bonjour,

Code:

OutApp.Visible = False
19/06/2017, 10h28
babuf

il faut le poser ou ??? j'ai déjà essayé plusieurs fois sans sucées ...

désolé de revenir a la charge avec mon code mais voila il est comme ça

Code:

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
 
Sub test_lien_PDF() 'Devis
With ActiveSheet.PageSetup
    .Orientation = xlLandscape
 
Worksheets("Demande de réparation").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:="C:\Users\TECH\Desktop\enregistrement PDF.pdf", _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
 
.Orientation = xlLandscape
 
        End With
 
Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim olFormatHTML As String
    FileAttach = "C:\Users\TECH\Desktop\enregistrement PDF.pdf" _
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
     strbody = "Information sur la mise à jour"
    On Error Resume Next
        With OutMail
            Select Case Sheets("Demande de réparation").Range("C3") ' <= la valeur à tester
   case is ... 
    End Select
            .Bcc = ""
            .Subject = "Demande de réparation"
          .HTMLBody = "Bonjour, <BR><BR>Ce message vous informe que     " & Worksheets("Demande de réparation").Cells(3, "C") & "      a enregistré la pièce      " & Worksheets("Fiche de réparation").Cells(2, "I") & "       dans le fichier réparation materiel .<BR><BR>" _
            & "<A href=" & """" & "\\Nom_serveur\Repertoire\nom_ficihier.xls" & """" & "></A>" & Chr(10) & "<BR><BR>Cordialement"
            .Attachments.Add Réparation_matériel_test2
            .Attachments.Add (FileAttach)
            .OriginatorDeliveryReportRequested = False
            .ReadReceiptRequested = False
            .Display
    Dim SessionOutlook, myOlApp
   Const Chemin As String = "C:\Program Files\Microsoft Office\Office12\OUTLOOK"
 
    On Error Resume Next
    Set Appli = GetObject(, "Outlook.Application")
 
    If Appli Is Nothing Then
    SessionOutlook = Shell(Chemin, 1)
Else
 
    SessionOutlook = Shell(Chemin, 1)
    End If
 
     End With
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub

et j'ai essayé de le mettre partout (oui oui je suis désespéré ) mais pas moyen de faire disparaitre la page outlook ...

19/06/2017, 10h47
joe.levrai

et si tu tentais de réduire la fenêtre ?

Code:

OutApp.ActiveExplorer.WindowState = 3

en fait je crois que j'ai été un peu vite, il me semble (désolé mon outlook est en pleine macro) que l'objet Application de Outlook ne possède pas de propriété .Visible
19/06/2017, 10h53
babuf

sans vouloir abuser ... tu peux me dire ou le mettre stp j'y arrive vraiment pas :(
19/06/2017, 10h56
halaster08
Citation:

Envoyé par babuf

tu peux me dire ou le mettre stp j'y arrive vraiment pas :(

Dans ton C...ode

Juste après le set logiquement.
Code:

1 2 Set OutApp = CreateObject("Outlook.Application") OutApp.ActiveExplorer.WindowState = 3
19/06/2017, 10h59
babuf

Il va finir par y aller ...

variable objet ou variable bloc with non définie sur " OutApp.ActiveExplorer.WindowState = 3 " comment le définir?
19/06/2017, 11h02
joe.levrai

montre ta procédure complète, tu utilises bien OutApp dans celle-ci ?

l'erreur signifie que tu manipules un objet qui n'existe pas (ou pas encore)

j'utilise ce macro

Code:

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
 
 
Sub test_lien_PDF() 'Devis
With ActiveSheet.PageSetup
    .Orientation = xlLandscape
 
Worksheets("Demande de réparation").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:="C:\Users\TECH\Desktop\enregistrement PDF.pdf", _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
 
    .Orientation = xlLandscape
End With
 
Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim olFormatHTML As String
    FileAttach = "C:\Users\TECH\Desktop\enregistrement PDF.pdf" _
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.ActiveExplorer.WindowState = 3
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
     strbody = "Information sur la mise à jour"
    On Error Resume Next
        With OutMail
            Select Case Sheets("Demande de réparation").Range("C3") ' <= la valeur à tester
   Case Is = "test"
To "test@hotmail.fr" 
    End Select
            .Bcc = ""
            .Subject = "Demande de réparation"
          .HTMLBody = "Bonjour, <BR><BR>Ce message vous informe que     " & Worksheets("Demande de réparation").Cells(3, "C") & "      a enregistré la pièce      " & Worksheets("Fiche de réparation").Cells(2, "I") & "       dans le fichier réparation materiel .<BR><BR>" _
            & "<A href=" & """" & "\\Nom_serveur\Repertoire\nom_ficihier.xls" & """" & "></A>" & Chr(10) & "<BR><BR>Cordialement"
            .Attachments.Add Réparation_matériel_test2
            .Attachments.Add (FileAttach)
            .OriginatorDeliveryReportRequested = False
            .ReadReceiptRequested = False
            .Display
    Dim SessionOutlook, myOlApp
    OutApp.ActiveExplorer.WindowState = 3
   Const Chemin As String = "C:\Program Files\Microsoft Office\Office12\OUTLOOK"
   OutApp.ActiveExplorer.WindowState = 3
 
    On Error Resume Next
    Set Appli = GetObject(, "Outlook.Application")
 
    If Appli Is Nothing Then
    SessionOutlook = Shell(Chemin, 1)
OutApp.ActiveExplorer.WindowState = 3
Else
End If
 
     End With
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub

vraiment désolé de t’embêter avec ça ...
le problème est donc sur la ligne 24 et j'utilise bien outapp ( ligne 17 ... sauf erreur de ma part )

19/06/2017, 11h10
joe.levrai
Met 1 au lieu de 3 ... maintenant que j'ai la main sur outlook je suis allé récupérer la bonne valeur de constante

testé à l'instant directement dans mon outlook
Code:

1 2 3 4 5 6 Sub testtee() Dim OutApp As Object Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon OutApp.ActiveExplorer.WindowState = 1 End Sub
19/06/2017, 11h12
babuf

même erreur ...
19/06/2017, 11h21
halaster08

J'ai aussi le message d'erreur mais uniquement quand outlook est déjà minimisé, donc il suffit de rajouter un test si.

Code:

if not(OutApp.ActiveExplorer.WindowState = 1) then OutApp.ActiveExplorer.WindowState = 1

Déjà en ligne 32, met le "." devant la propriété To

ensuite, je ne sais vraiment pas ce que tu fais à partir de la ligne 43, tu prends des nouvelles variables et tu tentes à nouveau la popotte pour chopper l'instance Outlook ??

un peu de ménage et un début de remise en forme (on appelle ça l'indentation)

Code:

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
Sub test_lien_PDF() 'Devis
Dim OutApp As Object
Dim strbody As String
 
    ActiveSheet.PageSetup.Orientation = xlLandscape
    Worksheets("Demande de réparation").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:="C:\Users\TECH\Desktop\enregistrement PDF.pdf", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
 
    FileAttach = "C:\Users\TECH\Desktop\enregistrement PDF.pdf" _
 
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    OutApp.ActiveExplorer.WindowState = 3
    strbody = "Information sur la mise à jour"
    On Error Resume Next   ' pourquoi une gestion d'erreur ??
        With OutApp.CreateItem(0)
            Select Case Sheets("Demande de réparation").Range("C3") ' <= la valeur à tester
                Case "test"
                    .To "test@hotmail.fr"
            End Select
 
            .Bcc = ""
            .Subject = "Demande de réparation"
            .HTMLBody = "Bonjour, <BR><BR>Ce message vous informe que     " & Worksheets("Demande de réparation").Cells(3, "C") & "      a enregistré la pièce      " & Worksheets("Fiche de réparation").Cells(2, "I") & "       dans le fichier réparation materiel .<BR><BR>" _
            & "<A href=" & """" & "\\Nom_serveur\Repertoire\nom_ficihier.xls" & """" & "></A>" & Chr(10) & "<BR><BR>Cordialement"
            .Attachments.Add Réparation_matériel_test2
            .Attachments.Add (FileAttach)
            .OriginatorDeliveryReportRequested = False
            .ReadReceiptRequested = False
            .Display
        End With
 
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub

19/06/2017, 11h23
babuf

la variable reste non définie .

Voir 40 message(s) de cette discussion en une page