Excel boutons

Jul997 -  
Bonjour,

J'ai sur ma feuille excel plusieurs boutons correspondant chacun au nom d'une personne. Ces boutons permettent de lancer plusieurs actions (envoi d'u mail, ....). J'aimerai crée un bouton "ajouter une personne" qui lorsque je clique dessus me demande le nom de la personne et crée un bouton qui fasse les mêmes actions que les autres boutons.
Est ce possible?
merci,

10 réponses

  1. Jul997 Auteur
    je n'ai malheureusement aucune ligne surlignée en jaune...
    0
    2. cs_Le Pivert Contributeur
      Voilà le code opérationnel! 

      Option Explicit
'allez dans outils, Référence et  cochez la référence Microsoft Outlook 12.0 object library
'déclaration des variables
Dim NouveauBouton As OLEObject
Dim Code$, NextLine&
Dim i As Integer
Dim Nom As String
Dim Emplacement As Object

Dim OutlookApp As Object
Dim OutlookMail As Object
Dim EMail As String
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim dl As Integer

Private Sub CommandButton1_Click()
Ajouter_Bouton
End Sub
Sub Ajouter_Bouton()
'emplacement et nom du bouton
Set Emplacement = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
Nom = InputBox("Entrer le nom du bouton :", "Saisie NOM")
Set NouveauBouton = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
   
   'création du bouton
    With NouveauBouton
        .Name = Nom
        .Left = Range(Emplacement.Address).Left
        .Top = Range(Emplacement.Address).Top
        .Width = 100
        .Height = 50
        .Object.Caption = Nom
    End With

'   Comment ajouter le code se rapportant au bouton...
    Code = "Sub " & Nom & "_Click()" & vbCrLf
    Code = Code & "  Nom = " & Nom & ".Caption" & vbCrLf
    Code = Code & "  On Error Resume Next" & vbCrLf
    Code = Code & "  envoimail" & vbCrLf
    Code = Code & "  If Err <> 0 Then" & vbCrLf
    Code = Code & "   MsgBox ""Impossible d'envoyer le mail.""" & vbCrLf
    Code = Code & "  End If" & vbCrLf
    Code = Code & "End Sub"

'   Ecriture du code dans le module de la feuille (fs)
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
      NextLine = .CountOfLines + 1
      .InsertLines NextLine, Code
    End With
End Sub
Sub envoimail()
dl = Sheets("Suivi des colis").Range("a9999").End(xlUp).Row + 1
Sheets("Suivi des colis").Range("a" & dl) = Format(Now, "MM/DD/YYYY HH:MM")

dl = Sheets("Suivi des colis").Range("b9999").End(xlUp).Row + 1
Sheets("Suivi des colis").Range("b" & dl) = Nom

Matériel.Show

EMail = "julienlaf2@gmail.com"
' definition du corps du mail "strbody" (sans la signature outlook)


Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

strbody = "Bonjour " & Nom & ",</br></br>Nous venons de réceptionner un colis qui t'est destiné.</br></br>Tu peux le récupérer à l'atelier B05.</br></br>Cordialement," 'j'ai changer JeanLuc par la variable Nom, a toi de voir???

' recupere la signature outlook, definis à qui envoyer, l'objet et ajoute la signature outlook au corps du mail "strbody"

SigString = Environ("appdata") & _
"\Microsoft\Signatures\mysign.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = "Le responsable Atelier B05"
End If

On Error Resume Next
 With OutlookMail
        .Display
        .To = EMail
        .CC = ""
        .BCC = ""
        .Subject = "Réception d'un colis au B05" & _
Format(Now, "hh:mm") & ""
        .HTMLBody = strbody & "<br><br>" & Signature
        .Send
    End With
     MsgBox "Mail envoyé."
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function OutlookOuvert() As Boolean
Dim oOL As Object
On Error Resume Next
Set oOL = GetObject(, "Outlook.Application")
On Error GoTo 0
OutlookOuvert = Not (oOL Is Nothing)
Set oOL = Nothing
End Function


      @+ Le Pivert
      0
  2. Jul997 Auteur
    ah merci ça marche mais une autre erreur apparaît, cette fois c'est l'erreur d’exécution 9 : l'indice n’appartient pas à la sélection
    0
    1. cs_Le Pivert Contributeur
      qu'elle est la ligne surlignée en jaune?
      quand tu passes le curseur sur toute la ligne, qu'indique-t-il?
      0
  3. Jul997 Auteur
    Merci beaucoup mais après qaund mon bouton est crée il n'arrive pas reproduire les mêmes actions que les autres boutons il ne se passe rien quand j'appuie.
    Dsl je ne suis pas très bon...
    0
    1. Jul997 Auteur
      Merci mais en fait, quand je rentre le nouveau prénom et que je valide, il me marque erreur d’exécution 1004 : l’accès par programme au projet Visual Basic n'est pas fiable.
      0
      1. cs_Le Pivert Contributeur
        Je ne vois pas pourquoi tu t'embêtes avec un bouton par personne pour utiliser la même macro avec le nom qui diffère!
        Utilise une Inputbox avec ta variable Nom comme je l'ai fait, Tu mets ta ligne de code comme ceci : 

        Sub envoimail()
Dim Nom As String
Nom = InputBox("Entrer le nom :", "Saisie NOM")


        et le tour est joué!
        Un seul bouton

        Voilà
        0
      2. cs_Le Pivert Contributeur
        Pour le nom, il ne faut pas de nom composé avec trait d'union ou d'espace. Car c'est ce nom qui est donné au bouton!!!

        si tu veux quand même mettre un bouton par personne, il faudra changer ce code: 

        '   Comment ajouter le code se rapportant au bouton...
    Code = "Sub " & Nom & "_Click()" & vbCrLf
    Code = Code & "  Nom = " & Nom & ".Caption" & vbCrLf 'ajout de cette ligne pour avoir le nom
    Code = Code & "  On Error Resume Next" & vbCrLf
    Code = Code & "  envoimail" & vbCrLf
    Code = Code & "  If Err <> 0 Then" & vbCrLf
    Code = Code & "   MsgBox ""Impossible d'envoyer le mail.""" & vbCrLf
    Code = Code & "  End If" & vbCrLf
    Code = Code & "End Sub"


        Voilà
        0
      3. cs_Le Pivert Contributeur
        Pour cela:

        l’accès par programme au projet Visual Basic n'est pas fiable.

        Va dans le Ruban: Developpeur; Sécurité des Macros et cocher:

        accès approuvé au modèle d'objet du projet VBA

        @+
        0
    3. Jul997 Auteur
      Et incompatibilité de type à ce niveau :

      Set Emplacement = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
      0
      1. cs_Le Pivert Contributeur
        aucun problème chez moi, si ce n'est que le mail ne part pas par manque d’élément. Pas de bug:

        https://www.cjoint.com/c/HJclMEKZx2Q

        Voilà

        @+
        0
    4. Jul997 Auteur
      il me dit nom ambigue detecte : getboiler
      0
      1. Jul997 Auteur
        Ah oui et ce que je t'ai envoyé n'ai pas le code complet. Tous est refait pour chaque prénom à chaque fois.
        0
        1. cs_Le Pivert Contributeur
          Voilà le code complet 

          Option Explicit
'déclaration des variables
Dim NouveauBouton As OLEObject
Dim Code$, NextLine&
Dim i As Integer
Dim Nom As String
Dim Emplacement As Object

Dim OutlookApp As Object
Dim OutlookMail As Object
Dim EMail As String
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim dl As Integer
Private Sub CommandButton1_Click()
Ajouter_Bouton
End Sub
Sub Ajouter_Bouton()
'emplacement et nom du bouton
Set Emplacement = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
Nom = InputBox("Entrer le nom du bouton :", "Saisie NOM")
Set NouveauBouton = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
   
   'création du bouton
    With NouveauBouton
        .Name = Nom
        .Left = Range(Emplacement.Address).Left
        .Top = Range(Emplacement.Address).Top
        .Width = 100
        .Height = 50
        .Object.Caption = Nom
    End With

'   Comment ajouter le code se rapportant au bouton...
    Code = "Sub " & Nom & "_Click()" & vbCrLf
    Code = Code & "  On Error Resume Next" & vbCrLf
    Code = Code & "  envoimail" & vbCrLf
    Code = Code & "  If Err <> 0 Then" & vbCrLf
    Code = Code & "   MsgBox ""Impossible d'envoyer le mail.""" & vbCrLf
    Code = Code & "  End If" & vbCrLf
    Code = Code & "End Sub"

'   Ecriture du code dans le module de la feuille (fs)
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
      NextLine = .CountOfLines + 1
      .InsertLines NextLine, Code
    End With
End Sub
Sub envoimail()

dl = Sheets("Suivi des colis").Range("a9999").End(xlUp).Row + 1
Sheets("Suivi des colis").Range("a" & dl) = Format(Now, "MM/DD/YYYY HH:MM")

dl = Sheets("Suivi des colis").Range("b9999").End(xlUp).Row + 1
Sheets("Suivi des colis").Range("b" & dl) = Nom  'j'ai changer JeanLuc par la variable Nom, a toi de voir???

Matériel.Show

EMail = "julienlaf2@gmail.com"
' definition du corps du mail "strbody" (sans la signature outlook)


Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

strbody = "Bonjour " & Nom & ",</br></br>Nous venons de réceptionner un colis qui t'est destiné.</br></br>Tu peux le récupérer à l'atelier B05.</br></br>Cordialement," 'j'ai changer JeanLuc par la variable Nom, a toi de voir???

' recupere la signature outlook, definis à qui envoyer, l'objet et ajoute la signature outlook au corps du mail "strbody"

SigString = Environ("appdata") & _
"\Microsoft\Signatures\mysign.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = "Le responsable Atelier B05"
End If

On Error Resume Next
OutlookMail.Open
With OutlookMail
.Subject = "Réception d'un colis au B05" & _
Format(heure, "hh:mm") & ""
.To = EMail
.htmlbody = strbody & "<br><br>" & Signature


OutlookMail.Send

End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function OutlookOuvert() As Boolean
Dim oOL As Object
On Error Resume Next
Set oOL = GetObject(, "Outlook.Application")
On Error GoTo 0
OutlookOuvert = Not (oOL Is Nothing)
Set oOL = Nothing
End Function


          @+ Le Pivert
          0
      2. Jul997 Auteur
        Bon je t'avoue que j'ai un peu de mal avec la partie "comment ajouter le code se rapportant au bouton".
        Donc voici le code que j'avais deja fait concernant les boutons :

        Function GetBoiler(ByVal sFile As String) As String
        'Dick Kusleika
        Dim fso As Object
        Dim ts As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
        End Function

        Option Explicit

        Private Sub JeanLuc_Click()
        Dim dl As Integer
        dl = Sheets("Suivi des colis").Range("a9999").End(xlUp).Row + 1
        Sheets("Suivi des colis").Range("a" & dl) = Format(Now, "MM/DD/YYYY HH:MM")

        dl = Sheets("Suivi des colis").Range("b9999").End(xlUp).Row + 1
        Sheets("Suivi des colis").Range("b" & dl) = "Jean-Luc CEBE"

        Matériel.Show

        Dim OutlookApp As Object
        Dim OutlookMail As Object
        Dim EMail As String
        Dim strbody As String
        Dim SigString As String
        Dim Signature As String
        Dim i
        If OutlookOuvert = False Then i = Shell("Outlook", vbNormalNoFocus)

        EMail = "julienlaf2@gmail.com"
        ' definition du corps du mail "strbody" (sans la signature outlook)

        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)

        strbody = "Bonjour Jean-Luc,</br></br>Nous venons de réceptionner un colis qui t'est destiné.</br></br>Tu peux le récupérer à l'atelier B05.</br></br>Cordialement,"

        ' recupere la signature outlook, definis à qui envoyer, l'objet et ajoute la signature outlook au corps du mail "strbody"

        SigString = Environ("appdata") & _
        "\Microsoft\Signatures\mysign.htm"

        If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
        Else
        Signature = "Le responsable Atelier B05"
        End If

        On Error Resume Next
        OutlookMail.Open
        With OutlookMail
        .Subject = "Réception d'un colis au B05" & _
        Format(heure, "hh:mm") & ""
        .To = EMail
        .htmlbody = strbody & "<br><br>" & Signature

        OutlookMail.Send

        End With

        End Sub

        Function OutlookOuvert() As Boolean
        Dim oOL As Object
        On Error Resume Next
        Set oOL = GetObject(, "Outlook.Application")
        On Error GoTo 0
        OutlookOuvert = Not (oOL Is Nothing)
        Set oOL = Nothing
        End Function
        </code>
        0
        1. Jul997 Auteur
          Ok merci beaucoup je vais tester et je reviens te dire!
          0
          1. cs_Le Pivert Contributeur
            Bonjour,

            Oui c'est possible, mais il faut maitriser vba pour écrire la macro qui est affectée au bouton.

            Le bouton d'ajout est le CommandButton1 a adapter

            Ce mettre sur la feuille concernée, faire Alt F11 pour accéder au module de la feuille et coller ce code: 

            Option Explicit
