VBA : Ellipse (et plus si affinité...)
Bonsoir,
BsAlv, pour le fichier je parlais à galopin01 ! Mais nos réponses se sont croisées mais comme souvent c'est vous le plus rapide !
Petit code pour faire un hexagone régulier dans le bon sens sans rotation :
' on crée la forme "modèle"
x = 150 'abscisse du centre du polygone
y = 150 'ordonnée du centre du polygone
r = [Taille] / 2 'rayon du cercle circonscrit au polygone
n = 6 'nombre de côtés du polygone
With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, x, y + r)
For k = 1 To n
x2 = x + r * Sin(2 * k * 3.141592656 / n)
y2 = y + r * Cos(2 * k * 3.141592656 / n)
.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
Next
Set Sh = .ConvertToShape
End WithMais mon problème c'est le texte, qui se trouve sans artifice dans le bon sens mais pas au bon endroit !
Retouche du code pour ne créer les shapes que s'ils se trouvent sur le cercle :
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, L As Double, NbH As Integer, NbL As Integer
Dim xGc As Double, yGc As Double, xPc As Double, yPc As Double, Decale As Double, Cpt As Integer, NvH As Double, NvV 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
' on crée la forme "modèle"
x = 150 'abscisse du centre du polygone
y = 150 'ordonnée du centre du polygone
r = [Taille] / 2 'rayon du cercle circonscrit au polygone
n = 6 'nombre de côtés du polygone
With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, x, y + r)
For k = 1 To n
x2 = x + r * Sin(2 * k * 3.141592656 / n)
y2 = y + r * Cos(2 * k * 3.141592656 / n)
.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
Next
Set Sh = .ConvertToShape
End With
Sh.Name = "LRD"
Sh.Fill.ForeColor.RGB = RGB(112, 48, 160)
Sh.Line.Weight = 0.25
' on récupère la largeur et la hauteur
H = Sh.Height
L = Sh.Width
' on calcule le nombre de shape en largeur
NbL = ActiveSheet.Shapes("Cercle").Width / L
' permet de centrer sur le cercle la MAP
Decale = (ActiveSheet.Shapes("Cercle").Width - (NbL * L)) / 2
' on calcule le nombre de shape en hauteur en sachant qu'il y a un décalage de 0.25 vers le haut à chaque colonne
' donc c'est comme ci que le shape faisait 0.75 !
NbH = ActiveSheet.Shapes("Cercle").Height / (H * 0.74)
' on fabrique la MAP
Set Sh = ActiveSheet.Shapes("LRD")
RefT = ActiveSheet.Shapes("Cercle").Top
RefL = ActiveSheet.Shapes("Cercle").Left + Decale
PosT = RefT
PosL = RefL
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
' on construit ligne après ligne donc la première boucle c'est pour les colonnes
For J = 1 To NbH
For I = 1 To IIf(I Mod 2 = 0, NbL, NbL + 1) ' une ligne sur deux il y a un shape de plus
'*************************************
' on vérifie s'il est sur le cercle
xPc = PosL + (Sh.Width / 2)
yPc = PosT + (Sh.Height / 2)
oo = Sqr(Abs(yGc - yPc) ^ 2 + Abs(xPc - xGc) ^ 2)
If oo + (L / 2) < Gc.Width / 2 Or oo + (H / 2) < Gc.Height / 2 Then ' dedans
' on crée le shape
Set Nv = Sh.Duplicate
Nv.Name = "Exa"
Nv.Left = PosL
Nv.Top = PosT
Cpt = Cpt + 1
End If
'**************************************
' le shape suivant est décalé vers la droite de sa largeur
PosL = PosL + L
Next I
' une fois la ligne finie on passe le top à Top + hauteur du shape -0.25
PosT = PosT + H * 0.74
' une ligne sur deux on décale les shapes vers la gauche de la moitié de sa largeur
PosL = RefL + IIf(J Mod 2 = 0, 0, -L / 2)
Next J
' on efface le modèle
ActiveSheet.Shapes("LRD").Delete
MsgBox ("Il y a " & Cpt & " hexagonne sur le cercle")
End Sub@ bientôt
LouReeD
On ne lâche rien !
Le fichier avec des hexagones réguliers, créés seulement si nécessaire, "dans le bon sens" pour le texte et avec du texte !
Toujours sur un cercle, mais avec la formule de BsAlv je devrait pouvoir le faire sur une ellipse !
@ bientôt
LouReeD
BsAlv, : Dommage j'avais déjà préparé mes images !
J'avais à peu près capté pour l'orientation du texte et la rotation de 270 mais je n'ai pas été jusqu'au bout de la démarche...
Bon YAPUKA se retrousser les manches !
Je n'ai plus qu'à recaler ton ellipse, et la jouer fine sur les détails, les débordements me conviennent mais je dois retailler le PJeu pour que toussa reste dans l'écran .Puis je pourrais me pencher sur le déroulement du jeu.
LouReed : Pas encore pris le temps d'éplucher ta prose... YFO que je parte en course...
A+
Moi j'attends de voir votre fichier !
@ bientôt
LouReeD
Lou : Pas eu le temps de travailler dessus encore aujourd'hui.
Pour le partage du fichier à propos de l’image précédente, je ne l’ai pas ajouté car ça ne faisait pas avancer le sujet. J’avais procédé par tâtonnement en construisant un plein écran d’Hex puis en ajustant les marges et la taille de l’Ellipse pour avoir un rendu satisfaisant. Et puis j’ai bloqué tout de suite sur le texte central….
Visiblement je n’ai pas la même disponibilité (en temps) que vous pour pondre du code. (et sans doute moins de vélocité et de compétence…)
Donc là après analyse de ta dernière prod je vais repartir sur des bases plus saines. Mais il faut d'abord que j'analyse plus finement entre toutes les propositions celles qui me permettent de rester avec une ovale et avec un maximum de souplesse. il me semble qu'un mix entre les proposition de BsAlv et tes Formes Libres pourraient l'affaire ?
Si vous voulez fureter plus loin sur ce projet sachez que j’ai prévu un embryon de BD dans la feuille "Prm" pour lister les coordonnées des Hex, le Texte central sera une lettre de l’alphabet majuscule. Donc sur la base de mon dernier modèle comportant 321 Hex (ce n’est pas encore tranché !) il devrait y avoir au moins 12 alphabets complets +11 vides.
Il est prévu de les distribuer aléatoirement en regroupant les vides au centre. Le problème de nombre est bien sur fonction du total d’Hex créés. Le nombre de blancs restant n’est pas important. Ce qui le sera c’est que chaque alphabet soit complet.
Vous allez commencer à comprendre l’importance de la BD (et de la classe…) :
Le nom de chaque shape devrait être au format "Hex000 ?" le commun "Hex" & un index au format "000" et la lettre affichée ou sa valeur ASCII (ce n'est pas encore tranché.
Enfin chaque Hex devra comporter une propriété "genre Tag" qui prendra une valeur byte...
Bon je me mets au boulot !
A+
bonjour galopin01, LouReeD,
@LouReeD, amusant, vous avez créez votre propre forme
Et un cercle n'est qu'un ellipse spécial.
@galopin01, pour le moment, j'attends votre prochaine pierre d'achoppement
Avant de lancer la macro de LouReeD, vous pouvez déformer le "cercle" en largeur et/ou hauteur.
BsAlv : en effet je crée ma propre forme et comme cela elle est régulière, la forme d'Excel me paraît toujours déformée... et pour savoir s'il faut la créer je vais partir sur la vérification que les 6 sommets sont bien sur l'ellipse ou plutôt l'inverse interdire sa création si au moins 1 sommet est en dehors de l'ellipse.
@ bientôt
LouReeD
Vous avez bien raison, ça va vous faire des vacances ! Parce que à ma vitesse de travail le temps que je fasse la synthèse de TOUSSA !
De plus ça permettra à tout le monde travailler avec les mêmes outils et (objets et variables)...
A+
Bonsoir,
et bien voilà, avec la formule de BsAlv et ma "façon de faire" je me retrouve avec un fichier sans hexagone en dehors de l'ellipse, ni même sur le trait de cette dernière.
Possibilité de choisir la taille du shape et Hop ! Merci à vous deux ! Galopin01 quand vous voulez pour d'autre remu méninges !
Le fichier :
Le code :
Sub Remplissage()
Dim Sh As Shape, Nv As Shape, RefT As Double, RefL As Double, PosT As Double, PosL As Double
Dim I As Integer, J As Integer, H As Double, L As Double, NbH As Integer, NbL As Integer
Dim xGc As Double, yGc As Double, xPc As Double, yPc As Double, Decale As Double, Cpt As Integer
Dim Texte As String, NbS As Integer, dFormule, A, B, K, N, X, Y, X2, Y2
Application.ScreenUpdating = False
' on efface tous les hexagones
For Each Sh In ActiveSheet.Shapes
If Sh.Name = "Exa" Then Sh.Delete
Next Sh
' on crée la forme "modèle" sur mesure
X = 150 'abscisse du centre du polygone
Y = 150 'ordonnée du centre du polygone
R = [Taille] / 2 'rayon du cercle circonscrit au polygone
N = 6 'nombre de côtés du polygone
With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, X, Y + R)
For K = 1 To N
X2 = X + R * Sin(2 * K * 3.141592656 / N)
Y2 = Y + R * Cos(2 * K * 3.141592656 / N)
.AddNodes msoSegmentLine, msoEditingAuto, X2, Y2
Next
Set Sh = .ConvertToShape
End With
Sh.Name = "LRD"
Sh.Fill.ForeColor.RGB = RGB(112, 48, 160)
Sh.Line.Weight = 0.25
' on récupère la largeur et la hauteur
H = Sh.Height
L = Sh.Width
Set Gc = ActiveSheet.Shapes("Cercle")
' on calcule le nombre de shape en largeur
NbL = Gc.Width / L
' permet de centrer la MAO sur le cercle
Decale = (Gc.Width - (NbL * L)) / 2
' on calcule le nombre de shape en hauteur en sachant qu'il y a un décalage de 0.25 vers le haut à chaque colonne
' donc c'est comme ci que le shape faisait 0.74 !
NbH = Gc.Height / (H * 0.74)
' on fabrique la MAP
Set Sh = ActiveSheet.Shapes("LRD")
RefT = Gc.Top
RefL = Gc.Left ' + Decale
PosT = RefT
PosL = RefL
xGc = Gc.Left + Gc.Width / 2
yGc = Gc.Top + Gc.Height / 2
A = Gc.Width / 2
B = Gc.Height / 2
' on construit ligne après ligne donc la première boucle c'est pour les colonnes
For J = 1 To NbH
For I = 1 To IIf(I Mod 2 = 0, NbL, NbL + 1) ' une ligne sur deux il y a un shape de plus
' on vérifie s'il est sur le cercle
xPc = PosL + (Sh.Width / 2)
yPc = PosT + (Sh.Height / 2)
' vérification des 6 sommets
For K = 1 To N
X2 = xPc + R * Sin(2 * K * 3.141592656 / N)
Y2 = yPc + R * Cos(2 * K * 3.141592656 / N)
' avec la formule de BsAlv pour l'ellipse
dFormule = ((X2 - xGc) / A) ^ 2 + ((Y2 - yGc) / B) ^ 2
If dFormule < 1 Then NbS = NbS + 1 Else Exit For
Next
' si les 6 sommets sont sur l'ellipse alors on crée l'hexagone par duplication du modèle
If NbS = 6 Then
Set Nv = Sh.Duplicate
With Nv
.Name = "Exa"
.Left = PosL
.Top = PosT
Cpt = Cpt + 1
Texte = "LRD" & Cpt
.TextFrame2.MarginTop = (.Height / 2) + 8
.TextFrame2.MarginLeft = .Width - Len(Texte) * 2
.TextFrame2.TextRange.Font.Size = 6
.TextFrame2.TextRange.Characters.Text = Texte
End With
End If
NbS = 0
' le shape suivant est décalé vers la droite de sa largeur
PosL = PosL + L
Next I
' une fois la ligne finie on passe le top à Top + hauteur du shape -0.25
PosT = PosT + H * 0.74
' une ligne sur deux on décale les shapes vers la gauche de la moitié de sa largeur
PosL = RefL + IIf(J Mod 2 = 0, 0, -L / 2)
Next J
' on efface le modèle
ActiveSheet.Shapes("LRD").Delete
MsgBox ("Il y a " & Cpt & " hexagone sur le cercle")
End Sub@ bientôt
LouReeD
Lou : Joli ! Bien sur pas encore eu le temps de l'ouvrir !
La caption des Hex doit être une lettre de l'alphabet de A à Z aléatoire. Mais in fine ça doit faire ± une douzaine d'alphabets complets et il doit restera sans doute quelques objets vides (ne pas les créer). Caption et position seront aléatoire.
Le nom de la Shape devrait être "Shex000?" (Shex constante, 000 son format(var,000) le "?" la lettre tirée au sort ou son code ASC (de 65 à 90 dans ce cas le format sera ("Shex00000")
On peut aussi déjà penser à compléter un tableau TData dans la feuille "Prm" avec pour chaque objet son nom et ses coordonnées x, y...
A+
Pour l'espèce de TAG, vous avez ceci :
Sh.AlternativeText = 25 ' la sorte de Tag comprenant une valeur, le hic c'est du texte...mais *1 cela devient numérique.
@ bientôt
LouReeD
Impressionnant. Juste un petit défaut si on veut chipoter, tu ne gères pas la symétrie horizontale avec mon modèle je n'ai qu'une shape en 1ère ligne et une quinzaine tout en bas... Et ça envoie, Waow !!!
J'ai testé une vingtaine de dimensions d'Ellipse, voilà qui va me faire gagner au moins une journée !
Ce ne sont ps des Tags ce sera le nom (iD) des Shapes dans la BD Ce nom doit intégrer le radical sont numéro et la lettre affichée il seront extrait ensuite par mid dans la classe.
Et il y aura en plus une propriété Tag mais ça... chut ! Ce sera la cerise...
A+
Symétrie ? C'est la première fois que je vois ce mot, non ?
BsAlv ?
Sinon je calculai un centrage en horizontal, juste à faire la même chose en vertical ce qui engendrera une symétrie...
@ bientôt
LouReeD
Bah ! ça c'est pas compliqué je m'en charge je t'ai répondu aussi (dans ma réponse précédente) pour les propriétés Name et Tag
J'ai l'impression que tu n'a pas trouvé le centrage du texte sur la forme, mais je dois y arriver..
A + ...Demain !
Zzzzzzzzzzzzzz...
Bizarrement le centrage sur une forme créée ne marche pas... ou bien je suis passé à côté d'un truc...
@ bientôt
LouReeD
Bonjour,
Bon voici une synthèse de vos apports avec un petit toilettage (déclaration des var, centrage du texte des Exa) , avec quelques boutons pour ne pas avoir à jouer sur la conf et conserver la votre à la sortie.
TAPUKA faire le centrage (Je m'y perd un peu dans tes variables esotériques...)
Je m'occupe du tirage au sort des lettres affichées et du nommage définitif de chaque Shape.
Je pense que ça me suffira pour aujourd'hui. Demain j'attaquerai le déroulement du jeu et le Tag proprement dit : Pour l'instant on à mangé notre pain blanc !
A+
Bonjour,
centrage horizontal et vertical :
Sub Remplissage()
' variables générales
Dim Sh As Shape, I As Integer, J As Integer, K As Integer, Gc As Shape
' variables création forme modèle
Dim X1 As Double, Y1 As Double, R1 As Double, S1 As Integer
Dim X2 As Double, Y2 As Double
Dim H As Double, L As Double
' variables de construction de la MAP
Dim NbL As Integer, DL As Double, NbH As Integer, DH As Double
Dim RefL As Double, RefT As Double, XGc As Double, YGc As Double, A As Double, B As Double
Dim Xs As Double, Ys As Double, dFormule, NbS As Integer, Texte As String
' on arrête la mise à jour de l'écran
Application.ScreenUpdating = False
' on efface tous les hexagones
For Each Sh In ActiveSheet.Shapes
If Left(Sh.Name, 3) = "Hex" Then Sh.Delete
Next Sh
' on crée la forme modèle "sur mesure"
X1 = 150 'abscisse du centre du polygone
Y1 = 150 'ordonnée du centre du polygone
R1 = [Taille] / 2 'rayon du cercle circonscrit au polygone
S1 = 6 'nombre de côtés du polygone
With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, X1, Y1 + R1)
For I = 1 To S1
X2 = X1 + R1 * Sin(2 * I * 3.141592656 / S1)
Y2 = Y1 + R1 * Cos(2 * I * 3.141592656 / S1)
.AddNodes msoSegmentLine, msoEditingAuto, X2, Y2
Next I
Set Sh = .ConvertToShape
End With
' on lui donne un nom, une couleur
Sh.Name = "MOD"
Sh.Fill.ForeColor.RGB = RGB(112, 48, 160)
' on récupère la hauteur et la largeur
H = Sh.Height
L = Sh.Width
' on attribue à Gc le shape ellipse
Set Gc = ActiveSheet.Shapes("Cercle")
' on calcule le nombre de shape en largeur par rapport à la largeur de Gc
NbL = Gc.Width / L
' on calcul le décalage harizontal afin de centrer la MAP sur Gc
DL = (Gc.Width - (NbL * L)) / 2
' on calcule le nombre de shape en hauteur en sachant qu'il y a un décalage de 0.25 vers le haut à chaque colonne
' c'est comme ci que le shape faisait 0.75 !
NbH = Gc.Height / (H * 3 / 4)
' pour le centrage il faut un nombre de ligne impaire
If NbH Mod 2 = 0 Then NbH = NbH - 1
DH = (Gc.Height / 2) - ((((NbH - 1) / 2) * (H * 3 / 4)) + (H * 1 / 2)) '((Gc.Height - (NbH * (H * 3 / 4)) + (H * 1 / 4)) / 2) + (H / 4)
' on fabrique la MAP
'*******************
' position de départ à gauche des hexagones
RefL = Gc.Left + DL
RefT = Gc.Top + DH
' position gauche et haute du prochain shape à créer
PosT = RefT
PosL = RefL + (L / 2)
' coordonnées du centre de l'ellipse
XGc = Gc.Left + Gc.Width / 2
YGc = Gc.Top + Gc.Height / 2
' Largeur et hauteur de l'ellipse
A = Gc.Width / 2
B = Gc.Height / 2
' on construit ligne après ligne donc la première boucle c'est pour les colonnes
' on boucle sur les colonnes
For J = 1 To NbH
' on boucle sur les lignes
For I = 1 To NbL
' on vérifie s'il est sur le cercle
Xs = PosL + (L / 2)
Ys = PosT + (H / 2)
' vérification des 6 sommets
For K = 1 To S1
X2 = Xs + R1 * Sin(2 * K * 3.141592656 / S1)
Y2 = Ys + R1 * Cos(2 * K * 3.141592656 / S1)
' avec la formule de BsAlv pour l'ellipse
dFormule = ((X2 - XGc) / A) ^ 2 + ((Y2 - YGc) / B) ^ 2
If dFormule < 1 Then NbS = NbS + 1 Else Exit For
Next
' si les 6 sommets sont sur l'ellipse alors on crée l'hexagone par duplication du modèle
If NbS = 6 Then
Set Nv = Sh.Duplicate
With Nv
.Name = "Hex" & Format(Int(Rnd * 999) + 1, "###")
.Left = PosL
.Top = PosT
Cpt = Cpt + 1
Texte = Chr(Int(Rnd * 26) + 65)
' à revoir le centrage du texte
.TextFrame2.MarginTop = (.Height / 2) + 6
.TextFrame2.MarginLeft = .Width - Len(Texte) * 2.5
.TextFrame2.TextRange.Font.Size = 16
.TextFrame2.TextRange.Characters.Text = Texte
' ici renseignement du "TAG"
.AlternativeText = Int(Rnd * 256) ' la sorte de Tag comprenant une valeur, le hic c'est du texte...mais *1 cela devient numérique
End With
End If
NbS = 0
' le shape suivant est décalé vers la droite de sa largeur
PosL = PosL + L
Next I
' une fois la ligne finie on passe le top à Top + hauteur du shape -0.25
PosT = PosT + (H * 3 / 4)
' une ligne sur deux on décale les shapes vers la droite de la moitié de sa largeur
PosL = RefL + IIf(J Mod 2 = 0, L / 2, 0)
Next J
' on efface le modèle
ActiveSheet.Shapes("MOD").Delete
MsgBox ("Il y a " & Cpt & " hexagone sur le cercle")
End Sub@ bientôt
LouReeD
Bonjour,
Pour répondre à BsAlv, l'hexagone proposé par Excel n'est pas "régulier" lorsque vous appliquez une rotation à la forme elle ne se superpose pas (au 6ième de tour près) à une forme de taille identique.
J'ai fais cette expérience : création d'un hexagone régulier, ce qui me donne un shape avec des dimensions en H et L, insertion d'une forme hexagonale, et mise en taille identique que le shape créé, et rien à faire ! Les angles "programmés" dans la forme ne sont pas tous égaux, ce qui fait que les formes ne sont pas superposables à un hexagone régulier.
Par contre le régulier engendre un problème de centrage de texte, sans manipulation il se trouve en dehors de la forme même avec les alignements centrés dans les deux directions !
@ bientôt
LouReeD
Bon pour le centrage du texte sur la forme libre :
With .TextFrame2
.TextRange.Font.Size = 16
.TextRange.Font.Name = "Consolas"
.TextRange.Characters.Text = Texte
.MarginTop = Nv.Height
.MarginLeft = Nv.Width
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End WithJ'ai ajouté "consolas" mais ce n'est peut-être pas la peine...
J'ai également ajouté ceci à la création du modèle afin de dissocier les hexagones de la taille des cellules, sait-on jamais :
' on le rend "indéformable"
Sh.Placement = xlFreeFloating@ bientôt
LouReeD
re,
voici ma proposition à partir du dernier fichier de galopin01
Edit: LouReeD, je vois que vous avez aussi répondu, je n'ai pas encore lu vos modifications, sorry
PS. je dois parfois m'occuper de ma mère âgée la nuit, donc je ne peux pas répondre, je me contente de lire sur mon téléphone portable.
PS2 votre macros ne fonctionnent plus, je ne sais pas pourquoi, donc il faut les copier et coller