creation de commandButton deplacable dans 4 directions

**Mod77** · 18/01/2025, 09h37

Bonjour,
Je crée un commandButton via un formulaire UF_pad mais je n'arrive pas à le déplacer sur la feuille. Il ne reste pas sélectionné.

voici mon code vba:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub TB_creval_Click()
    Set ws = ThisWorkbook.Sheets("BAES")
 
    If TB_creval.Value Then
        buttonCount = buttonCount + 1
 
        ' Créer un nouveau bouton
        Set newShape = ws.Shapes.AddOLEObject(ClassType:="Forms.CommandButton.1", _
                                Left:=Application.Width / 2 - 50, Top:=Application.Height / 2 - 15, _
                                Width:=100, Height:=30)
        Set newButton = newShape.OLEFormat.Object.Object
        newShape.Name = "CB_baes" & buttonCount
        newButton.Caption = "baes " & buttonCount
    Else
        ValidateAndOpenForm
    End If
End Sub
 
 
Private Sub ValidateAndOpenForm()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BAES")
 
    ' Vérifiez que newShape est bien défini
    If Not newShape Is Nothing Then
        ' Remplir le tableau
        Dim lastRow As Long
        lastRow = ws.Cells(ws.Rows.Count, "O").End(xlUp).Row + 1
        ws.Cells(lastRow, "O").Value = buttonCount
 
        ' Passer la valeur lastRow à UF_id et ouvrir le formulaire d'identité sans fermer UF_pad
        UF_id.RowNum = lastRow
        UF_id.Show vbModeless
    End If
End Sub

TB_creval: crée un commandButton lorsqu'il est enfoncé et lorsqu'il est relevé il valide la création (il devrait fixer le commandButton) puis ouvre le formulaire d'identite UF_id.

Sur mon formulaire j'ai 4 commandButton de direction cardinale. Lorsque je clique sur celui de droite il devrait déplacer le commandButton vers la droite mais rien ne se passe.
voici mon code placé au même endroit que le 1er (page du code formulaire UF_pad):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Private Sub CB_droite_Click()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BAES")
 
    If Not newShape Is Nothing Then
        With ws.Shapes(newShape.Name)
            .Left = .Left + 10
        End With
    End If
End Sub

Je ne sais pas comment m'y pendre.

Quelqu'un peut-il m'aider svp?

**Franc** · 18/01/2025, 11h57

Bonjour, je relève 2 erreurs potentielles mais sans voir ton code complet je n'en suis pas certain.
Je lis Set ws = ThisWorkbook.Sheets("BAES") mais ne vois pas le DIM correspondant.
Idem pour newShape, qui lui devrait être déclaré Global puisque utilisé dans les 2 macros.

**EricDgn** · 18/01/2025, 14h48

Bonjour,

Un petit exemple qui devrait vous donner quelques idées.
Le code, pour ceux qui n'aiment pas ouvrir des fichier xlsm.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Option Explicit
 
Dim ws As Worksheet
Dim btn As Button
Dim Continuer As Boolean
Dim NextCell As Range
 
Private Sub btnEst_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MoveBtn 0, 1
End Sub
 
Private Sub btnEst_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Continuer = False
End Sub
 
Private Sub btnNord_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MoveBtn -1, 0
End Sub
 
Private Sub btnNord_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Continuer = False
End Sub
 
Private Sub btnOuest_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MoveBtn 0, -1
End Sub
 
Private Sub btnOuest_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Continuer = False
End Sub
 
Private Sub btnSud_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MoveBtn 1, 0
End Sub
 
Private Sub btnSud_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Continuer = False
End Sub
 
Private Sub btnNouveau_Click()
    Dim n As Integer
    Set ws = ActiveSheet
    Set btn = ws.Buttons.Add(Application.Width / 2 - 50, Application.Height / 2 - 15, 100, 30)
    n = ws.Shapes.Count
    With btn
        .Name = "CB_baes" & n
        .Caption = "baes " & n
        .OnAction = "BtnBaes" & n
    End With
    btn.Select
End Sub
 
