VBA : Ellipse (et plus si affinité...)
Bonjour,
Comme à mon habitude je vous propose un remue méninge peu ordinaire, qui tombe à point pour occuper un dimanche morose…
On dispose d’un tableau de 798 points dont les coordonnées X, Y correspondant au centre des 798 cellules dans lesquelles s’inscrit une Shape (Ellipse)
La question est comment compléter ce tableau avec en troisième colonne une valeur Vrai si le point est dans l’Ellipse Faux ou vide dans le cas contraire.
Nota : Pour des raisons d’ergonomie le fichier joint mémorise votre Config Excel (en dur dans la feuille Prm) et la restitue à la sortie.
Cependant vous devez travailler en mode exclusif car je n’ai pas prévu de balade entre plusieurs classeurs. Donc si vous avez d’autres classeurs ouverts il est préférable de les fermer avant d’ouvrir l’appli.
Bon après-midi.
A+
Petite précision : Le tableau c'est TData : il est dans la feuille WsP ("Prm")
Je l'ai complété avec la méthode expérimentale et..; "la veuve poignet" mais j'aimerai quelque chose de plus fiable.
Bonjour,
en supposant un shape de taille 1 de forme cercle (petit cercle) , que l'on déplace à chaque coordonnée du tableau, il suffit alors de faire les trois tests afin de savoir s'il se trouve sur l'ellipse (le grand cercle).
Pour vous, trouver sur le net :
Sub dans()
Set grandcercle = ActiveSheet.Shapes("Oval 6")
Set petitcercle = ActiveSheet.Shapes("Oval 7")
xgc = grandcercle.Left + grandcercle.Width / 2
ygc = grandcercle.Top + grandcercle.Height / 2
xpc = petitcercle.Left + petitcercle.Width / 2
ypc = petitcercle.Top + petitcercle.Height / 2
Oo = Sqr(Abs(ygc - ypc) ^ 2 + Abs(xpc - xgc) ^ 2)
critere = Oo + petitcercle.Height / 2 < grandcercle.Width / 2
MsgBox (critere)
End Sub
Sub hors()
Set grandcercle = ActiveSheet.Shapes("Oval 6")
Set petitcercle = ActiveSheet.Shapes("Oval 7")
xgc = grandcercle.Left + grandcercle.Width / 2
ygc = grandcercle.Top + grandcercle.Height / 2
xpc = petitcercle.Left + petitcercle.Width / 2
ypc = petitcercle.Top + petitcercle.Height / 2
Oo = Sqr(Abs(ygc - ypc) ^ 2 + Abs(xpc - xgc) ^ 2)
critere = Oo - petitcercle.Height / 2 > grandcercle.Width / 2
MsgBox (critere)
End Sub
Sub coupe()
Set grandcercle = ActiveSheet.Shapes("Oval 6")
Set petitcercle = ActiveSheet.Shapes("Oval 7")
xgc = grandcercle.Left + grandcercle.Width / 2
ygc = grandcercle.Top + grandcercle.Height / 2
xpc = petitcercle.Left + petitcercle.Width / 2
ypc = petitcercle.Top + petitcercle.Height / 2
Oo = Sqr(Abs(ygc - ypc) ^ 2 + Abs(xpc - xgc) ^ 2)
critere = Oo + petitcercle.Height / 2 > grandcercle.Width / 2 And Oo - petitcercle.Height / 2 < grandcercle.Width / 2
MsgBox (critere)
End SubLe fichier dont sont tirés ces codes :
@ bientôt
LouReeD
bonjour Galopin01,LouReeD,
l'ellipse est en bleu, tout ce qui est dehors est rouge et à l'interieur = vert
Macro "Galopin"
Bonsoir,
en retravaillant les codes fournis précédemment :
Sub RempliTab()
Dim Gc As Shape, xGc As Double, yGc As Double, xPc As Double, yPc As Double
Application.ScreenUpdating = False
Sheets("Jeu").Activate
Set Gc = ActiveSheet.Shapes("PJeu")
xGc = Gc.Left + Gc.Width / 2
yGc = Gc.Top + Gc.Height / 2
For i = 2 To 799
xPc = Sheets("Prm").Range("AQ" & i) + 0.01
yPc = Sheets("Prm").Range("AR" & i) + 0.01
Oo = Sqr(Abs(yGc - yPc) ^ 2 + Abs(xPc - xGc) ^ 2)
If Oo + 0.01 < Gc.Width / 2 Then ' dedans
Sheets("Prm").Range("AS" & i) = True
ElseIf Oo - 0.01 > Gc.Width / 2 Then ' en dehors
Sheets("Prm").Range("AS" & i) = False
ElseIf Oo + 0.01 > Gc.Width / 2 And Oo - 0.01 < Gc.Width / 2 Then ' coupe
Sheets("Prm").Range("AS" & i) = True
End If
Next i
Sheets("Prm").Activate
End SubJe boucle sur les valeurs du tableau, je fais les trois tests, disons plutôt la série des trois mais cela s'arrête à la première condition vrai trouvée.
Si dedans = True, si dehors = False, et si en "coupe" sur le trait du shape = True.
J'ai pris la colonne AQ comme étant celle des "Left" et AR pour les "Top", si c'est l'inverse il suffit d'inverser...
J'ai simulé un point de 0.01 de large, mais l'on peut aller en dessous je crois vu la précision de la position d'un shape au niveau de ses coordonnées...
@ bientôt
LouReeD
LouReed : Le premier exemple ne respecte pas du tout les condition, donc je n'ai pas été plus loin. Ce qui ne veut pas dire que je ne regarderai pas ta seconde réponse.
BsAlv : Ta réponse m'a permis de me rendre compte que mon approche était insuffisante : En effet en première analyse je me suis basé sur la disposition des cellules pour identifier des points clefs et savoir s'ils rentraient dans l'ellipse.
J'ai tendance à un peu douter de tes résultat car visuellement tes résultats donnent une ellipse dissymétrique.(peu vraisemblable sur la dernière ligne si on regarde les points, ce qui se confirme dans la feuille Prm sur le tableau de VRAI/FAUX .
Mais ce n'ai pas grave, ne cherche pas plus loin. Ces observations m'ont permis de me rendre compte que mon approche est bien trop superficielle : En réalité mon projet est de peupler l'Ovale avec des hexagones contigus ce qui va augmenter considérablement les points clefs. En fait à chaque lignes les poins "centre" à examiner doivent être décalés environ d'1/4 en hauteur et 1/4 en hauteur si on veut juxtaposer correctement les hexagones. Il faut que le me repenche exactement sur la géométrie de l'hexagone pour confirmer, mébon...
Ça promet bien du plaisir quand il va s'agir de peupler mon ovale avec plusieurs centaine d'hexagones...
Je met le sujet en résolu pour l'instant : Il faut d'abord que je modifie mon approche des points à analyser pour que mon "carrelage" puisse se positionner correctement.
A+
Trouvez les coordonnées des sommets de l'hexagone et testez les avec le deuxième code et vous saurez si ce sommet est sur l'ellipse ou pas, non ?
@ bientôt
LouReeD
bonjour Galopin01, salut LouReeD,
l'astuce est de préparer quelques formes de base dans un coin perdu avec déjà toutes les propriétés nécessaires mais avec des dimensions microscopiques. La seule chose à faire, c'est dupliquer ces formes, déplacer vers les coordinates voulus et puis agrandir "du centre", càd le centre de la forme reste le même mais la forme agrandit vers toutes les directions. Comme çà, on n'a pas ce décalage que vous avez décrit ci-dessus.
Pour le moment, je ne comprends pas pourquoi on a encore un tout petit espace "vertical" entre les hexagones
PS. comme excel ne sait pas ajouter une forme qui se trouve pas complètement dans l'écran, par exemple ajouter un cercle avec centre {0;0) et radius 200 sera "normallement" visible pour 1/4. Donc, c'est peut-être mieux de déplacer votre ellipse un tout petit peu (100 points ?) vers la droite et vers le bas.
Bonjour,
Si je vous ai bien compris... Pour éviter ce problème je compte utiliser ces points pour centre de mes hexagones. Ainsi pas de risque de dépassement des limites de l'écran.
Bon mais ça pour l'instant c'est très théorique... Ma réflexion pour l'instant se portent sur le fait qu' Excel ne sait pas dessiner un hexagone dans un cercle. Si c'était le cas, pour un cercle de rayon 1 il suffirai de décaler chaque ligne de points de 0,87 (racine(3)/2 et chaque colonne de 0,5 et l'affaire serait faite.
C'est probablement du aux particularités de l'affichage vertical sous Windows (Je ne me souvient pas avoir eu ce genre de décalage sous MAC) il faut donc trouver un truc pour dissimuler l'écart vertical entre la hauteur du cercle circonscrit et celle de l'hexagone qui sort du cercle en haut et en bas pour un cercle de rayon 1.
Je pense avoir trouver un truc en diminuant le contraste de mes bordures avec le fond de l'ovale avec des hexagone bleu à bordures blanches de 2pt ça doit être jouable...
Il faut encore que je décante tout ça. Simultanément, je réfléchi également à la possibilité de gérer un grand nombre d'hexagones à la manière d'un démineur...
Juste ce qu'il faut pour entretenir mes méninges...
A+
re,
je ne sais pas non plus pourquoi, mais apparament le Y = 0,80 au lieu de 0.866 de l'X
Sub Galopin2()
X = 300 'centre X
Y = 300 'Centre Y
Multipl = 50000 'multiplier avec ...
With Sheets("blad1") 'une autre feuille
For Each shp In .Shapes 'supprimer toutes les formes
shp.Delete
Next
With .Shapes.AddShape(msoShapeOval, X, Y, 0.01, 0.01) 'Cercle
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.LockAspectRatio = msoTrue 'verrouiller rapport largeur/hauteur
.ScaleWidth Multipl, msoFalse, msoScaleFromMiddle
End With
With .Shapes.AddShape(msoShapeHexagon, X, Y, 0.01, 0.01) 'hexagone
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.ScaleWidth Multipl, msoFalse, msoScaleFromMiddle
.ScaleHeight Multipl * 0.8, msoFalse, msoScaleFromMiddle 'ne me demandez pas pourquoi c'est 0.80 !!!!
End With
End With
End Subre,
le fichier avec un rectangle en plus, bizarre ...
feuille "Blad1" et macro "Galopin2"
Hum... On ne parle pas de la même chose !
Personnellement j'utilise 0.9 !
.ScaleHeight multipl * 0.9, msoFalse, msoScaleFromMiddleCe qui me donne après rotation quelque chose d'un peu plus convaincant.
Après il me reste à définir le rapport entre toutes ces petites choses...
Bonne fin de journée
A+
Bonsoir,
je reviens avec "mon code"... Bon j'y suis pour un cercle, je ne suis pas loin de l'ellipse !
Le code :
Sub Remplissage()
Dim Sh As Shape, Nv As Shape, RefT As Double, RefL As Double, PosT As Double, PosL As Double, I As Integer, J As Integer, H As Double, V As Double, NbH As Integer, NbV As Integer
Dim xGc As Double, yGc As Double, xPc As Double, yPc As Double, Decal As Double
Application.ScreenUpdating = False
' on efface tous les hexagonnes
For Each Sh In ActiveSheet.Shapes
If Sh.Name = "Exa" Then Sh.Delete
Next Sh
' nombre d'hexagonne en horizontal
NbH = 30
' nombre d'hexagonne en vertical
NbV = 30
' la hauteur des formes
V = ActiveSheet.Shapes("Cercle").Height / NbV
' on calcul la largeur des formes
H = ActiveSheet.Shapes("Cercle").Width / NbH
' le nombre de forme à l'horizontal
NbH = ActiveSheet.Shapes("Cercle").Width / (H * 0.75)
' la hauteur des formes
V = ActiveSheet.Shapes("Cercle").Height / NbV
' on cré la forme "modèle"
Set Sh = ActiveSheet.Shapes.AddShape(msoShapeHexagon, 0, 0, H, V)
Sh.Name = "LRD"
Sh.Fill.ForeColor.RGB = RGB(112, 48, 160)
' on fabrique la MAP
Set Sh = ActiveSheet.Shapes("LRD")
RefT = ActiveSheet.Shapes("Cercle").Top
RefL = ActiveSheet.Shapes("Cercle").Left + Decal
PosT = RefT
PosL = RefL
For J = 1 To NbH
For I = 1 To IIf(J Mod 2 = 0, NbV - 1, NbV)
Set Nv = Sh.Duplicate
Nv.Name = "Exa"
Nv.Left = PosL
Nv.Top = PosT
PosT = PosT + V
Next I
PosT = IIf(J Mod 2 = 0, RefT, RefT + V / 2)
PosL = PosL + H * 0.75
Next J
' on efface le modèle
ActiveSheet.Shapes("LRD").Delete
' on les scanne afin de savoir s'ils sont sur lla forme complètement
' si non on les efface
Set Gc = ActiveSheet.Shapes("Cercle")
xGc = ActiveSheet.Shapes("Cercle").Left + ActiveSheet.Shapes("Cercle").Width / 2
yGc = ActiveSheet.Shapes("Cercle").Top + ActiveSheet.Shapes("Cercle").Height / 2
For Each Sh In ActiveSheet.Shapes
If Sh.Name = "Exa" Then
xPc = Sh.Left + (Sh.Width / 2)
yPc = Sh.Top + (Sh.Height / 2)
oo = Sqr(Abs(yGc - yPc) ^ 2 + Abs(xPc - xGc) ^ 2)
If oo + (H / 2) < Gc.Width / 2 Or oo + (V / 2) < Gc.Height / 2 Then ' dedans
' on ne fait rien
ElseIf oo - (H / 2) > Gc.Width / 2 Or oo - (V / 2) > Gc.Height / 2 Then ' en dehors
' on efface
Sh.Delete
ElseIf (oo + (H / 2) > Gc.Width / 2 And oo - (H / 2) < Gc.Width / 2) Or (oo + (V / 2) > Gc.Height / 2 And oo - (V / 2) < Gc.Height / 2) Then ' coupe
' on efface aussi
Sh.Delete
End If
End If
Next Sh
End SubLe fichier :
Pour se rapprocher de vos 798 hexagones il vous faut mettre :
' nombre d'hexagonne en horizontal
NbH = 28
' nombre d'hexagonne en vertical
NbV = 29Cela va en créer 790 dans le cercle.
@ bientôt
LouReeD
Bonsoir,
je n'avais pas vu qu'il fallait faire une rotation de 90° de la shape, du coup nouveau fichier qui prend en compte cette subtilité :
Reste plus qu'à trouver les conditions de nettoyage pour une ellipse !
@ bientôt
LouReeD
Waow !
Bel effort.
Avec un zoom de 100, une taille de 45 semble optimale. (± 3 ?)
Une ellipse me semble indispensable à la jouabilité. 200 à 250 Hex me semble envisageable pour obtenir un peuplement satisfaisant tout en laissant un espace libre à l’intérieur. Et une petite zone libre à l’extérieur…
Ton peuplement est efficace, (le Sh.Duplicate y est sans doute pour quelque chose…) meilleur que le mien.
Pour autant (Vu la difficulté) une construction purement mathématique ne me semble pas indispensable : Selon la taille des Sh, il est facile de peupler tout l’écran et de mémoriser dans une table cellex qui sont indispensables. Selon la taille il faut env. 16 lignes pour meubler correctement l’ellipse. Avec un petit peu de tâtonnements pour centrer le tout on arrive assez facilement à créer une table des coordonnées de chaque Sh. Cette table servira ensuite à mémoriser les propriétés de chacune.
En pointillé l’hypothèse d’une classe se profile dans mon esprit car on n’est pas sur un démineur… 6 coté YFO les gérer…
Bon aujourd'hui ça va être soleil. Je m'attarde pas trop parce du coup ce matin y va falloir penser à remplir le frigo...
A+
Bonjour,
La construction mathématique pour la mise en place des shapes plutôt qu'à la main, et ensuite création du tableau des coordonnées de chaque shape.
Bon je suis ravi que cela puisse vous faire avancer dans votre projet.
Pour ce qui est du démineur, on m'a construit un code pour ma version qui même s'il n'y a que 4 côtés gère un grand nombre de possibilités lors de découverte de zone sans bombes ! A voir absolument ! Tout comme la version d'ExcelCoreGame !
@ bientôt
LouReeD
aha, c'est pour un jeu ???
A la base, l'idée est effectivement un jeu et puis est venu la curiosité, le défi...
Bon pour l'instant j'ai un peuplement parfait avec des Hexagones de 47,5 x47,5 (sans zoom et avec une ovale un poil réduite) mais il y a un écueil rédhibitoire : Il n'est pas possible d'écrire sur un hexagone avec une rotation de 90°. (enfin ça doit être possible, mais il doit falloir créer un modèle d'objet invraisemblable avec rotation 3D et... ça pue !
Je vais donc abandonner cette piste non sans avoir sauvegardé ce mappage et je vais appliquer cette forme à des images !
A+
Edit :salut LouReeD, je le sais
Bonsoir,
merci pour le partage de l'image !
@ bientôt
LouReeD