challenge vba suite

[nazemrap]

Bonjour et bonnes fêtes à tous,

 

J 'ai changé de rubrique, celle-ci me paraissant plus adaptée.

J 'ai voulu terminer mon challenge, cela n'a pas été sans mal.

Je le soumets donc à vos appréciations et critiques, améliorations bienvenues.

j' ai souhaité dessiner les symboles au moins une fois, en utilisant la création de blocs.

 

Pas d' autres explications , c'est dans le code.

A rajouter: le comptage et affichage du score....

Si ça ne marche pas, protester ici.

Addiction interdite.

 

 

'definition des variables pour les 3 cartes (le 0 compte aussi)
Dim carte(2) As AcadLWPolyline
'definition des points nécesssaires à la polyligne 4 sommets avec x et y pour chacun soit 8 valeurs en double précision
Dim pt(0 To 15) As Double
'definition de la variable pour la largeur
Dim largeur As Double
' definition de la variable pour la hauteur
Dim hauteur As Double
' definition d' une varariable entier pour une boucle
Dim fois As Integer
' definition d' une varariable entier pour l 'écart séparant 2 cartes
Dim dep As Double
' definition d'une variable pour le chanfrein de la carte
Dim ray As Double
' definition d'une variable pour verifier bloc existant
Dim bloc As AcadBlock
'definition d' un contenant pour la liste de tirage.
Dim liste As Variant
Dim cp_liste As Variant
Dim alea As Integer
'-----------------------
' definition du point de centre de la carte
Dim centre_carte(0 To 2) As Double
'definition de la position du symbole de la carte
Dim pos_symbole(0 To 2) As Double
'definition de 3 arcs pour l 'as de coeur
Dim arc(3) As AcadArc
'definition as de coeur comme région
Dim as_de_coeur As AcadRegion
'-----------------------
'definition des éléments necessaires a as de coeur
'liste d'entités qui composent le symbole coeur
Dim liste_obj(3) As AcadEntity
'définition de la variable qui recevra la région
Dim region As Variant
'définition des variables nécessaires à la hachure du symbole
Dim hachure As AcadHatch
Dim hachure_pique As AcadHatch
Dim nom_motif As String
Dim hachure_type As Long
Dim associatif As Boolean
Dim contour_hachure(0) As AcadEntity
'-----------------------
'definition des blocs
Dim pt_insertion(0 To 2) As Double
Dim bloc_pied As AcadBlock
Dim bloc_coeur As AcadBlock
Dim bloc_pique As AcadBlock
Dim bloc_trefle As AcadBlock
'-----------------------
'definition des references de blocs
Dim ref_coeur As AcadBlockReference
Dim ref_pique As AcadBlockReference
Dim ref_trefle As AcadBlockReference

Dim calq1 As AcadLayer
Dim calq2 As AcadLayer
Dim calq_actif As AcadLayer
'-----------------------
'definition des variables pour rejouer ou arreter
Dim no_gagnant As Long
Dim retour_carte As AcadLWPolyline
Dim reponse As Integer
'definit variable pour verifier
Dim verif As Integer


Public Function DenR(angle)
Pi = 4 * Atn(1)
DenR = (angle * Pi) / 180
End Function

Public Sub bonneteau_1()
verif = 0
debut:
pt_insertion(0) = 0: pt_insertion(1) = 0: pt_insertion(2) = 0

'valoriser les 3 paramètres de dimension et placement
'largeur = InputBox("Quelle est la largeur de la carte")'mettre en service ici pour la largeur de carte
largeur = 10 'à supprimer si utlisation de la ligne supétieure.
hauteur = largeur * 2
dep = largeur * 2
ray = largeur * 0.1

'positionne le symbole
'conforme aux tracés géométriques préconisés, mais à modifier suivant besoins
'cela permettra de changer le point de base si on fait tout un jeu un jour
'position en X
pos_symbole(0) = pt_insertion(0) - (ray / 2)
'position en Y
pos_symbole(1) = pt_insertion(1) + (ray)
'on reste sur le plan à 0
pos_symbole(2) = 0

'Stop
'Création des blocs si necessaires
If verif = 0 Then
coeur
pied
pique
trefle
End If

'Création des calques
Set calq1 = ThisDrawing.Layers.Add("rouge_coeur_carreau")
calq1.color = acRed
Set calq2 = ThisDrawing.Layers.Add("noir_pique_trefle")
calq2.color = acWhite

