Comment positionner un rectangle a l'endroit du curseur?

Le
Emile63
Bonjour à tous,

Je souhaite insérer un rectangle à l'endroit ou se trouve la
sélection, qui aurair différentes couleurs RGB, en fonction d'un
critère contenu dans la cellule sélectionné.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
séléctionnée entièrement.
Je tourne autour de:

Left=A
Top=B
Width=C
Height=D
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la procédure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
michdenis
Le #21359971
Bonjour

Si l'objectif poursuivi est de créer un rectangle dans la cellule active ???
'---------------------------
with activecell
A = .left
B = .Top
C = .Width
D = .Height
End with
activesheet.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select
'---------------------------



"Emile63"
Bonjour à tous,

Je souhaite insérer un rectangle à l'endroit ou se trouve la
sélection, qui aurair différentes couleurs RGB, en fonction d'un
critère contenu dans la cellule sélectionné.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
séléctionnée entièrement.
Je tourne autour de:

Left=A
Top=B
Width=C
Height=D
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la procédure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
LSteph
Le #21360591
Bonjour,

Si j'ai bien compris.Supposons une plage où l'on met des nombres de n
à 999999
et que l'on promène le curseur dedans http://cjoint.com/?dlpIJox5uW

'''''dans modulestandard
Public myrSel As Range, myShp As Shape

''''''dans le code de la Feuille Feuil1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a#, b#, c#, d#, i#
On Error Resume Next
myShp.Delete
On Error GoTo 0
With ActiveCell
a = .Left
b = .Top
c = .Width
d = .Height
End With
i = ActiveCell Mod 56

Set myShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, a, b, c, d)
myShp.OLEFormat.Object.Interior.ColorIndex = i
myShp.OLEFormat.Object.Text = ActiveCell
Target.Activate

End Sub

'LSteph




On 11 mar, 13:23, Emile63
Bonjour à tous,

Je souhaite insérer un rectangle à l'endroit ou se trouve la
sélection, qui aurair différentes couleurs RGB, en fonction d'un
critère contenu dans la cellule sélectionné.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
séléctionnée entièrement.
Je tourne autour de:

Left=A
Top=B
Width=C
Height=D
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la procédure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
Emile63
Le #21360981
Bonjour Michdenis,

Encore tu viens a mon secours, merci pour ton aide assidue :-))
C'était bien le bout de code manquant.. ;-)
Maintenant j'ai un autre problème (de mémoire)...
Il y a env. 220 Rectangles dans ma feuille.
Quand j'éxécute la macro dans un fichier test, elle fonctionne
correctement.
Par-contre quand je la test sur ma feuille de travail, elle
plantouille un peu avec une: erreur de mémoire 7
Voici le code, et ma question c'est:
- Est-ce qu'il y a un moyen de contourner ce problème (éventl. afiner
mon code...)
'**************************************************
Sub Couleurs()
Dim A, B, C, D, E, G, R, MyDocument
'On Error Resume Next
Application.ScreenUpdating = False
Set MyDocument = ActiveSheet
MyDocument.Shapes.SelectAll ' <_ Ici, j'ai -Erreur 7, Mémoire
insufisante.
Selection.Delete ' Du coup, comme il ne sélectionne pas les
"Shapes",
Range("B5").Select ' il ne les effaces pas non plus.
For I = 5 To 250
With ActiveCell
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height
End With
If Range("C" & I) = Empty Then Exit Sub
R = Mid(Range("C" & I).Value, 1, 3)
G = Mid(Range("C" & I).Value, 5, 3)
B = Mid(Range("C" & I).Value, 9, 3)
MyDocument.Shapes.AddShape(msoShapeRectangle, A, E, C,
D).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = RGB(R, G, B)
End With
ActiveCell.Offset(1, 0).Select
Next I
Application.ScreenUpdating = True
End Sub
'**************************************************

Encore merci pour ton aide,
Cordialement,

Emile
Emile63
Le #21361611
Merci LSteph
Pour ton aide.
C'est pas tout-à-fait ce que le suis en train de boutiquer,
mais ça m'a donné de nouvelles idées... ;-))
michdenis
Le #21361871
'----------------------------------------------
Sub Couleurs()
Dim A As Double, B As Integer, C As Double
Dim D As Double, E As Double, G As Integer, R As Integer
Dim Rg As Range, Cell As Range

Application.ScreenUpdating = False
With ActiveSheet
'Efface toutes les shapes de la feuille
.DrawingObjects.Delete
'Définit la plage de cellules
Set Rg = .Range("A5:A250")
End With

'Une boucle sur chacune des cellules
For Each Cell In Rg
With Cell
If .Value = Empty Then Exit Sub
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height

R = Mid(.Value, 1, 3)
G = Mid(.Value, 5, 3)
B = Mid(.Value, 9, 3)
With .Parent.Shapes.AddShape(msoShapeRectangle, A, E, C, D)
.Fill.ForeColor.RGB = RGB(10, 50, 200)
End With
End With
Next
Application.ScreenUpdating = True
End Sub
'----------------------------------------------




"Emile63"
Bonjour Michdenis,

Encore tu viens a mon secours, merci pour ton aide assidue :-))
C'était bien le bout de code manquant.. ;-)
Maintenant j'ai un autre problème (de mémoire)...
Il y a env. 220 Rectangles dans ma feuille.
Quand j'éxécute la macro dans un fichier test, elle fonctionne
correctement.
Par-contre quand je la test sur ma feuille de travail, elle
plantouille un peu avec une: erreur de mémoire 7
Voici le code, et ma question c'est:
- Est-ce qu'il y a un moyen de contourner ce problème (éventl. afiner
mon code...)
'**************************************************
Sub Couleurs()
Dim A, B, C, D, E, G, R, MyDocument
'On Error Resume Next
Application.ScreenUpdating = False
Set MyDocument = ActiveSheet
MyDocument.Shapes.SelectAll ' <_ Ici, j'ai -Erreur 7, Mémoire
insufisante.
Selection.Delete ' Du coup, comme il ne sélectionne pas les
"Shapes",
Range("B5").Select ' il ne les effaces pas non plus.
For I = 5 To 250
With ActiveCell
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height
End With
If Range("C" & I) = Empty Then Exit Sub
R = Mid(Range("C" & I).Value, 1, 3)
G = Mid(Range("C" & I).Value, 5, 3)
B = Mid(Range("C" & I).Value, 9, 3)
MyDocument.Shapes.AddShape(msoShapeRectangle, A, E, C,
D).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = RGB(R, G, B)
End With
ActiveCell.Offset(1, 0).Select
Next I
Application.ScreenUpdating = True
End Sub
'**************************************************

Encore merci pour ton aide,
Cordialement,

Emile
Emile63
Le #21364031
Bonjour Michdenis,

Une fois encore t'as mis dans le mille. :-)

Mille mercis.
cordialement,
Emile
Publicité
Poster une réponse
Anonyme