Private Function BoutonActif() As String
    Dim shp As Shape
    If Selection Is Nothing Then
        BoutonActif = ""
    Else
        If TypeName(Selection) = "Shape" Then   '--- vérifie si l'objet sélectionné est une forme
            If shp.Type = msoFormControl Then   '--- vérifie si la forme est un bouton
                If shp.FormControlType = xlButtonControl Then
                    BoutonActif = shp.Name
                End If
            Else
                BoutonActif = ""
            End If
        ElseIf TypeName(Selection) = "Button" Then
            BoutonActif = Selection.Name
        Else
            BoutonActif = ""
        End If
    End If
End Function
 
Private Sub MoveBtn(dX As Integer, dY As Integer)
    '--- tant que l'on appuie sur le bouton du PAD, le bouton de la feuille est déplacé dans le sens sélectionné
    Set ws = ActiveSheet
    If BoutonActif <> "" Then
        Continuer = True
        Set btn = Selection
        Debug.Print "btn: " & btn.Name
        Do While Continuer
            With btn
                Set NextCell = ws.Cells(.topLeftCell.Row + dX, .topLeftCell.Column + dY) '--- cellule suivante
                .Top = NextCell.Top
                .Left = NextCell.Left
            End With
            Application.Wait Now + TimeValue("00:00:01") '--- attend 1 seconde
            DoEvents  '--- pour permettre à l'événement MouseUp d'être capté (sinon boucle indéfiniment)
        Loop
    End If
End Sub

Cordialement.

**Mod77** · 25/01/2025, 18h58

Bonsoir, Et merci de votre aide.
Je vais étudier cela bien que j'ai trouvé une solution dans l'heure qui a suivie le poste.
je l'ajoute ici aussi:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Private Sub CB_Up_Click()
    Dim moveStep As Long
    ' Vérifier l'état de la case à cocher
    If CC_vite.Value = True Then
        moveStep = 60 ' Déplacement rapide
    Else
        moveStep = 9 ' Déplacement normal
    End If
 
    MoveSelectedButton 0, -10 - moveStep
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Private Sub TB_creval_Click()
    ' Mettre à jour l'état des boutons déplaçables
    ButtonsMovable = TB_creval.Value
 
    ' Vérifier si le ToggleButton est désenclenché
    If Not TB_creval.Value Then
        ' Afficher le formulaire UF_id
        UF_id.Show
    End If
 
    ' Créer un nouveau bouton de commande uniquement lorsque le ToggleButton est enfoncé
    If ButtonsMovable Then
        ' Créer un nouveau bouton de commande sur la feuille BAES
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets("BAES")
 
        ' Vérifier si la feuille est correctement définie
        If ws Is Nothing Then
            MsgBox "La feuille BAES n'a pas été trouvée.", vbCritical
            Exit Sub
        End If
 
        ' Déterminer le niveau actuel
        Dim niv As String
        niv = RenvoiNiveauLu()
 
        ' Déterminer le numéro suivant pour le bouton de commande
        Dim nextButtonNumber As Long
        nextButtonNumber = GetNextButtonNumber()
 
        ' Créer le nouveau bouton de commande
        Dim NewButton As OLEObject
        Set NewButton = ws.OLEObjects.Add(ClassType:="Forms.CommandButton.1")
        If NewButton Is Nothing Then
            MsgBox "Le bouton de commande n'a pas pu être créé.", vbCritical
            Exit Sub
        End If
 
        ' Obtenir le numéro de la première ligne visible pour placer le nouveau bouton de commande
        Dim firstRowVisible As Long
        firstRowVisible = ActiveWindow.ScrollRow    'remplacable par RenvoiNiveauLu()
 
        ' Calculer la position relative du nouveau bouton en fonction de la première ligne visible
        Dim relativeTop As Single
        relativeTop = ws.Rows(firstRowVisible).Top + 5 ' Ajuster la marge supérieure si nécessaire
 
        ' Configurer le CB
        With NewButton
            .Name = "CB_baes" & niv & "_" & nextButtonNumber ' Utiliser une combinaison du niveau et du numéro de bouton pour le nom
            .Object.Caption = nextButtonNumber
            .Left = 100
            .Top = relativeTop ' Utiliser la position relative calculée
            .Width = 11 ' Ajustement de la largeur pour mieux voir le caption
            .Height = 8 ' Ajustement de la hauteur pour mieux voir le caption
            .Object.BackColor = RGB(0, 255, 0) ' Vert
        End With
 
        ' Ajouter le bouton à la collection
        On Error Resume Next
        CreatedButtons.Add NewButton, NewButton.Name
        If Err.Number <> 0 Then
            MsgBox "Erreur lors de l'ajout du bouton à la collection : " & Err.Description, vbCritical
            Err.Clear
        End If
        On Error GoTo 0
 
        ' Mettre à jour le tableau avec les informations du bouton créé et le niveau
        lgCourante = FindLgCourante
        ws.Cells(lgCourante, "S").Value = niv
        ws.Cells(lgCourante, "U").Value = nextButtonNumber ' Mettre à jour les colonnes S et U avec le niveau et le numéro de bouton
 
        ' Mettre à jour l'affichage du niveau dans le formulaire
        UF_pad.TB_niveau.Value = RenvoiNiveauLu()
    End If