'la liste
liste = Array("coeur", "pique", "trefle")
cp_liste = liste

'création des cartes avec une boucle
'3 tours
For fois = 0 To 2
'point d' origine au tour suivant le placement du point d 'origine est augmenté de la variable de placement
pt(0) = 0 + (dep * fois) + ray: pt(1) = 0
pt(2) = pt(0) + largeur - 2 * ray: pt(3) = pt(1)
pt(4) = pt(2) + ray: pt(5) = pt(3) + ray
pt(6) = pt(4): pt(7) = pt(3) + hauteur - ray
pt(8) = pt(2): pt(9) = pt(3) + hauteur
pt(10) = pt(0): pt(11) = pt(9)
pt(12) = pt(0) - ray: pt(13) = pt(7)
pt(14) = pt(12): pt(15) = pt(1) + ray
'creation de la carte proprement dit avec une polyligne 2d
Set carte(fois) = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
'propriété qui permet de fermer la polyligne sur son premier point
carte(fois).Closed = True

'centre de la carte
'permettra les positionnements
centre_carte(0) = pt(0) + (largeur / 2) - ray
centre_carte(1) = hauteur / 2
centre_carte(2) = 0

'propriété qui permet d'avoir des coins arrondis
For fois2 = 1 To 7 Step 2
carte(fois).SetBulge fois2, Tan(DenR(22.5))
Next fois2

'creation aleatoire pour dessinner les symboles
Randomize
alea = Int((2 * Rnd) + 0.5)
While cp_liste(alea) = "rien"
alea = Int((2 * Rnd) + 0.5)
Wend

'Appel création de symbole
Set calq_actif = ThisDrawing.ActiveLayer
Select Case alea
Case 0
ThisDrawing.ActiveLayer = calq1
Set ref_coeur = ThisDrawing.ModelSpace.InsertBlock(centre_carte, "coeur", 1, 1, 1, 0)
Case 1
ThisDrawing.ActiveLayer = calq2
Set ref_pique = ThisDrawing.ModelSpace.InsertBlock(centre_carte, "pique", 1, 1, 1, 0)
Case 2
ThisDrawing.ActiveLayer = calq2
Set ref_trefle = ThisDrawing.ModelSpace.InsertBlock(centre_carte, "trefle", 1, 1, 1, 0)
End Select
ThisDrawing.ActiveLayer = calq_actif
cp_liste(alea) = "rien"
   
Next fois

'reglage du zoom
ThisDrawing.Application.ZoomExtents
   Dim pointz1(0 To 2) As Double
   Dim pointz2(0 To 2) As Double
   pointz1(0) = -(largeur / 2): pointz1(1) = 0: pointz1(2) = 0
   pointz2(0) = largeur * 6: pointz2(1) = hauteur * 2.5: pointz2(2) = 0
   ZoomWindow pointz1, pointz2

'boite de dialogue proposant de jouer

If verif = 0 Then
Dim Msg, Style, Titre
Msg = "Jouer ?"    ' Définit le message.
Style = vbYesNo   ' Définit les boutons.
Titre = "Lancer le jeu"    ' Définit le titre.
' Affiche le message.
reponse = MsgBox(Msg, Style, Titre)
End If

'efface les blocs
ref_coeur.Delete
ref_pique.Delete
ref_trefle.Delete

'si reponse négative, sortir
If reponse = 7 Then GoTo fin

'---------------------------
'seconde phase
'---------------------------

'affecte la carte gagnante
Randomize
alea = Int((2 * Rnd) + 0.5)
no_gagnant = carte(alea).ObjectID

'Selection éventuelle de la carte gagnante
'MsgBox "Selectionnez l' as de coeur"
'Message d' invite, également sur la ligne de commande

ThisDrawing.Utility.GetEntity retour_carte, basePnt, "Selectionnez l' as de coeur en cliquant sur le contour."
If retour_carte.ObjectID = no_gagnant Then
MsgBox "BRAVO, vous avez gagné !!!!"
Else
MsgBox "Malheureusement ce n 'est pas la bonne carte !"
End If

reponse = MsgBox("Voulez-vous rejouer ?", vbYesNo)

