Solitario - Piramide con carte napoletane

Stato
Chiusa ad ulteriori risposte.

dracoscrigno

CioccaPiatti & VBA Expert
Expert
1 Maggio 2016
4.023
63
office pro 2010
57
Volevo allenarmi nell' uso delle classi e così mi sono messo ad implementare un classico solitario :)

Niente di tracendentale:

Le prime carte della piramide sono scopribili con un click ed eliminabili se, prese a due alla volta, fanno 10 punti. Sempre con un click
Dal mazzo coperto, con un doppio click, si scopre uan carta sul mazzo degli scarti.

Il mazzo degli scarti è selezionabile come le carte della pirabide.

In alto a sinistra c'è un pulsante con il quale ricominciare a giocare ed un numero sotto le carte coperte vi indica quante ve ne sono rimaste.
Un piccolo aiuto lo trovate, finendo il mazzo coperto. facendo doppio click ancora nel mazzo coperto senza carte, tutti gli scarti verranno riposizionati coperti...
Inutile dire che questo solitario è talmente odioso che viene una volta ogni tre morti di Papa. (a me una sola volta fino ad ora)

Eccovi uno screen:








Mi ha dato non poco filo da torcere e non credo di aver fatto un buon lavoro. c'è ancora molto da capire anche se molto ho gia compreso...
Spero vi venga voglia di darmi qualche consiglio a riguardo :)


Per fare funzionare il file allegato c'è bisogno di scaricare la cartella delle immagini che trovate qui:
immagini_carte
Questa cartella di immagini va messa nella stessa cartella dove sarà presente il file.slsm.
Lo sfondo del USerForm che, tra l' altro ho preso in rete come anche le carte :Muoi: è anche esso disponibile qui: Sfondo Userform

la macro che associa le immagini ai controlli è:

Codice:
'*************************************
'* Subroutine e function di servizio ***
'*****************************************
'----------------------------------------------------------
'Metodo Utilizzato per creare il mazzo di carte di partenza
Public Sub Z_SettaComeMazzoCompleto()
    Dim FileJpg As Object
    Dim Collezione As New Collection
    Dim Carta As clsCarta
    Dim i As Long
    
    If pCarte Is Nothing Then
        For[COLOR=#ff0000] Each[/COLOR] FileJpg In CreateObject("Scripting.FileSystemObject").GetFolder([SIZE=3][B][COLOR=#ff0000]ThisWorkbook.Path & "\Immagini_carte"[/COLOR][/B][/SIZE]).Files
            If Not InStr(1, FileJpg.Name,[B][COLOR=#ff0000] "jpg"[/COLOR][/B], vbTextCompare) = 0 Then
                If Val(FileJpg.Name) > 0 Then
                    Set Carta = New clsCarta
                    With Carta
                        .CreaNuovo _
                            Name:=[COLOR=#ff0000]FileJpg.Name[/COLOR], _
                            Valore:=Val([B][COLOR=#ff0000]FileJpg.Name[/COLOR][/B]), _
                            Seme:=Right(FileJpg.Name, Len([B][COLOR=#ff0000]FileJpg.Name[/COLOR][/B]) - [B][COLOR=#ff0000]2[/COLOR][/B]), _
                            ImmagineFronte:=LoadPicture([COLOR=#ff0000][B]FileJpg.Path[/B][/COLOR]), _
                            ImmagineDorso:=Tavolo.Image30.Picture
                    End With
                    Collezione.Add Item:=Carta, Key:=FileJpg.Name
                End If
            End If
        Next
        Set pCarte = Collezione
        'è stato definita convenzionalmente la prima carta del mazzo rivolto a carte scoperte
        'come la prima carta della collezione
        pMazzoScoperto = False
        Set pPrimaCarta = pCarte(pCarte.Count)
    End If
End Sub
Coem si può notare, il nome della cartella ed i nomi dei file JPG, sono determinanti per il funzionamento della procedura d' acquisizione.
nella cartella delle carte ci devono essere solo le 40 immagini delle carte.
nominate secondo la regola:

Valore & Seme
dove valore è un numero compreso tra 1 e 40 formato SEMPRE da due cifre.
Seme è uno dei quattro semi (denari, bastoni, spade, coppe)

Ma ripeto... quest aè la caortella con le immagini rinominate: immagini_carte


Nella speranza vi venga volgia di darmi qualche dritta mentre vi passate un pò il tempo; eccovi il file :)

Modulo del Form: Tavolo
Codice:
Option Explicit


'Collezione contenente tutti i mazzi in gioco
'- MazzoCoperto: il mazzo iniziale, completo di tutte le carte, poi defalcato di quelle che gli vengono
'  tolte a formare glia ltri mazzi durante la partita.
'- MAzzoScarti: il mazzo dove fluiscono tutte le carte, ad una ad una, defalcate dal mazzo completo,
'  Come aiuto alla soluzione del solitario
'- I 28 mazzi della piramide, ogni uno formato di una sola carta e disposti, appunto a piramide,
'  su sette file crescenti da 1 a 7 posizioni.
Private MazziPiramide As New Collection


Private MazzoCoperto As clsMazzo
Private MazzoScarti As clsMazzo
Private Mazzo As clsMazzo
Private WithEvents Memo As clsMemo


Private Sub UserForm_Initialize()
    Set Memo = New clsMemo
    Set MazzoCoperto = New clsMazzo
    Dim ControlImage As MSForms.Image
    Dim Fila As Long
    Dim Pos As Long
    Dim i As Long
    
    'Creazione del mazzo di carte
    With MazzoCoperto
        'assegnazione del controllo, dell' indice di posizione sul form e del memo.
        .Controllo Me.Image30, 30, Memo
        'Assegnazione delle caerte presenti nel foglio DB
        .Z_SettaComeMazzoCompleto
        'Mescolamento del mazzo
        .MescolaMazzo
    End With
    
    'Distribuzione delle 28 carte sul tavolo a formare la piramide
    For i = 1 To 28
        Set Mazzo = New clsMazzo
        Set ControlImage = New MSForms.Image
        'Creazione e posizionamento del controllo sul form
        Set ControlImage = Me.Controls.Add("Forms.Image.1", "Carta" & Trim(CStr(i)))
        With ControlImage
            .width = 66
            .height = 100
            .PictureSizeMode = fmPictureSizeModeStretch
            .BackStyle = fmBackStyleOpaque
            .SpecialEffect = fmSpecialEffectRaised
            'Calcolo della posizione della carta nella piramide
            Do
                Fila = Fila + 1
            Loop Until Sommatoria(Fila) >= i
            Pos = i - Sommatoria(Fila - 1)
            
            .Left = (Me.width / 2) - ((.width + 5) * (Fila - Pos + 1)) + ((.width + 5) / 2 * Fila)
            .Top = 50 + Fila ^ 2 + Fila
            Fila = 0
            Pos = 0
        End With
        With Mazzo
            .Controllo ControlImage, i, Memo
            Set .AddCarta = MazzoCoperto.GetCarta
        End With
        MazzoCoperto.RemoveCarta
        MazziPiramide.Add Mazzo, CStr(i)
    Next
    
    'Disposizione della prima carta scoperta nel mazzo degli scarti
    Set MazzoScarti = New clsMazzo
    With MazzoScarti
        .MazzoScoperto = True
        .Controllo Me.Image29, 29, Memo
        Set .AddCarta = MazzoCoperto.GetCarta
    End With
    MazzoCoperto.RemoveCarta
    
    'riferimento al mazzo degli scarti memorizzato nel memo
    Set Memo.MazzoScarti = MazzoScarti
    'Caption della label sotto al mazzo coperto indicante le carte ancora presenti
    Me.lblCoperto.Caption = MazzoCoperto.Count
End Sub




Private Sub Image30_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If Not MazzoCoperto.GetCarta Is Nothing Then
        Memo.VuotaMemo
        Memo.PutMemo Me.Image29, MazzoCoperto.GetCarta
        Set MazzoScarti.AddCarta = MazzoCoperto.GetCarta
        MazzoCoperto.RemoveCarta
        With Image30
            .Visible = False
            .Visible = True
        End With
        With Image29
            .Visible = False
            .Visible = True
        End With
        If MazzoCoperto.Count = 0 Then
            Me.Image30.BackStyle = fmBackStyleTransparent
        End If
    Else
        Dim i As Long
        For i = 1 To MazzoScarti.Count
            Set MazzoCoperto.AddCarta = MazzoScarti.GetCarta
            MazzoScarti.RemoveCarta
        Next
        Me.Image30.BackStyle = fmBackStyleOpaque
        Me.Image29.BackStyle = fmBackStyleTransparent
    End If
    Me.lblCoperto.Caption = MazzoCoperto.Count
End Sub
Private Sub Image29_Click()
    Me.lblCoperto.Caption = MazzoCoperto.Count
End Sub


Private Sub CommandButton1_Click()
    If MsgBox("Scegliendo ""SI"" Il gioco verrà riinizializzato e perderai tutti i progressi" & vbCrLf & _
                "Sei sicuro di voler procedere?", vbCritical + vbQuestion + vbYesNo, "Riprendi dall' inizio") = vbYes Then
        Unload Me
        Tavolo.Show
    End If
End Sub


Private Function Sommatoria(Max As Long, Optional min As Long = 1) As Long
    If Not Max = 0 Then
        Sommatoria = Max + Sommatoria(Max - 1)
    End If
End Function
Private Sub Memo_MazzoScartiNONvuoto()
    Me.Image29.BackStyle = fmBackStyleOpaque
End Sub
Private Sub Memo_MazzoScartiVuoto()
    Me.Image29.BackStyle = fmBackStyleTransparent
End Sub
Modulo Standard: mdlServizi
Codice:
Sub prova()
Tavolo.Show
End Sub
Modulo di classe: clsCarta
Codice:
Option Explicit


Public Event PictureGet(ImmagineRestituita As Object)


Private pName As String
Private pValue As Long
Private pSeme As String
Private pImgDorso As Object
Private pImgFront As Object


Public Property Get Name() As String
   Name = pName
End Property
Public Property Get Value() As Long
    Value = pValue
End Property
Public Property Get Seme() As String
   Seme = pSeme
End Property
Public Property Get Picture(Optional CartaScoperta As Boolean = False) As Object
    Dim pPicture As Object
    If CartaScoperta Then
        Set pPicture = pImgFront
    Else
        Set pPicture = pImgDorso
    End If
    Set Picture = pPicture
    RaiseEvent PictureGet(pPicture)
End Property


Public Sub CreaNuovo(Name As String, Valore As Long, Seme As String, ImmagineFronte As Object, ImmagineDorso As Object)
    pName = Name
    pValue = Valore
    pSeme = Seme
    Set pImgFront = ImmagineFronte
    Set pImgDorso = ImmagineDorso
End Sub
Modulo di classe: clsMAzzo
Codice:
Option Explicit


' VAriabili rlative al controllo sul form
Private WithEvents pControllo As MSForms.Image  'recepito in fase iniziale
Private pIndex As Long      'recepito in fase iniziale, è il numero di indice del controllo
Private pFila As Long       'calclato da pIndex
Private pPos As Long        'Calcolato da pIndex
'variabili relative al mazzo di carte
Private WithEvents pPrimaCarta As clsCarta  'Calcolato da pCarte
Private pCarte As Collection 'recepito in fase iniziale e modificato dai metodi .Add e .Remove
Private pMazzoScoperto As Boolean   'recepito in fase iniziale e modificabile
'Variabile che fa riferimento alla variabile Memo sul form
Public pMemo As clsMemo 'in fase iniziale viene referenziata al memo del userform
 
Public Property Get Index() As Long
    Index = pIndex
End Property
Public Property Get Fila() As Long
    Fila = pFila
End Property
Public Property Get Pos() As Long
    Pos = pPos
End Property
Public Property Let MazzoScoperto(Value As Boolean)
    pMazzoScoperto = Value
End Property
Public Property Get Count() As Long
    Count = pCarte.Count
End Property
Public Property Get GetCarta() As clsCarta
    If pCarte.Count > 0 Then
        If pMazzoScoperto Then
            Set GetCarta = pCarte(1)
        Else
            Set GetCarta = pCarte(pCarte.Count)
        End If
    End If
End Property
Public Property Set AddCarta(Value As clsCarta)
    If Not pCarte Is Nothing Then
        If pCarte.Count > 0 Then
            If pMazzoScoperto Then
                pCarte.Add Item:=Value, Key:=Value.Name, before:=1
            Else
                pCarte.Add Item:=Value, Key:=Value.Name, after:=pCarte.Count
            End If
        Else
            pCarte.Add Value, Value.Name
        End If
    Else
        Set pCarte = New Collection
        pCarte.Add Value, Value.Name
    End If
    Set pPrimaCarta = Value
    Set pControllo.Picture = pPrimaCarta.Picture(pMazzoScoperto)
End Property


Public Sub Controllo(FrmImageControl As MSForms.Image, IndexValue As Long, Memo As clsMemo)
    Set pControllo = FrmImageControl
    pIndex = IndexValue
    Do
       pFila = pFila + 1
    Loop Until Sommatoria(pFila) >= IndexValue
    pPos = IndexValue - Sommatoria(Fila - 1)
    Set pMemo = Memo
End Sub


Public Sub RemoveCarta()
    If pCarte.Count > 0 Then
        If pMazzoScoperto Then
            pCarte.Remove (1)
        Else
            pCarte.Remove (pCarte.Count)
        End If
    End If
    If pCarte.Count > 0 Then
        If pMazzoScoperto Then
            Set pPrimaCarta = pCarte(1)
        Else
            Set pPrimaCarta = pCarte(pCarte.Count)
        End If
        Set pControllo.Picture = pPrimaCarta.Picture(pMazzoScoperto)
    Else
        Set pControllo.Picture = Nothing
    End If
End Sub




Private Sub pControllo_Click()
    If pIndex = 30 Then Exit Sub
    
    If pMazzoScoperto Then
        'Carte scoperte che possono essere selezionate ed essere eliminate dalla piramide
        If pPrimaCarta.Value = 10 Then
            ScartiSulTavolo pPrimaCarta.Picture(True)
            If pIndex = 29 Then
                pMemo.Scarta
                'pMemo.VuotaMemo
            Else
                pControllo.Visible = False
            End If
        ElseIf pMemo.e_Nothing Then
            pMemo.PutMemo pControllo, pPrimaCarta
        Else
            If pMemo.Carta.Value + pPrimaCarta.Value = 10 And pMemo.Carta.Name <> pPrimaCarta.Name Then
                'Elimina le carte dal gioco
                ScartiSulTavolo pPrimaCarta.Picture(True)
                ScartiSulTavolo pMemo.Carta.Picture(True)
                If pMemo.Controllo.Name = "Image29" Then


                    pControllo.Visible = False
                    pMemo.Scarta
                ElseIf pControllo.Name = "Image29" Then
                    pMemo.Controllo.Visible = False
                    pMemo.Scarta
                Else
                    pMemo.Controllo.Visible = False
                    pControllo.Visible = False
                End If
                pMemo.VuotaMemo
            Else
                pMemo.VuotaMemo
                pMemo.PutMemo pControllo, pPrimaCarta
            End If
               
        End If
    Else
        If pIndex >= 22 Then
            pMazzoScoperto = True
            'Carte appartenenti alla settima fila che poosno, quindi, essere scoperte
            Set pControllo.Picture = pPrimaCarta.Picture(pMazzoScoperto)
            pMemo.VuotaMemo
            pMemo.PutMemo pControllo, pPrimaCarta
        Else
            If pControllo.Parent.Controls("carta" & pIndex + Fila).Visible = False And pControllo.Parent.Controls("carta" & pIndex + Fila + 1).Visible = False Then
                pMazzoScoperto = True
                Set pControllo.Picture = pPrimaCarta.Picture(pMazzoScoperto)
                pMemo.VuotaMemo
                pMemo.PutMemo pControllo, pPrimaCarta
            Else
                'Carta coperta che non può essere scoperta perchè ne ha altre sopra di essa
                'Stop
            End If
        End If
    End If
End Sub




Private Sub pPrimaCarta_PictureGet(ImmagineRestituita As Object)
    'pControllo.Parent.Repaint
    If pControllo.Visible = True Then
        pControllo.Visible = False
        pControllo.Visible = True
    End If
End Sub


'*************************************
'* Subroutine e function di servizio ***
'*****************************************
'----------------------------------------------------------
'Metodo Utilizzato per creare il mazzo di carte di partenza
Public Sub Z_SettaComeMazzoCompleto()
    Dim FileJpg As Object
    Dim Collezione As New Collection
    Dim Carta As clsCarta
    Dim i As Long
    
    If pCarte Is Nothing Then
        For Each FileJpg In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Immagini_carte").Files
            If Not InStr(1, FileJpg.Name, "jpg", vbTextCompare) = 0 Then
                If Val(FileJpg.Name) > 0 Then
                    Set Carta = New clsCarta
                    With Carta
                        .CreaNuovo _
                            Name:=FileJpg.Name, _
                            Valore:=Val(FileJpg.Name), _
                            Seme:=Right(FileJpg.Name, Len(FileJpg.Name) - 2), _
                            ImmagineFronte:=LoadPicture(FileJpg.Path), _
                            ImmagineDorso:=Tavolo.Image30.Picture
                    End With
                    Collezione.Add Item:=Carta, Key:=FileJpg.Name
                End If
            End If
        Next
        Set pCarte = Collezione
        'è stato definita convenzionalmente la prima carta del mazzo rivolto a carte scoperte
        'come la prima carta della collezione
        pMazzoScoperto = False
        Set pPrimaCarta = pCarte(pCarte.Count)
    End If
End Sub


'-------------------------------------------------------------------------
'Funzione per rimescolare il mazzo di carte
Public Sub MescolaMazzo()
    Dim Mazzo As New Collection
    Dim min As Long
    Dim Max As Long
    Dim i As Long
    min = 1
    
    Do Until pCarte.Count = 0
        Max = pCarte.Count
        Randomize
        i = Int(Rnd() * (Max - min + 1) + min)
        Mazzo.Add pCarte(i), pCarte(i).Name
        pCarte.Remove (i)
    Loop
    Set pCarte = Mazzo
End Sub
'-------------------------------------------------------------------------
'Funzione utilie per estrarre la posizione della carta nella piramide
Private Function Sommatoria(Max As Long, Optional min As Long = 1) As Long
    If Not Max = 0 Then
        Sommatoria = Max + Sommatoria(Max - 1)
    End If
End Function


Private Sub ScartiSulTavolo(Picture As Object)
    With pControllo.Parent.Controls.Add("Forms.Image.1", , True)
        Randomize
        .Top = Int(Rnd(Rnd()) * (230 - 220 + 1) + 220)
        Randomize
        .Left = Int(Rnd(Rnd()) * (480 - 430 + 1) + 430)
        .width = 66
        .height = 100
        .PictureSizeMode = fmPictureSizeModeStretch
        Set .Picture = Picture
    End With
End Sub
Modulo di classe: clsMemo
Codice:
Option Explicit


Public Event MazzoScartiVuoto()
Public Event MazzoScartiNONvuoto()


Private pControllo As MSForms.Image
Private pMazzoScarti As clsMazzo
Private pCarta As clsCarta
Private pValue As Long
Private pSeme As String


Public Property Set MazzoScarti(Value As clsMazzo)
    Set pMazzoScarti = Value
End Property
Public Property Get MazzoScarti() As clsMazzo
    Set MazzoScarti = pMazzoScarti
End Property
Public Property Get e_Nothing() As Boolean
        e_Nothing = pControllo Is Nothing
End Property
Public Property Get Controllo() As MSForms.Image
    Set Controllo = pControllo
End Property
Public Property Get Carta() As clsCarta
    Set Carta = pCarta
End Property


Public Sub PutMemo(ControlloAssociato As MSForms.Image, CartaMemorizzata As clsCarta)
    Set pCarta = CartaMemorizzata
    Set pControllo = ControlloAssociato
    With pControllo
        .width = .width + 10
        .Left = .Left - 5
        .height = .height + 10
        .Top = .Top - 5
    End With
End Sub
Public Sub VuotaMemo()
    pSeme = ""
    pValue = 0
    If Not pControllo Is Nothing Then
        With pControllo
            .width = .width - 10
            .Left = .Left + 5
            .height = .height - 10
            .Top = .Top + 5
        End With
        Set pControllo = Nothing
    End If
End Sub
Public Sub Scarta()
    pMazzoScarti.RemoveCarta
    If pMazzoScarti.Count = 0 Then
        RaiseEvent MazzoScartiVuoto
    Else
        RaiseEvent MazzoScartiNONvuoto
    End If
End Sub


Buon divertimento :)
 

Allegati

A.Maurizio

Utente abituale
16 Agosto 2015
383
16
Torino
2007
0
Complimenti DracoScrigno Bellossimo Lavoro di Pazzienza oltre che di Abilità nel mettre in sieme il Codice Grazie D'esistere ciao da A.Maurizio
 

dracoscrigno

CioccaPiatti & VBA Expert
Expert
1 Maggio 2016
4.023
63
office pro 2010
57
grazie Simbadimba.
con vba, si può fare praticamente tutto quello che si può fare con qualsiasi altro linguaggio di programmazione.
le limitazioni, sono veramente poche anche se, una di queste, è alquanto sgradevole: sotto a tutto l impalco che costruisci ci deve essere obbligatoriamente (in questo caso è Excel) l applicazione che fa girare VBA.

il programmino qui presentato, che, tra l altro non è implementato nel migliore dei modi e se dovessi rifarlo, probabilmente seguirei altre strade, è stato solo un esercizio per tenermi allenato nell uso di oggetti creati dall utente attraverso l implementazione delle classi che li rappresentano.
esse sono molto utili per il riutilizzo del codice gia scritto e per mantenere un certo ordine logico che non è di poco aiuto nell atto del programmare.
 
Stato
Chiusa ad ulteriori risposte.

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!