End Sub

**Mod77** · 25/01/2025, 19h16

Merci Eric Dgn,
Je regarde ton code et vois cette ligne qui m'interesse:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
    With btn
        .Name = "CB_baes" & n
        .Caption = "baes " & n
        .OnAction = "BtnBaes" & n
    End With

Je souhaite profiter de la création d'un bouton pour lui affecter un code qui affichera un formulaire UF_etat lors d'un clic.
Je pensais naïvement, car je ne m'y connais pas vraiment en vba, écrire:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.OnAction = UF_etat.Show

mais ce n'est pas possible de compil : incompatibilité de type.

Que dois-je faire svp?

De plus, pour quelle raison il y a mouseUp et mousedown pour chaque direction mais sans la notion de clic ?

et une autre question: comment faire une info bulle pour chaque bouton au passage de la souris pour indique son caption svp?

**EricDgn** · 25/01/2025, 22h39

Bonsoir

Dans cette partie du code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
    With btn
        .Name = "CB_baes" & n
        .Caption = "baes " & n
        .OnAction = "BtnBaes" & n
    End With

si n = 1, alors .OnAction = "BtnBaes1" et il faut qu'il y ait dans un module une routine nommée BtnBaes1, par exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub BtnBaes1()
    UF_etat.Show
End Sub

Pour ce qui est de MouseUp et MouseDown, ce sont des événements qui correspondent à appuyer (Down) et relâcher (Up) le bouton de la souris. Lien

Pour ce qui est d'une info-bulle je pense que ce n'est pas possible sur un bouton placé sur une feuille et que c'est uniquement possible sur un bouton placé sur un formulaire.

Cordialement.

**Mod77** · 26/01/2025, 06h59

Merci. mais j'ai mis dans le module1 standard ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub ShowUFetat()
    UF_etat.Show
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
        With NewButton
            .Name = "CB_baes" & niv & "_" & nextButtonNumber ' Utiliser une combinaison du niveau et du numéro de bouton pour le nom
            .Object.Caption = nextButtonNumber
            .Left = 100
            .Top = relativeTop ' Utiliser la position relative calculée
            .Width = 11 ' Ajustement de la largeur pour mieux voir le caption
            .Height = 8 ' Ajustement de la hauteur pour mieux voir le caption
            .Object.BackColor = RGB(0, 255, 0) ' Vert
            .OnAction = ShowUFetat
        End With

mais cela crée une erreur fonction ou variable attendue je ne comprends pas pourquoi?

De plus, si je change ma façon de faire (car j'ai besoin de l'info bulle pour les boutons créés) pourrais-je toujours déplacer les boutons créés sur le formulaire garce à UF_pad et comme ils sont associés et posés sur une image, pourrais-je les sauvegarder sur l'image puis charger une autre image pour y placer d'autres boutons de commande ? car s'est fondamental dans mon projet.

**tototiti2008** · 03/02/2025, 00h38

Bonsoir,

Ce qui est sûr c'est que dans ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
        With NewButton
            .Name = "CB_baes" & niv & "_" & nextButtonNumber ' Utiliser une combinaison du niveau et du numéro de bouton pour le nom
            .Object.Caption = nextButtonNumber
            .Left = 100
            .Top = relativeTop ' Utiliser la position relative calculée
            .Width = 11 ' Ajustement de la largeur pour mieux voir le caption
            .Height = 8 ' Ajustement de la hauteur pour mieux voir le caption
            .Object.BackColor = RGB(0, 255, 0) ' Vert
            .OnAction = ShowUFetat
        End With