Le but de cette ActiveX est de donnée un accès plus facile aux fonctionnalités de la Dll Cards32.dll de Microsoft.
Cette ActiveX est maintenant libre : vous pouvez le redistribuer et/ou le modifier selon les termes de la Licence Publique Générale GNU-GPL publiée par la Free Software Foundation (version 2).
Liste des Méthodes & propriétés : (un fichier d'aide acompagne l'OCX)
CardValue : permet de définir la valeur de la carte (As, Roi,...)
CardColor : permet de définir la couleur de la carte (Carreau, Pique,...)
CardId : donne le numéro de la carte dans le paquet (combinaison des deux propriétés précédentes
CardBack : permet de définir le motif du verso (Robots, Coquillage,...)
Picture : permet de définir un motif depuis un fichier BMP,WMF,...
Animate : permet de définir si le recto est animé.
AnimateSpeed : donne la vitesse de l'animation.
CardDraw : indique la méthode d'affichage (Recto, Verso,...)
Stretch : indique si l'on utilise une dimension de carte personnalisée.
Visible : indique si la carte visible ou non.
CardPaquet : indique la méthode d'affichage (Recto, Verso,...)
CardPaquet_Index : indique si l'on utilise une dimension de carte personnalisée.
MetaTag : donne une référence sur un objet de l'utilisateur.
CreateGame : permet de créer un paquet de cartes mélangé.
Source / Exemple :
VERSION 5.00
Begin VB.UserControl Cards
CanGetFocus = 0 'False
ClientHeight = 2655
ClientLeft = 0
ClientTop = 0
ClientWidth = 2295
ClipControls = 0 'False
OLEDropMode = 1 'Manual
ScaleHeight = 2655
ScaleWidth = 2295
ToolboxBitmap = "Cards.ctx":0000
Begin VB.Timer iAnimate
Interval = 1000
Left = 1680
Top = 240
End
Begin VB.Image UserPicture
Enabled = 0 'False
Height = 2415
Left = 0
Stretch = -1 'True
Top = 0
Width = 2175
End
End
Attribute VB_Name = "Cards"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'=========================================================================================
' (C) 2000 by Patrick
'
' email: jeux.cartes@free.fr
'=========================================================================================
Option Explicit
'=========================================================================================
' Fonctions Externe
'=========================================================================================
Private Declare Function cdtInit Lib "Cards32.Dll" (Dx As Long, Dy As Long) As Long
Private Declare Function cdtDraw Lib "Cards32.Dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal iCard As Long, ByVal iDraw As Long, ByVal BkGrnd As Long) As Long
Private Declare Function cdtDrawExt Lib "Cards32.Dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Dx As Long, ByVal Dy As Long, ByVal iCard As Long, ByVal iDraw As Long, ByVal BkGrnd As Long) As Long
Private Declare Function cdtAnimate Lib "Cards32.Dll" (ByVal hDC As Long, ByVal iCardBack As Long, ByVal X As Long, ByVal Y As Long, ByVal iState As Long) As Long
Private Declare Function cdtTerm Lib "Cards32.Dll" () As Long
'=========================================================================================
' Working
'=========================================================================================
Private Dx As Long ' Working
Private Dy As Long '
Private Motif As Integer '
Private UserMode As Boolean '
Private iCardDraw As Long ' Backup Property
Private iCardId As Integer '
Private iCardBack As Integer '
Private iStretch As Boolean '
Private iPaquet As Collection '
Private iPqIndex As Long '
Private iMetaTAG As Object '
'=========================================================================================
' Constantes
'=========================================================================================
Public Enum PaquetEnum ' Definition des rangs
Souche = 1 '
Haut = 2 '
End Enum '
Public Enum CopyrightEnum ' Affichage Copyright
Copyright = 1 '
End Enum '
Public Enum TypeGameEnum ' Liste des Jeux
Paquet_32_Cartes = 32 '
Paquet_52_Cartes = 52 '
End Enum '
Public Enum CardColorEnum ' Liste des Couleurs de carte
Trefle '
Carreaux '
Coeur '
Pique '
End Enum '
Public Enum CardDrawEnum ' Liste des modes d'affichage (Cards32.dll)
FACEUP '
FACEDOWN '
HILITE '
GHOST '
SUPPR '
INVISIBLEGHOST '
DECKX '
DECKO '
End Enum '
Public Enum CardBackEnum ' Liste des Motifs des Rectos des cartes (Cards32.dll)
Black = 53 '
Plaid = 54 '
Weave = 55 '
Robot = 56 '
Roses = 57 '
IvyBlack = 58 '
IvyBlue = 59 '
FishCyan = 60 '
FishBlue = 61 '
Shell = 62 '
Castle = 63 '
Beach = 64 '
CardHand = 65 '
UserPicture = 99
End Enum '
'=========================================================================================
' Evenements
'=========================================================================================
Public Event Click()
Attribute Click.VB_UserMemId = -600
Public Event DblClick()
Attribute DblClick.VB_UserMemId = -601
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_UserMemId = -605
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_UserMemId = -606
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_UserMemId = -607
'------- Click
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
'------- Double Click
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
'------- Mouse Down
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
'------- Mouse Move
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
'------- Mouse Up
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
'=========================================================================================
' Propriétés
'=========================================================================================
'------------------------------------ A propos de... -------------------------------------
Public Sub A_Propos_de()
Attribute A_Propos_de.VB_Description = "email:bureau.patrick@libertysurf.fr Site:http://perso.libertysurf.fr/jeuxdecartes"
Attribute A_Propos_de.VB_UserMemId = -552
FrmCopyright.Show vbModeless, Me
End Sub
'---------------------------------- Paquet de la carte -----------------------------------
Public Property Get CardPaquet() As Collection
Attribute CardPaquet.VB_Description = "Collection définisant le PAQUET auquel appartient la carte"
Attribute CardPaquet.VB_HelpID = 12
Set CardPaquet = iPaquet
End Property
Public Property Set CardPaquet(Value As Collection)
'- - - - Retire de la collection précédente
If Not (iPaquet Is Nothing) Then
iPaquet.Remove Str(iPqIndex)
Set iPaquet = Nothing
End If
'- - - - fixe dans la nouvelle collection
Set iPaquet = Value
If Not Value Is Nothing Then
iPaquet.Add UserControl.Extender, Str(iPaquet.Count + 1)
iPqIndex = iPaquet.Count
End If
End Property
Public Property Get CardPaquetIndex() As Long
Attribute CardPaquetIndex.VB_Description = "Indice de la carte dans le PAQUET. l'indice 1 doit être réservé au talon du paquet."
Attribute CardPaquetIndex.VB_HelpID = 13
CardPaquetIndex = iPqIndex
End Property
'------------------------------ Valeur de la Cartes (0 à 12) -----------------------------
Public Property Let CardValue(Value As Integer)
Attribute CardValue.VB_Description = "Valeur de la carte : 1=As, 2=2, 11=Valet, 12=Dame, 13=Roi"
Attribute CardValue.VB_HelpID = 8
Value = IIf(Value < 1, 1, IIf(Value > 13, 13, Value))
Me.CardId = (((Value - 1) * 4) + Me.CardColor) + 1
End Property
Public Property Get CardValue() As Integer
CardValue = Int(iCardId / 4) + 1
End Property
'------------------------------ Couleur de la cartes (0 à 3) -----------------------------
Public Property Let CardColor(Value As CardColorEnum)
Attribute CardColor.VB_Description = "Couleur de la carte"
Attribute CardColor.VB_HelpID = 4
Value = IIf(Value < 0, 0, IIf(Value > 3, 3, Value))
Me.CardId = (((Me.CardValue - 1) * 4) + Value) + 1
End Property
Public Property Get CardColor() As CardColorEnum
CardColor = iCardId Mod 4
End Property
'----------------------- Numero de la carte dans le paquet (1 à 52) ----------------------
Public Property Let CardId(Value As Integer)
Attribute CardId.VB_Description = "Numero de la carte dans le paquet : de 1 à 52 pas de joker !"
Attribute CardId.VB_HelpID = 6
iCardId = IIf(Value < 1, 1, IIf(Value > 52, 52, Value)) - 1
PropertyChanged ("CardId")
Call Refresh
End Property
Public Property Get CardId() As Integer
CardId = iCardId + 1
End Property
'-------------------------------- Recto, Verso,.... (0 à 7) ------------------------------
Public Property Let CardDraw(Value As CardDrawEnum)
Attribute CardDraw.VB_Description = "Facede la carte dessine, sélection, ..."
Attribute CardDraw.VB_HelpID = 5
iCardDraw = IIf(Value < 0, 0, IIf(Value > 7, 7, Value))
PropertyChanged ("CardDraw")
Call Refresh
End Property
Public Property Get CardDraw() As CardDrawEnum
CardDraw = iCardDraw
End Property
'------------------------------- Modif du recto de la Carte ------------------------------
Public Property Let CardBack(Value As CardBackEnum)
Attribute CardBack.VB_Description = "Modif du recto de la carte"
Attribute CardBack.VB_HelpID = 3
If Value = UserPicture Then
iCardBack = UserPicture
Else
iCardBack = IIf(Value < 53, 53, IIf(Value > 65, 65, Value))
Set Me.Picture = Nothing
End If
PropertyChanged ("CardBack")
Call Refresh
End Property
Public Property Get CardBack() As CardBackEnum
CardBack = iCardBack
End Property
Public Property Set Picture(ByVal NewPicture As Picture)
Attribute Picture.VB_Description = "Modif de Fond définie par l'utilisateur"
Attribute Picture.VB_HelpID = 11
Dim PictureType As Long
On Error Resume Next
PictureType = NewPicture.Type
On Error GoTo 0
If PictureType > 0 Then
Me.CardBack = UserPicture
Me.Animate = False
End If
Set UserControl.UserPicture.Picture = NewPicture
PropertyChanged ("Picture")
Call Refresh
End Property
Public Property Get Picture() As Picture
Set Picture = UserControl.UserPicture.Picture
End Property
'------------------------------------ Animation sur la carte ---------------------------------
Public Property Let Animate(Value As Boolean)
Attribute Animate.VB_Description = "Active l'animation de certain motif de carte (Robot, Beach, ...) Disponible uniquement si la propriété Stretch=False"
Attribute Animate.VB_HelpID = 1
iAnimate.Enabled = Value
PropertyChanged ("Animate")
End Property
Public Property Get Animate() As Boolean
Animate = iAnimate.Enabled
End Property
Public Property Let AnimateSpeed(Value As Integer)
Attribute AnimateSpeed.VB_Description = "Vitesse de l'animation"
Attribute AnimateSpeed.VB_HelpID = 2
iAnimate.Interval = Value
PropertyChanged ("AnimateSpeed")
End Property
Public Property Get AnimateSpeed() As Integer
AnimateSpeed = iAnimate.Interval
End Property
'------------------------------------ Taille de la carte ---------------------------------
Public Property Let Stretch(Value As Boolean)
Attribute Stretch.VB_Description = "False:Taille Standard, True= Taille definie par les propriété Height et With"
Attribute Stretch.VB_HelpID = 10
iStretch = Value
PropertyChanged ("Stretch")
If iAnimate.Enabled And Value = True Then Me.Animate = False
Call UserControl_Paint
End Property
Public Property Get Stretch() As Boolean
Stretch = iStretch
End Property
'------------------------------------------- Actif ? --------------------------------------
Public Property Let Enabled(Value As Boolean)
UserControl.Enabled = Value
PropertyChanged ("Enabled")
End Property
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_UserMemId = -514
Enabled = UserControl.Enabled
End Property
'-------------------------------------- Aspect de la sourie ------------------------------
Public Property Let MousePointer(Value As MousePointerConstants)
UserControl.MousePointer = Value
End Property
Public Property Get MousePointer() As MousePointerConstants
Attribute MousePointer.VB_UserMemId = 0
MousePointer = UserControl.MousePointer
End Property
'-------------------------------------- MetaTAG ------------------------------
Public Property Set MetaTAG(Value As Object)
Attribute MetaTAG.VB_HelpID = 9
Set iMetaTAG = Value
End Property
Public Property Get MetaTAG() As Object
Set MetaTAG = iMetaTAG
End Property
'=========================================================================================
' Initialisation
'=========================================================================================
Private Sub UserControl_Initialize()
'- - - - - - - - Initialisation de la Dll
On Error GoTo Erreur
Call cdtInit(Dx, Dy)
On Error GoTo 0
'- - - - - - - - Initialisation Working
iCardDraw = FACEUP
iCardId = 0
iCardBack = Robot
iAnimate = False
Set iPaquet = Nothing
Set iMetaTAG = Nothing
Exit Sub
Erreur:
If MsgBox("Erreur " & Err.Number & " Intialisation de Cards32.dll :" & vbCrLf & vbCrLf & Err.Description, vbRetryCancel) = vbCancel Then
Unload Me
End If
Resume
End Sub
'---------------------------- Chargement Valeur depuis Source ----------------------------
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'- - - - - - - - Lecture des valeurs implicites
On Error Resume Next
Me.CardId = PropBag.ReadProperty("CardId", 1)
Me.CardDraw = PropBag.ReadProperty("CardDraw", FACEUP)
Me.CardBack = PropBag.ReadProperty("CardBack", Robot)
Me.Animate = PropBag.ReadProperty("Animate", False)
Me.AnimateSpeed = PropBag.ReadProperty("AnimateSpeed", 1000)
Me.Stretch = PropBag.ReadProperty("Stretch", False)
Me.Enabled = PropBag.ReadProperty("Enabled", UserControl.Enabled)
Set Me.Picture = PropBag.ReadProperty("Picture", UserControl.UserPicture.Picture)
On Error GoTo 0
End Sub
'---------------------------- Sauvegarde Valeur dans le Source ---------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'- - - - - - - - Ecriture des valeurs implicites
On Error Resume Next
PropBag.WriteProperty "CardId", Me.CardId, 1
PropBag.WriteProperty "CardDraw", Me.CardDraw, FACEUP
PropBag.WriteProperty "CardBack", Me.CardBack, Robot
PropBag.WriteProperty "Animate", Me.Animate, False
PropBag.WriteProperty "AnimateSpeed", Me.AnimateSpeed, 1000
PropBag.WriteProperty "Stretch", Me.Stretch
PropBag.WriteProperty "Enabled", Me.Enabled
PropBag.WriteProperty "Picture", UserControl.UserPicture.Picture
On Error GoTo 0
End Sub
'---------------------------------------- Fin DLL ------------------------------------------
Private Sub UserControl_Terminate()
'- - - - - - - - Fermeture de la Dll
'cdtTerm
'- - - - - - - - Libération Mémoire
Set Me.CardPaquet = Nothing
Set Me.MetaTAG = Nothing
End Sub
'=========================================================================================
' Controle
'=========================================================================================
Private Sub UserControl_Resize()
Call Refresh
UserControl.UserPicture.Width = UserControl.Width
UserControl.UserPicture.Height = UserControl.Height
End Sub
Private Sub UserControl_Paint()
Call Refresh
End Sub
Public Sub Refresh()
Attribute Refresh.VB_UserMemId = -550
'- - - - - - - Working
Dim iCards As Long
'- - - - - - Calcul du code carte : 0 => As Treffle, 1 => As Carreaux, 2 => As Coeur, 3 => As Pique, 4 => 2 Treffle, 5 => 2 Carreaux,...
iCards = IIf(iCardDraw = FACEDOWN, iCardBack, iCardId)
'- - - - - - Desine la Carte...
On Error Resume Next
UserControl.BackColor = UserControl.Extender.Parent.BackColor
On Error GoTo 0
'- - - - - - ...Avec Stretching
If iStretch Then
UserControl.UserPicture.Visible = (iCardDraw = FACEDOWN And iCardBack = UserPicture)
If UserControl.UserPicture.Visible = False Then
Call cdtDrawExt(UserControl.hDC, 0, 0, UserControl.Width / Screen.TwipsPerPixelX, UserControl.Height / Screen.TwipsPerPixelY, iCards, iCardDraw, UserControl.BackColor)
End If
'- - - - - - ...Sans Stretching
Else
'- - - - - - Resize du controle...
If UserControl.Width <> Dx * Screen.TwipsPerPixelX Then UserControl.Width = Dx * Screen.TwipsPerPixelX
If UserControl.Height <> Dy * Screen.TwipsPerPixelY Then UserControl.Height = Dy * Screen.TwipsPerPixelY
'- - - - - - Dessine la carte...
UserControl.UserPicture.Visible = (iCardDraw = FACEDOWN And iCardBack = UserPicture)
If UserControl.UserPicture.Visible = False Then
Call cdtDraw(UserControl.hDC, 0, 0, iCards, iCardDraw, UserControl.BackColor)
'- - - - - - Remet l'animation...
If iCardDraw = FACEDOWN And iAnimate.Enabled Then
Call cdtAnimate(UserControl.hDC, iCardBack, 0, 0, Motif)
End If
End If
End If
End Sub
'=========================================================================================
' Animation
'=========================================================================================
Private Sub iAnimate_Timer()
If iCardDraw = FACEDOWN Then
Motif = (Motif Mod 3) + 1
Call cdtAnimate(UserControl.hDC, iCardBack, 0, 0, Motif)
End If
End Sub
'=========================================================================================
' Calcul d'un jeux de carte
'=========================================================================================
Public Function CreateGame(TypeGame As TypeGameEnum, Optional Nombre As Integer = 1, Optional InitialRandom As Integer) As Collection
Attribute CreateGame.VB_HelpID = 20
'- - - - - - - - Paquet de carte
Dim PAQUET() As Integer
Dim Game As New Collection
'- - - - - - - - Working
Dim Indice As Integer
Dim Ind1 As Integer
Dim Ind2 As Integer
Dim Value As Integer
'- - - - - - - - Création du paquet de carte
Screen.MousePointer = vbArrowHourglass
ReDim PAQUET(TypeGame * Nombre)
Ind1 = 1
For Ind2 = 1 To Nombre
For Indice = 1 To 52
Select Case TypeGame
'- - - - - - 32 Cartes
Case Paquet_32_Cartes
If Indice < 5 Or Indice > 24 Then
PAQUET(Ind1) = Indice
Ind1 = Ind1 + 1
End If
'- - - - - - Paquet_52_Cartes
Case Else
PAQUET(Ind1) = Indice
Ind1 = Ind1 + 1
End Select
Next
Next
'- - - - - - - - On bat le paquet
If InitialRandom > 0 Then Randomize InitialRandom Else Randomize
For Indice = 1 To 100 * Nombre
Ind1 = Int(TypeGame * Nombre * Rnd) + 1
Ind2 = Int(TypeGame * Nombre * Rnd) + 1
Value = PAQUET(Ind1)
PAQUET(Ind1) = PAQUET(Ind2)
PAQUET(Ind2) = Value
Next
'- - - - - - - - Retour sous forme de collection
For Indice = 1 To TypeGame * Nombre
Game.Add PAQUET(Indice)
Next
Set CreateGame = Game
Screen.MousePointer = vbDefault
End Function
'=========================================================================================
' Deplacement d'une carte
'=========================================================================================
Private Function Mini(Val1, Val2) As Variant
Mini = IIf(Val1 > Val2, Val2, Val1)
End Function
Private Function Maxi(Val1, Val2) As Variant
Maxi = IIf(Val1 < Val2, Val2, Val1)
End Function
'=========================================================================================
Public Sub CardMove(X As Single, Y As Single, Optional Vitesse As Integer)
Attribute CardMove.VB_Description = "Déplace une carte à l'écran"
Attribute CardMove.VB_HelpID = 21
'- - - - - Working
Dim IncX As Double
Dim IncY As Double
Dim NbrSaut As Integer
Dim Indice As Integer
'- - - - - Initialisation
NbrSaut = IIf(Vitesse <= 0, 6, Vitesse)
IncX = (X - UserControl.Extender.Left) / NbrSaut
IncY = (Y - UserControl.Extender.Top) / NbrSaut
'- - - - - Execute les sauts
While NbrSaut > 1
NbrSaut = NbrSaut - 1
For Indice = 1 To 400
DoEvents
Next
UserControl.Extender.Move (UserControl.Extender.Left + IncX), (UserControl.Extender.Top + IncY)
Wend
UserControl.Extender.Move X, Y
UserControl.Extender.ZOrder
End Sub
'=========================================================================================
Public Sub CardMovePaquet(NewPaquet As Collection, Optional IncX As Single, Optional IncY As Single, Optional Vitesse As Integer)
Attribute CardMovePaquet.VB_Description = "Déplace d'une pile de carte à l'écran d'un PAQUET à un autre "
Attribute CardMovePaquet.VB_HelpID = 22
Dim Indice As Long
Dim PaquetSource As Collection
If Not (iPaquet Is NewPaquet) Then
If iPaquet Is Nothing Then
If NewPaquet.Count <= 1 Then IncX = 0: IncY = 0
Me.CardMove NewPaquet(NewPaquet.Count).Left + IncX, NewPaquet(NewPaquet.Count).Top + IncY, IIf(Vitesse = 0, 1, Vitesse)
Set Me.CardPaquet = NewPaquet
Else
Indice = iPqIndex
Set PaquetSource = iPaquet
Do
PaquetSource.Item(Indice).CardMove NewPaquet(NewPaquet.Count).Left + IIf(NewPaquet.Count <= 1, 0, IncX), NewPaquet(NewPaquet.Count).Top + IIf(NewPaquet.Count <= 1, 0, IncY), IIf(Vitesse = 0, 1, Vitesse)
Set PaquetSource.Item(Indice).CardPaquet = NewPaquet
Loop Until PaquetSource.Count < Indice
Set PaquetSource = Nothing
End If
End If
End Sub
Conclusion :
Je vous engage tous particulièrement à visiter mon site
http:// jeux.cartes@free.fr consacré aux réussites, et tout particulièrement à leurs développements... ; Vous y trouverez des exemples d'utilisation de Cards32.dll, de sa version 16 bits Cards.dll, et, bien sur, des sources de réussites utilisant Cards.OCX.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.