Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Excel et les objets

Excel et les objets

5 réponses
Avatar
Jero
Bonjour aux excellentes et excellents,

Voici mon pb.

dans une feuille, lorsque je clique sur une cellule, j'insère un cercle
(c'est pour entourer une réponse) ; ça c'est ok.
je que je veux faire : supprimer un cercle si je clique dessus.
j'ai beau chercher (avec Shape, ShapeRange ou DrawingObjects) => rien de
bien convainquant (apparemment l'événement On_click n'existe pas pour une
feuille)... et je n'ai trouvé aucune aide sur la collection DrawingObjects
qui puisse m'aider réellement.
évidemment, en ajoutant un bouton de commande, c'est possible mais ça fait
pas très propre...

Donc, si vous avez une idée, elle serait la bien venue.

D'avance merci,
Jero
Signaler un problème avec ce contenu

5 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
michdenis
Bonjour Jean-Pierre,

Tu veux bien donner quelques indications sur la manière dont
tu insères tes cercle autour des valeurs dans les cellules.


Salutations!


"Jero" <~ a écrit dans le message de news: %
Bonjour aux excellentes et excellents,

Voici mon pb.

dans une feuille, lorsque je clique sur une cellule, j'insère un cercle
(c'est pour entourer une réponse) ; ça c'est ok.
je que je veux faire : supprimer un cercle si je clique dessus.
j'ai beau chercher (avec Shape, ShapeRange ou DrawingObjects) => rien de
bien convainquant (apparemment l'événement On_click n'existe pas pour une
feuille)... et je n'ai trouvé aucune aide sur la collection DrawingObjects
qui puisse m'aider réellement.
évidemment, en ajoutant un bouton de commande, c'est possible mais ça fait
pas très propre...

Donc, si vous avez une idée, elle serait la bien venue.

D'avance merci,
Jero
Avatar
Jero
Bonjour,

En réponse à Mich...

Objectif :


J'ai cloné (ou du moins essayé) un système papier « auto-scorable ». Je sais
que je peux faire autrement qu'avec un cercle (couleur fond de la cellule
par exemple) mais c'était pour « faire pareil » que la version papier.



Sur la feuille « Réponses », les personnes ont à répondre (c'est un test de
personnalité, mais c'est bien sûr adaptable...) à un certain nombre de
questions en « entourant » une des 5 possibilités (A, B, C,.) proposées.

En fonction de la question posée, chaque réponse à un poids différent (A, B,
etc. varient de 0 à 4) et ces résultats sont cumulés sur une feuille «
Résultats » (qui est un peu une feuille « carbone » que la personne ne voit
pas).



Je détermine les coordonnées du cercle en fonction de l'adresse de la
cellule cliquée (d'où un certain nombre de constantes ; on peut faire mieux
avec plus de paramètres.).




Voici le bout de code relatif à la création d'un cercle entourant une
réponse :



Option Explicit

Dim Col As Byte, Lg As Byte, Rg As String

Dim NumQuestion As Byte

Const LgCol As Single = 14.25

Const Decalage As Single = 6.5 'pour une colonne de largeur=1

Const LargColSauter As Byte = 3 'les colonnes non "utiles" font 3 de large

Const LigneDebut As Byte = 5





Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim DecalGauche As Single, NbColPhrase As Byte, tmpCol As String

Dim NomOvalFeuilleReponses As String, NomOvalFeuilleResultats As String

Dim AdresseQuestion As String

Dim OvalExiste As Boolean

'Exit Sub

'Stop

If Application.Intersect(Range("Datas"), Range(ActiveCell.Address)) Is
Nothing Then

Exit Sub

End If

Application.ScreenUpdating = False

OvalExiste = True

Col = ActiveCell.Column: Lg = ActiveCell.Row

If Col <= 26 Then

tmpCol = Chr(Col + 64)

Rg = tmpCol & Trim(Str(Lg))

Else

tmpCol = Chr(Int(Col / 26) + 64) & Chr(Col Mod 26 + 64)

Rg = tmpCol & Trim(Str(Lg))

End If

NomOvalFeuilleReponses = "Oval" & "_" & tmpCol & "_" & Trim(Str(Lg))

NomOvalFeuilleResultats = NomOvalFeuilleReponses & "Resultats"

NbColPhrase = Int((Col - 1) / 6) + 1 'Nb. colonnes non "utiles" => n° de
phrase

DecalGauche = Decalage * LargColSauter * NbColPhrase + (Col - 1 -
NbColPhrase) * LgCol

NumQuestion = Lg - (LigneDebut - 1) + (NbColPhrase - 1) * 30

AdresseQuestion = "NQ" & Trim(Str(NumQuestion))

'Stop

On Error GoTo NExistePas

ActiveSheet.Shapes(NomOvalFeuilleReponses).Select

If Not OvalExiste Then

AjouterOval Lg, Rg, NbColPhrase, DecalGauche, NomOvalFeuilleReponses,
NomOvalFeuilleResultats

NbOval(NumQuestion) = NbOval(NumQuestion) + 1

Worksheets("FeuilleReponses").Activate

MiseEnFormeNumQuestion NumQuestion, AdresseQuestion

Else

End If

Worksheets("FeuilleResultats").Activate

ActiveSheet.UsedRange.Range("SommesNEOAC").Calculate

Worksheets("FeuilleReponses").Activate

''Calculate

Application.ScreenUpdating = True

Exit Sub



NExistePas:

OvalExiste = False

On Error GoTo 0

Resume Next

End Sub



Sub AjouterOval(Ligne, Rang, NbColPhr, DecalGche, NomOvalFeuilRep,
NomOvalFeuilCarb)

'Dans la feuille "FeuilleReponses"

ActiveSheet.Shapes.AddShape(msoShapeOval, DecalGche, LgCol * (Ligne -
1), LgCol, LgCol).Select

Selection.ShapeRange.Fill.Transparency = 1

Selection.ShapeRange.Name = NomOvalFeuilRep

'Dans la feuille "FeuilleResultats"

Worksheets("FeuilleResultats").Activate

ActiveSheet.Shapes.AddShape(msoShapeOval, DecalGche, LgCol * (Ligne -
1), LgCol, LgCol).Select

Selection.ShapeRange.Fill.Transparency = 1

Selection.ShapeRange.Name = NomOvalFeuilCarb

ActiveSheet.Range(Rang).Font.ColorIndex = 5

ActiveSheet.Range(Rang).Font.Bold = True

End Sub



Je peux envoyer le classeur à qui le désire.



A+ et merci d'avance...

Jero


"michdenis" a écrit dans le message de news:

Bonjour Jean-Pierre,

Tu veux bien donner quelques indications sur la manière dont
tu insères tes cercle autour des valeurs dans les cellules.


Salutations!


"Jero" <~ a écrit dans le message de
news: %
Bonjour aux excellentes et excellents,

Voici mon pb.

dans une feuille, lorsque je clique sur une cellule, j'insère un cercle
(c'est pour entourer une réponse) ; ça c'est ok.
je que je veux faire : supprimer un cercle si je clique dessus.
j'ai beau chercher (avec Shape, ShapeRange ou DrawingObjects) => rien de
bien convainquant (apparemment l'événement On_click n'existe pas pour une
feuille)... et je n'ai trouvé aucune aide sur la collection DrawingObjects
qui puisse m'aider réellement.
évidemment, en ajoutant un bouton de commande, c'est possible mais ça fait
pas très propre...

Donc, si vous avez une idée, elle serait la bien venue.

D'avance merci,
Jero





Avatar
Alain CROS
Bonjour,

Un petit exemple de création destruction de shapes ovales limité à la plage B2:E5.

Dans le module de la feuille :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LeLeft$, LeTop$
If Intersect(Target, [B2:E5]) Is Nothing Then Exit Sub
With Target
LeLeft = CStr(.Left)
LeTop = CStr(.Top)
.Parent.Shapes.AddShape msoShapeOval, .Left, .Top, .Width, .Height
End With
With Shapes(Shapes.Count)
.Fill.Transparency = 1
.Name = LeLeft & LeTop
.OnAction = .Parent.CodeName & ".ShDelete"
End With
End Sub

Sub ShDelete()
Shapes(Application.Caller).Delete
End Sub

Alain CROS

"Jero" <~ a écrit dans le message de news:
| Bonjour,
|
| En réponse à Mich...
|
| Objectif :
|
Avatar
Jero
Merci, je vais tester...
Jero
"Alain CROS" a écrit dans le message de news:

Bonjour,

Un petit exemple de création destruction de shapes ovales limité à la
plage B2:E5.

Dans le module de la feuille :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LeLeft$, LeTop$
If Intersect(Target, [B2:E5]) Is Nothing Then Exit Sub
With Target
LeLeft = CStr(.Left)
LeTop = CStr(.Top)
.Parent.Shapes.AddShape msoShapeOval, .Left, .Top, .Width, .Height
End With
With Shapes(Shapes.Count)
.Fill.Transparency = 1
.Name = LeLeft & LeTop
.OnAction = .Parent.CodeName & ".ShDelete"
End With
End Sub

Sub ShDelete()
Shapes(Application.Caller).Delete
End Sub

Alain CROS

"Jero" <~ a écrit dans le message de
news:
| Bonjour,
|
| En réponse à Mich...
|
| Objectif :
|




Avatar
Jero
Merci, ça "roule"
Jero
"Alain CROS" a écrit dans le message de news:

Bonjour,

Un petit exemple de création destruction de shapes ovales limité à la
plage B2:E5.

Dans le module de la feuille :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LeLeft$, LeTop$
If Intersect(Target, [B2:E5]) Is Nothing Then Exit Sub
With Target
LeLeft = CStr(.Left)
LeTop = CStr(.Top)
.Parent.Shapes.AddShape msoShapeOval, .Left, .Top, .Width, .Height
End With
With Shapes(Shapes.Count)
.Fill.Transparency = 1
.Name = LeLeft & LeTop
.OnAction = .Parent.CodeName & ".ShDelete"
End With
End Sub

Sub ShDelete()
Shapes(Application.Caller).Delete
End Sub

Alain CROS

"Jero" <~ a écrit dans le message de
news:
| Bonjour,
|
| En réponse à Mich...
|
| Objectif :
|