Microsoft 365 msgbox avec liste de choix

Usine à gaz · 25 Décembre 2021

Bonjour à toutes et à tous,

Je me tourne une nouvelle fois vers nos ténors

J'ai fait des p'tits tests UF pour faire des choix de nombres ... Pas de souci particulier pour ça
Mais les UF, me semble-t-il, alourdissent les classeurs et les miens sont déjà plutôt lourds et "Usines à gaz" comme disent les Amis lol.

Je me demandais si ce ne serait pas mieux (si c'est possible ?) de faire ce choix à l'aide, par exemple, d'un msgbox avec liste de choix ?
J'ai fait des recherches et pas mal d'essais sans succès.

Si c'est possible, auriez-vous le bon code ?
En cas, je joins une fichier test.
Merci pas avance,
Amicalement,
lionel,

laurent950 · 25 Décembre 2021

Bonsoir @Usine à gaz

' Astuce
' Création d'une comboBox sur la page Excel via une Msgbox
La derrière case de ce tableau : Array(10, 15, 20, 30, 45, 0)
c'est le code des boutons de la la MSGBOX soit : la description ici pour "Msgbox"

Fonction MsgBox (Visual Basic pour Applications)

Référence de langage VBA pour Office

docs.microsoft.com

alors tbl c'est le tableau avec les valeurs que vous avez choisies sauf 0 bien sur
vous avez deviné : tbl(UBound(tbl)) La valeur c'est 0 bien sur pour "OK"
Bon sa sert a rien je pense mais, il faut utilisé Msgbox comme une fonction
qui va renvoyer 0, et donc 0 ne sert à rien dans votre liste...

Usine à gaz · 26 Décembre 2021

Super merci pour tout ce super travail.
merci pour tout le temps que tu y as passé.
lionel

laurent950 · 26 Décembre 2021

Re Lionel,

Pour la Msgbox

Ce que j'ai ajouté :
' Msgbox (Pour la boite de message)
Dim StrString As String
Dim tmp() As Variant
tmp = tbl: ReDim Preserve tmp(UBound(tmp) - 1)
StrString = "Liste de choix" & vbCrLf & Join(tmp, vbCrLf & "")
tbl(UBound(tbl)) = MsgBox(StrString, tbl(UBound(tbl)), "CLIC SUR LA BONNE REPONSE")
' Les valeurs
~~'ReDim Preserve tbl(UBound(tbl) - 1)~~
tbl = tmp: Erase tmp

VB:

Sub MsgBoxListeDeChoix2()
Dim WS As Worksheet
    Set WS = ActiveSheet
Dim tbl() As Variant
    tbl = Array(0, 1, 2, 5, 10, 15, 20, 30, 0)
' Msgbox
Dim StrString As String
Dim tmp() As Variant
    tmp = tbl: ReDim Preserve tmp(UBound(tmp) - 1)
    StrString = "Liste de choix" & vbCrLf & Join(tmp, vbCrLf & "")
    tbl(UBound(tbl)) = MsgBox(StrString, tbl(UBound(tbl)), "CLIC SUR LA BONNE REPONSE")
' Les valeurs
    'ReDim Preserve tbl(UBound(tbl) - 1)
    tbl = tmp: Erase tmp
' La Liste Box
Dim oCombo As OLEObject
Dim L As Single, T As Single, W As Single, H As Single
    L = ActiveCell.Left     'L = 180 '<-- position horizontale
    T = ActiveCell.Top      'T = 80 '<-- position verticale
    W = ActiveCell.Width    'W = 130 '<-- largeur
    H = ActiveCell.Height   'H = 22 '<-- hauteur
' Si la liste existe
    For Each oCombo In WS.OLEObjects
        If oCombo.progID = "Forms.ComboBox.1" Then
            If oCombo.Name = "Combo1" Then
                oCombo.Delete
            End If
        End If
    Next
' Creation de la liste de choix
    Set oCombo = WS.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Left:=L, Top:=T, Width:=W, Height:=H)
With oCombo
    .Name = "Combo1" '<-- nom du Combobox
    .Object.List() = tbl    '<-- exemple de chargement des données
    .Object.TextAlign = 3   ' Aligne le texte a droite
    .Object.DropDown        ' Déroule le menu
