creation de commandButton deplacable dans 4 directions

Version imprimable

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:

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:

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?

18/01/2025, 11h57
Franc

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.

1 pièce(s) jointe(s)

Bonjour,

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

Code:

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.

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:

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:

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

25/01/2025, 19h16
Mod77
Merci Eric Dgn,
Je regarde ton code et vois cette ligne qui m'interesse:
Code:

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:

.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?
25/01/2025, 22h39
EricDgn
Bonsoir

Dans cette partie du code
Code:

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:

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.

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

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

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.

26/01/2025, 12h08
EricDgn

Bonjour,

Pour ce qui est de la partie NewButton, il faudrait avoir encodé en tête de module l'instruction Option Explicit et ensuite lancer un débogage (ruban / Débogage / Compiler VBAProject) pour voir sur quelle instruction le problème se produit. Dans ce que vous avez montré du code, je ne vois pas comment sont calculés ou initialisés nextButtonNumber et relativeTop.

Pour ce qui est des info-bulles, il n'y a que sur les formulaires que c'est géré et je n'ai pas compris ce que vous voulez finalement faire. Le plus simple pour expliquer cela serait sans doute de joindre un fichier Excel montrant un exemple de situation initiale et un exemple de résultat final attendu.

Cordialement.
26/01/2025, 20h15
Mod77

1 pièce(s) jointe(s)

EricDgn,

Merci. J'ai changé de procédure du coup et j'ai créé un formulaire pour pouvoir profiter des infobulles. Mais je galère encore plus :-(
cette marche arrière me ramène quasiment au début de mon projet, avec un problème de mon formulaire de création / déplacement des boutons de commande qui ne veut pas apparaitre sur un autre formulaire qui sert de support à l'image sur laquelle je veux que soit posé les boutons de commande créés.:cry:
Du coup je vais poser mes boutons de direction (pad) sur le formulaire d 'affichage de l'image et chercherais un moyen de les cacher ou les inhiber lorsque j'appellerai ce formulaire pour exploiter et non plus créer. voila le programme A+ et merciPièce jointe 663894
27/01/2025, 00h18
EricDgn

Heu, et à quoi tout cela va-t-il servir? Quel est l'objectif final? Trouver une position? Indiquer une position? Faire un inventaire?
Coridalement.
27/01/2025, 08h49
Mod77

Ca sert a la gestion de matériels sur plan.
D'ailleurs j'ai réflechi encore cette nuit et je pense qu'il faut que les boutons de commande soient sur une feuille finalement car sinon je ne pourrais pas les enregistrer et les reutiliser s'ils sont sur un formulaire. Confirmez-vous ?
27/01/2025, 14h13
EricDgn

Oui, c'est sans doute préférable.
Cordialement.

Bonsoir,

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

Code:

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

.OnAction doit contenir le texte repésentant la procédure, pas directement son nom

du type

Code:

.OnAction = "ShowUFetat"

avec des guillemets

03/02/2025, 05h08
Mod77

Bonjour tototiti2008,
Bien vu
merci