Comment compresser 4 macro en 1

Bonjour le forum

Je voudrai compresser ce code :

Il y 4 textbox qui renseigne chaque macro Outlook.

Si je clique sur un label correspondant à la textbox, seule celle-ci envoie le mail meme si les autres textbox sont remplies

'***** Correspond au programme du Label "Lbl_Mail"  *****
Private Sub Envoyer_Mail()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero13" & .Value        ' TxtB_Numero17, TxtB_Numero20, TxtB_Numero23
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail1"  *****
Private Sub Envoyer_Mail1()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero17" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail2"  *****
Private Sub Envoyer_Mail2()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero20" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail3"  *****
Private Sub Envoyer_Mail3()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero23" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub

Cordialement

Bonjour

Si je clique sur un label correspondant à la textbox,

Merci d'expliquer plus ou de mettre un fichier exemple

Quel est le code code correspondant au label dans l'USF -> Private Sub label click ????

Cordialement

Bonjour

exacte un oublie :

Private Sub Lbl_Mail_Click(): Call Envoyer_Mail: End Sub        ' .................................Envoyer un Mail
Private Sub Lbl_Mail1_Click(): Call Envoyer_Mail1: End Sub        ' ...............................Envoyer un Mail
Private Sub Lbl_Mail2_Click(): Call Envoyer_Mail2: End Sub        ' ...............................Envoyer un Mail
Private Sub Lbl_Mail3_Click(): Call Envoyer_Mail3: End Sub        ' ...............................Envoyer un Mail

ceci appelle cela :

'***** Correspond au programme du Label "Lbl_Mail"  *****
Private Sub Envoyer_Mail()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero13" & .Value        ' TxtB_Numero17, TxtB_Numero20, TxtB_Numero23
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail1"  *****
Private Sub Envoyer_Mail1()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero17" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail2"  *****
Private Sub Envoyer_Mail2()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero20" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub
'***** Correspond au programme du Label "Lbl_Mail3"  *****
Private Sub Envoyer_Mail3()
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "TxtB_Numero23" & .Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub

le fichier est dans une autre discussion : https://forum.excel-pratique.com/excel/soucis-avec-le-zoom-image-apres-une-selection-t84107.html

Ci tu clique sur le label, il renvoie sur la macro et récupère la valeur de la textBox du label correspondant.

Re

Actuellement vous avez un label qui ne contient pas de chiffre ce serait mieux d'en avoir un mais c'est pas une obligation.

En considérant que les labels sont numérotés, voici les modifications à faire

- Dans l'USF, mettre ce code

Private Sub Label1_Click()
i = Right(Me.Controls(Label).Name, 1)
Call Envoyer_Mail
End Sub

- Remplacer le code Private Sub Envoyer_mail par celui ci-dessous et s'il n'y est pas, le placer dans un module

Sub Envoyer_Mail()
Dim txttb As Byte
Select Case i
Case i = 1: txtb = 13
Case i = 2: txtb = 17
Case i = 3: txtb = 20
Case i = 4: txtb = 23
End Select
Application.DisplayAlerts = False
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
    .To = "TxtB_Numero" & txtb & .Value       ' TxtB_Numero17, TxtB_Numero20, TxtB_Numero23
   .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
End Sub

- En entete du module (donc au dessus de toutes les macros !), mettre cette instruction -->

Public i As Byte

Reste à tester

Cordialement

Bonjour,

ah non, lecture incomplète...

eric

Bonjour le fil

J'ai effectué les changements et les labels ne reprennent pas les valeurs des textboxs.

Alors j'ai fais vite fais un compressage de l'userform au strick minimum

Une erreur s'est glissée.

Edit Dan : Fichier supprimé --> comprenant des données confidentielles

Re,

avec un support c'est mieux, j'ai eu la flemme d'en faire un tout à l'heure pour contrôler un détail. Autre proposition à tester :

Private Sub Lbl_Mail1_Click()        ' ............................................................Envoyer un Mail
    Envoyer_Mail TxtB_Numero13.Text
End Sub
Sub Envoyer_Mail(dest As String)
    Application.DisplayAlerts = False
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = dest        ' TxtB_Numero17, TxtB_Numero20, TxtB_Numero23
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.DisplayAlerts = True
End Sub

eric

re

Désolé mais je n'ai pas eu le temps de vérifier dans votre fichier et je pensais que vous auriez adapté LABEL au bon nom

Modifiez le code comme suit

- Dans la Sub Lbl_Mail1 Remplacer

I = Right(Me.Controls(Label).Name, 1)

pa

 I = Right((Lbl_Mail1.Name), 1)

- Dans chaque code, le Lbl_Mail1 repris ci-dessus par LBL_Mail2, etc...

- Dans Envoyer mail

With OutMail
        .To = UserForm1("TxtB_Numero" & txttb).Text

Evitez de mettre des fichiers avec données confidentielles. Personnellement, cela ne me ferait pas plaisir de voir mes coordonnées au monde entier

Crdlt

bonjour le fil,

Je vais tester les deux propositions, et vous en faire un rapport dans 2 h je dois m'absenter

merci Dan & Eric

Cordialement

Bonjour le forum, le fil , Eriic et Dan

Voilà je viens de tester la modification par Eriic et je dois dire aucune erreur.

Le fichier

fonctionne correctement.

Et la modification de Dan

ne prend en compte que le premier label.

Même si tu clique sur un autre label correspond à sa textBox, il reprend la valeur du premier label.

.

Dan a écrit :

Evitez de mettre des fichiers avec données confidentielles. Personnellement, cela ne me ferait pas plaisir de voir mes coordonnées au monde entier

Vous avez les fichiers anonymisé dans vos messages correspondant.

En vous remerciant

Cordialement

Re

Tu as deux fois Public I as Byte Une fois dans l'USF et une fois dans le module.

Comme précisé avant dans mon post, cela doit uniquement se trouver en entete du module. Supprime le de l'entete de l'USF

Pour le reste, je devais être mal réveillé ... , modifie cette partie de code

    Select Case I
        Case Is = 1: txttb = 13
        Case Is = 2: txttb = 17
        Case Is = 3: txttb = 20
        Case Is = 4: txttb = 23
    End Select

Cordialement

Bonjour le forum, le fil, Dan

En effet s de Is joue son importance au code

Une fois rajouté le fichier fonctionne correctement.

Je garde ces 2 au cas ou. Deux approches différentes pour un même résultat

En te remerciant

Cordialement

Rechercher des sujets similaires à "comment compresser macro"