Excel boutons

Jul997 Messages postés 12 Statut Membre -  
cs_Le Pivert Messages postés 8437 Statut Contributeur -
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.
    cs_Le Pivert Messages postés 8437 Statut Contributeur 730
     
    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
  2. Jul997 Messages postés 12 Statut Membre
     
    Ok merci beaucoup je vais tester et je reviens te dire!
    0
  3. Jul997 Messages postés 12 Statut Membre
     
    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
  4. Jul997 Messages postés 12 Statut Membre
     
    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 Messages postés 8437 Statut Contributeur 730
       
      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

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. Jul997 Messages postés 12 Statut Membre
     
    il me dit nom ambigue detecte : getboiler
    0
  7. Jul997 Messages postés 12 Statut Membre
     
    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 Messages postés 8437 Statut Contributeur 730
       
      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
  8. Jul997 Messages postés 12 Statut Membre
     
    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 Messages postés 8437 Statut Contributeur 730
       
      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 Messages postés 8437 Statut Contributeur 730
       
      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 Messages postés 8437 Statut Contributeur 730
       
      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
  9. Jul997 Messages postés 12 Statut Membre
     
    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
  10. Jul997 Messages postés 12 Statut Membre
     
    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 Messages postés 8437 Statut Contributeur 730
       
      qu'elle est la ligne surlignée en jaune?
      quand tu passes le curseur sur toute la ligne, qu'indique-t-il?
      0
  11. Jul997 Messages postés 12 Statut Membre
     
    je n'ai malheureusement aucune ligne surlignée en jaune...
    0
    2. cs_Le Pivert Messages postés 8437 Statut Contributeur 730
       
      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