End With
Set oCombo = Nothing
End Sub

Usine à gaz · 26 Décembre 2021

Merci encore pour ce travail
j'avais désactivé la Msgbox me permettant ainsi d'être directement sur la liste déroulante et c'est super

Encore un petit truc (le dernier je pense) :

Je joins le fichier et je continue à chercher comment l'enlever.
lionel

laurent950 · 26 Décembre 2021

Usine à gaz à dit:
Je joins le fichier et je continue à chercher comment l'enlever.

C'est qu'elle module dans votre classeur ? pour le code

Usine à gaz · 26 Décembre 2021

C'est dans le module 1:

VB:

Sub MsgBoxListeDeChoix2()
Dim WS As Worksheet
    Set WS = ActiveSheet
Dim tbl() As Variant
    tbl = Array(0, 2, 5, 10, 15, 20, 30, 0)
' Msgbox
    'tbl(UBound(tbl)) = MsgBox("Liste de choix", tbl(UBound(tbl)), "CLIC SUR LA BONNE REPONSE")
' Les valeurs
    ReDim Preserve tbl(UBound(tbl) - 1)
' La Liste Box
Dim oCombo As OLEObject
Dim L As Single, T As Single, W As Single, H As Single
    'L = 180 '<-- position horizontale
    L = ActiveCell.Left
    'T = 80 '<-- position verticale
    T = ActiveCell.Top
    'W = 130 '<-- largeur
    W = ActiveCell.Width
    'H = 22 '<-- hauteur
    H = ActiveCell.Height
' Si la liste existe
    For Each oCombo In WS.OLEObjects
        If oCombo.progID = "Forms.ComboBox.1" Then
            If oCombo.Name = "Combo1" Then
                oCombo.Delete
            End If
        End If
    Next
' Creation de la liste de choix
    Set oCombo = WS.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Left:=L, Top:=T, Width:=W, Height:=H)
With oCombo
    .Name = "Combo1" '<-- nom du Combobox
    .Object.List() = tbl '<-- exemple de chargement des données
    .Object.TextAlign = 3 ' Aligne le texte a droite
    .Object.DropDown ' Déroule le menu
End With
Set oCombo = Nothing
CreateObject("wscript.shell").SendKeys "%{down}"
End Sub

laurent950 · 26 Décembre 2021

Re

Votre modification et faite ou dans votre code ci-dessus ?

j'avais désactivé la Msgbox me permettant ainsi d'être directement sur la liste déroulante et c'est super

Usine à gaz · 26 Décembre 2021

Oui, dans le fichier joint "Module1",

laurent950 · 26 Décembre 2021

Re

Cette ligne sert a quoi ? CreateObject("wscript.shell").SendKeys "%{down}"

ici maintenant
Dim tbl() As Variant
'tbl = Array(0, 2, 5, 10, 15, 20, 30, 0)
tbl = Array(0, 2, 5, 10, 15, 20, 30)
' Msgbox
'tbl(UBound(tbl)) = MsgBox("Liste de choix", tbl(UBound(tbl)), "CLIC SUR LA BONNE REPONSE")
' Les valeurs
~~ReDim Preserve tbl(UBound(tbl) - 1)~~

Usine à gaz · 26 Décembre 2021

"Cette ligne sert a quoi ? CreateObject("wscript.shell").SendKeys "%{down}""
= Ouvrir automatiquement la liste de validation

laurent950 · 26 Décembre 2021

Usine à gaz à dit:
"Cette ligne sert a quoi ? CreateObject("wscript.shell").SendKeys "%{down}""
= Ouvrir automatiquement la liste de validation

elle s'ouvre déjà avec cette ligne avant : .Object.DropDown ' Déroule le menu

Pour votre question en poste #18 c'est l'affichage par default, non modifiable.

VB:

Sub MsgBoxListeDeChoix2()
Dim WS As Worksheet
    Set WS = ActiveSheet
Dim tbl() As Variant
    'tbl = Array(0, 2, 5, 10, 15, 20, 30, 0)
    tbl = Array(0, 2, 5, 10, 15, 20, 30)
