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

  • Votes
  • Date
  • Date décroissante
  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à

    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>
      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.
        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
      4. Jul997 Auteur
        Et incompatibilité de type à ce niveau :

        Set Emplacement = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
        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à

          @+
      5. 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.
        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à
        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à
        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

          @+
      6. 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...
        1. 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
          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?
        2. Jul997 Auteur
          je n'ai malheureusement aucune ligne surlignée en jaune...
          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