If reponse = 6 Then
For fois2 = 0 To 2
carte(fois2).Delete
Next
'retourne à l 'étiquette debut en evitant la boite initiale
verif = 1
GoTo debut
End If

fin:
'supprime les contours et les calques
For fois2 = 0 To 2
carte(fois2).Delete
Next
calq1.Delete
calq2.Delete

' Attention les blocs ne sont pas purgés.

End Sub

Public Sub coeur()
'--------------------------
' il s' agit ici d'un sous programme qui définit le bloc coeur.
'--------------------------

Set bloc_coeur = ThisDrawing.Blocks.Add(pt_insertion, "coeur")

'traçage de arc1 supérieur gauche en reprenant le rayon défini pour l'arrondi et économiser les variables
'ceci est complètement arbitraire, à vous d 'innover sur ce point.
' l 'arc a besoin du centre, du rayon, de l'angle de départ en radian et de l'angle de fin en radian
'sens trigo
'on réutilise ici la fonction de MDSV31 pour la conversion degrés vers radians

Set arc(0) = ThisDrawing.ModelSpace.AddArc(pos_symbole, ray, DenR(60), DenR(180))

'miroir pour arc1 en symétrie avec 2 points
Set arc(1) = arc(0).Mirror(arc(0).StartPoint, pt_insertion)

'traçage de arc3 inférieur gauche car je dispose maintenant du point final de
'arc1 qui devient le centre de arc3

Set arc(3) = ThisDrawing.ModelSpace.AddArc(arc(0).EndPoint, (3 * ray), DenR(300), DenR(360))

'miroir pour arc2 en symétrie avec 2 points
Set arc(2) = arc(3).Mirror(arc(0).StartPoint, pt_insertion)

'mettre les arcs dans la liste
For fois2 = 0 To 3
Set liste_obj(fois2) = arc(fois2)
Next
'Stop
'la region dans la variable variant
region = ThisDrawing.ModelSpace.AddRegion(liste_obj)

'recupération de la région qui est la première et
'la seule créée présente dans la variable region
'il peut donc éventuellement y en avoir plusieurs
Set as_de_coeur = region(0)
as_de_coeur.Move arc(2).EndPoint, pt_insertion
' définition de la hachure
nom_motif = "SOLID"
hachure_type = acHatchPatternTypePreDefined
associatif = True
   
' création de la hachure
Set hachure = ThisDrawing.Blocks("coeur").AddHatch(hachure_type, nom_motif, associatif)
Set contour_hachure(0) = as_de_coeur

' ajouter le contour et afficher la hachure
hachure.AppendOuterLoop (contour_hachure)
hachure.Evaluate
hachure.color = acByLayer
ThisDrawing.Regen True

'suppression du contour
as_de_coeur.Delete
arc(2).Delete

End Sub

Public Sub pied()
'--------------------------
' il s' agit ici d'un sous programme qui sera appelé par le programme principal.
'création du pied en bloc necessaire pour le pique et le trefle
'vous avez remarqué que c 'est la même figure à l 'envers
'avec les grands arcs inversés, ces arc ont été coservés après la création du coeur
'--------------------------
Set bloc_pied = ThisDrawing.Blocks.Add(pt_insertion, "pied")

'miroir arc3 pour obtenir l 'inverse
'en utisant comme point de la ligne de symétrie les extrémités de arc3
Set arc(2) = arc(3).Mirror(arc(3).StartPoint, arc(3).EndPoint)
'supprime arc3
arc(3).Delete

'miroir arc2 pour obtenir l 'inverse
Set arc(3) = arc(2).Mirror(arc(0).StartPoint, pt_insertion)

'transforme en region
'---------------------------
'pour faire une région, il faut une liste d' objets
'pour le nombre d' objets nécessaires à créer la région
'une region est dans une variable de type variant

'mettre les arcs dans la liste
For fois2 = 0 To 3
Set liste_obj(fois2) = arc(fois2)
Next

'la region dans la variable variant
region = ThisDrawing.ModelSpace.AddRegion(liste_obj)

'recupération de la region qui est la première et
'la seule crée présente dans la variable region
'il peut donc éventuellement y en avoir plusieurs
Set piedepique = region(0)

'retournement par rotation
piedepique.Rotate arc(3).StartPoint, DenR(180)
piedepique.Move arc(3).StartPoint, pt_insertion