Private Sub CommandButton1_Click()
Ajouter_Bouton
End Sub
Sub Ajouter_Bouton()
Dim NouveauBouton As OLEObject
Dim Code$, NextLine&
Dim i As Integer
Dim Nom As String
Dim Emplacement As Object

'emplacement et nom du bouton
Set Emplacement = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
Nom = InputBox("Entrer le nom du bouton :", "Saisie NOM")
Set NouveauBouton = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
   
   'création du bouton
    With NouveauBouton
        .Name = Nom
        .Left = Range(Emplacement.Address).Left
        .Top = Range(Emplacement.Address).Top
        .Width = 100
        .Height = 30
        .Object.Caption = Nom 'à adapter suivant la feuille d'ouverture
    End With

'   Comment ajouter le code se rapportant au bouton...
    Code = "Sub " & Nom & "_Click()" & vbCrLf
    Code = Code & "  On Error Resume Next" & vbCrLf
    Code = Code & "  Sheets(""Feuil3"").Activate" & vbCrLf
    Code = Code & "  If Err <> 0 Then" & vbCrLf
    Code = Code & "   MsgBox ""Impossible d'activer la feuille3.""" & vbCrLf
    Code = Code & "  End If" & vbCrLf
    Code = Code & "End Sub"

'   Ecriture du code dans le module de la feuille (fs)
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
      NextLine = .CountOfLines + 1
      .InsertLines NextLine, Code
    End With
End Sub


            j'ai mis un code qui active la feuille 3 comme exemple. Si tu n'arrives pas à l'adapter il faudra que tu donnes ton code

            Voilà

            0