' Msgbox
    'tbl(UBound(tbl)) = MsgBox("Liste de choix", tbl(UBound(tbl)), "CLIC SUR LA BONNE REPONSE")
' Les valeurs
    'ReDim Preserve tbl(UBound(tbl) - 1)
' La Liste Box
Dim oCombo As OLEObject
Dim L As Single, T As Single, W As Single, H As Single
     L = ActiveCell.Left      ' L = 180 '<-- position horizontale
    T = ActiveCell.Top       ' T = 80 '<-- position verticale
    W = ActiveCell.Width  ' W = 130 '<-- largeur
    H = ActiveCell.Height  ' H = 22 '<-- hauteur
' Si la liste existe
    For Each oCombo In WS.OLEObjects
        If oCombo.progID = "Forms.ComboBox.1" Then
            If oCombo.Name = "Combo1" Then
                oCombo.Delete
            End If
        End If
    Next
' Creation de la liste de choix
    Set oCombo = WS.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Left:=L, Top:=T, Width:=W, Height:=H)
With oCombo
    .Name = "Combo1" '<-- nom du Combobox
    .Object.List() = tbl '<-- exemple de chargement des données
    .Object.TextAlign = 3 ' Aligne le texte a droite
    .Object.DropDown ' Déroule le menu
End With
Set oCombo = Nothing:   Set WS = Nothing: Erase tbl
L = Empty: T = Empty: W = Empty: H = Empty
End Sub

Usine à gaz · 26 Décembre 2021

Désolé, je ne l'avais pas vu et c'était le fait que j'ai ajouté la ligne qui à provoqué "le truc" intempestif"
Vraiment désolé de t'avoir fait passer plus de temps

C'est parfait, Génial !
Merci pour ce super travail
Voilà un code très utile.
Encore merci à toi
lionel

Usine à gaz · 27 Décembre 2021

Bonjour laurent950, le Forum,
Je vous souhaite à toutes et à tous une belle journée

Merci Laurent pour ta patience et ta ténacité
Je joins le fichier "finalisé" qui fonctionne "du tonnerre" et qui pourra être utile pour d'autres

Je profite de ce fil pour un souci d'intégration dans mon fichier de travail,
code dans la feuille :

Aurais-tu une idée ?
je continue mes tests,
Amicalement,
lionel

Usine à gaz · 28 Décembre 2021

Bonjour Laurent, le Forum,

Après beaucoup de tests, je confirme. Ton code fonctionne super bien
Un grand merci

Je cherche à ajouter une info.
Pas très indispensable mais, même si ça va sans dire, ça va tjrs mieux en le disant lol

Je voudrais ajouter une petit texte dans la combo1 :

"aujourd'hui + nbr jrs"
Est-ce possible ?
Je cherche de mon côté,
lionel

Usine à gaz · 29 Décembre 2021

Bonjour à toutes et à tous, Bonjour laurent950,
Je vous souhaite une belle journée

J'ai encore modifié le fichier test en y incluant un UF pour annuler si erreur de clic.
Comme mon Cher Job75, je suis jusqu'au-boutiste lol
Il ne me reste plus qu'a ajouter une petit texte dans la combo1 :

"aujourd'hui + nbr jrs"

Je joins le fichier à ce stade d'évolution.
Je continue mes recherches,
Amicalement,
lionel,

Eric C · 29 Décembre 2021

Bonjour le forum
Bonjour le fil

@Lionel :
J'ai fait des p'tits tests UF pour faire des choix de nombres ... Mais les UF, me semble-t-il, alourdissent les classeurs et les miens sont déjà plutôt lourds et "Usines à gaz" comme disent les Amis lol.

Eh ben Lionel, après avoir parcouru ce fil, on peut observer que cette fois ci, tu vas faire light en utilisant seulement :
- du code (bien sûr)
- du contrôle ActiveX
- un UserForm (Euh.. tu ne disais pas que ....je ne sais plus ???)
- une Macro Excel4
- l'exécution d'une commande externe avec écriture dans la base de registre ....

Je ne veux pas être ton programme lorsque tu vas lui sortir l'artillerie lourde

Bon Ok, je sors
Bonne après-midi à toutes & à tous
@+ Eric c

Microsoft 365 msgbox avec liste de choix

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Discussions similaires