' définition de la hachure
nom_motif = "SOLID"
hachure_type = acHatchPatternTypePreDefined
associatif = True
   
' création de la hachure
Set hachure = ThisDrawing.Blocks("pied").AddHatch(hachure_type, nom_motif, associatif)
Set contour_hachure(0) = piedepique

' ajouter le contour et afficher la hachure
hachure.AppendOuterLoop (contour_hachure)
hachure.Evaluate
hachure.color = acByLayer
ThisDrawing.Regen True

'suppression des arcs maintenant inutiles, et du contour
For fois2 = 0 To 3
arc(fois2).Delete
Next
piedepique.Delete

End Sub


Public Sub pique()
'--------------------------
' il s' agit ici d'un sous programme qui crée l' as de pique depuis les 2 blocs précédents
'--------------------------
Set bloc_pique = ThisDrawing.Blocks.Add(pt_insertion, "pique")

Set ref_pied = ThisDrawing.Blocks("pique").InsertBlock(pt_insertion, "pied", 0.8, 0.8, 0.8, 0)
pt_insertion(1) = (3 * ray) + (ray / 2)
Set ref_coeur = ThisDrawing.Blocks("pique").InsertBlock(pt_insertion, "coeur", 1, 1, 1, DenR(180))
pt_insertion(1) = 0
End Sub


Public Sub trefle()
'--------------------------
' il s' agit ici d'un sous programme qui crée l 'as de trèle depuis les 2 premiers blocs
'--------------------------
Set bloc_trefle = ThisDrawing.Blocks.Add(pt_insertion, "trefle")

Set ref_coeur = ThisDrawing.Blocks("trefle").InsertBlock(pt_insertion, "coeur", 0.5, 0.5, 0.5, DenR(-100))

'fait un réseau de 3
reseau = ref_coeur.ArrayPolar(3, DenR(200), pt_insertion)

Set ref_pied = ThisDrawing.Blocks("trefle").InsertBlock(pt_insertion, "pied", 0.8, 0.8, 0.8, 0)
End Sub

[lili2006]

Bonjour à toutes et tous,

 

Alors là, bleuffant ! Hormis la technique mis en oeuvre derrière tout cela, je me demande comment cela peut être aussi aléatoire, qu'avec 3 cartes !!

 

Evidemment, on peut toujours avoir des idées "d'amélioration", du style :

 

Partie en dix coups avec décompte de points,

Manche avec deux joueurs sur 3 parties,...

 

En tout cas, chapeau !

 

Et merci pour cette démonstration,...

 

[nazemrap]

Re,

 

En voilà une idée quelle est bonne!

Ce serait super.

 

[lili2006]

Re,

 

Heu ! j'espère que tu ne comte pas sur moi,...

 

Comme tu as pu le constater, je suis à 80¨% demandeur sur ce forum plutôt que "productif" !

 

ca, des idées, c'est pas c'qui manquent,....

 

Encore bravo !

[nazemrap]

Non, mais je sais bien que si personne ne s' y met, ça va me démanger.

Comme je dois aussi faire d' autres choses.

Alors je sollicite !

 

En fait, je crois que j 'aime bien ça.

D 'autre part, même si je ne demande pas toujours, j 'ai pioché beaucoud d 'éléments ici.

Si je peux renvoyer l 'ascenceur, même petitement, j'en suis enchanté.

[lili2006]

Re,

 

D 'autre part, même si je ne demande pas toujours, j 'ai pioché beaucoud d 'éléments ici.

 

C'est la mentalité de ce forum qui me séduit moi aussi.

 

Si je peux renvoyer l 'ascenceur, même petitement, j'en suis enchanté.

 

C'est le cas pour tous ici, et à chacun son niveau.

 

Il est vrai que sur les 40 000 menbres, forcément chacun trouve son bonheur,...

 

Bonnes fêtes de fin d'année.

[didier]

coucou

 

dans le temps :(

j'ai fait pas mal de jeu sur Excel...

 

sur AutoCad, j'ai fait un puissance 4

 

j'en ai jamais vraiment parlé, mais si c'est au goût du jour,

je vais chercher à remettre la main dessus, ou plutôt la souris

et je vous en fait profiter...

 

amicalement

[nazemrap]

Hello Didier

 

moi aussi j 'ai commencé avec Excel ! dans le temps....moi aussi.

 

Mais Puissance 4, je souhaite voir.