(21/06/2010, 15:09)manyak_1903 yazdı: aga ödev hazırlıyorum bunun kodlarını bana verebilirmisin lütfen bana ulaşırsan sevinirim....
Siz bu gidişle biraz zor tamamlarsınız ödevinizi "AGA"
(21/06/2010, 19:41)BlackEagle yazdı:(21/06/2010, 15:09)manyak_1903 yazdı: aga ödev hazırlıyorum bunun kodlarını bana verebilirmisin lütfen bana ulaşırsan sevinirim....
Siz bu gidişle biraz zor tamamlarsınız ödevinizi "AGA"
Option Explicit
Private Sub Form_Load()
numCardsToDraw = 3
timingTheGame = True
keepingScore = True
Solitaire_New_Game
Solitaire_Render Me
End Sub
Private Sub Form_Mousedown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Solitaire_CheckMouseDown X, Y
Solitaire_Render Me
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Solitaire_CheckMouseMove X, Y
Solitaire_Render Me
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Solitaire_Render Me
End Sub
Private Sub Form_Terminate()
DeleteCardPics
End Sub
Private Sub Form_Unload(Cancel As Integer)
DeleteCardPics
End Sub
Private Sub Game_Timer_Timer()
If timingTheGame Then
time = time + 1
lblTime = "Time: " & time
End If
End Sub
Private Sub mnuDeck_Click()
Load frmDeckOptions
frmDeckOptions.Show
End Sub
Private Sub mnuExit_Click()
Unload Me
End Sub
Private Sub mnuNew_Click()
Solitaire_New_Game
End Sub
Private Sub mnuOptions_Click()
Load frmSolitaireOptions
frmSolitaireOptions.Show
End Sub
Modüle1
Option Explicit
Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32.dll" (ByVal hdcDest As Long, ByVal nXDest As Long, ByVal nYDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal dwRop As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Const CARD_WIDTH = 71
Public Const CARD_HEIGHT = 96
Type Rect
Top As Long
bottom As Long
left As Long
right As Long
End Type
Enum eSuit
SUIT_CLUBS = 0
SUIT_DIAMONDS = 1
SUIT_HEARTS = 2
SUIT_SPADES = 3
End Enum
Enum eValue
CARD_ACE = 1
CARD_TWO
CARD_THREE
CARD_FOUR
CARD_FIVE
CARD_SIX
CARD_SEVEN
CARD_EIGHT
CARD_NINE
CARD_TEN
CARD_JACK
CARD_QUEEN
CARD_KING
End Enum
Type tCardPic
hdc As Long
pic As StdPicture
End Type
Public screenWidth As Integer
Public screenHeight As Integer
Public offScreenDC As Long
Public offScreenBMP As Long
Public CardPics(0 To 51) As tCardPic
Public ErrorPic As tCardPic
Public DeckBacks(0 To 14) As tCardPic
Sub SetCardPics()
Dim hTempDC As Long
Dim i As Integer
hTempDC = GetDC(0)
For i = 0 To 51
Set CardPics(i).pic = New StdPicture
Set CardPics(i).pic = LoadPicture(App.Path & "\cards\" & i + 1 & ".bmp")
CardPics(i).hdc = CreateCompatibleDC(hTempDC)
Call SelectObject(CardPics(i).hdc, CardPics(i).pic.Handle)
Next
For i = 0 To 14
Set DeckBacks(i).pic = New StdPicture
Set DeckBacks(i).pic = LoadPicture(App.Path & "\Cards\Card backs\" & i + 1 & ".bmp")
DeckBacks(i).hdc = CreateCompatibleDC(hTempDC)
Call SelectObject(DeckBacks(i).hdc, DeckBacks(i).pic.Handle)
Next
Set ErrorPic.pic = New StdPicture
Set ErrorPic.pic = LoadPicture(App.Path & "\Cards\error!.bmp")
ErrorPic.hdc = CreateCompatibleDC(hTempDC)
Call SelectObject(ErrorPic.hdc, ErrorPic.pic.Handle)
ReleaseDC 0, hTempDC
End Sub
Public Sub offScreenSet()
Dim hTempDC As Long
Dim hOldBMP As Long
hTempDC = GetDC(0)
offScreenDC = CreateCompatibleDC(hTempDC)
offScreenBMP = CreateCompatibleBitmap(hTempDC, screenWidth, screenHeight)
hOldBMP = SelectObject(offScreenDC, offScreenBMP)
ReleaseDC 0, hTempDC
End Sub
Function SuitsAreOpposite(Card1 As clsCard, Card2 As clsCard) As Boolean
If (Card1.Suit = SUIT_CLUBS Or Card1.Suit = SUIT_SPADES) And (Card2.Suit = SUIT_DIAMONDS Or Card2.Suit = SUIT_HEARTS) Then
SuitsAreOpposite = True
Exit Function
End If
If (Card1.Suit = SUIT_DIAMONDS Or Card1.Suit = SUIT_HEARTS) And (Card2.Suit = SUIT_CLUBS Or Card2.Suit = SUIT_SPADES) Then
SuitsAreOpposite = True
Exit Function
End If
End Function
Sub DeleteCardPics()
Dim i As Integer
For i = 0 To 51
DeleteDC CardPics(i).hdc
DeleteObject CardPics(i).pic
Next
For i = 0 To 14
DeleteDC DeckBacks(i).hdc
DeleteObject DeckBacks(i).pic
Next
DeleteDC ErrorPic.hdc
DeleteObject ErrorPic.pic
End Sub
Modüle2
Option Explicit
Public numCardsToDraw As Integer
Public Score As Long
Public keepingScore As Boolean
Public timingTheGame As Boolean
Public time As Long
Dim bla4 As Boolean
Type tSelectedCard
card() As New clsCard
PosFrom As Integer
End Type
Type tPileCard
numCards As Integer
card() As New clsCard
End Type
Public GameDeck As New clsDeck
Public DispDeck As New clsDeck
Public GoalDeck(0 To 3) As New clsDeck
Public Pile(0 To 6) As New clsDeck
Public CardPile(0 To 6) As tPileCard
Public SelectedCard As tSelectedCard
Public NumSelected As Integer
Public CardIsSelected As Boolean
Sub Solitaire_New_Game()
Dim i As Integer, j As Integer
Randomize
CardIsSelected = False
NumSelected = 1
ReDim SelectedCard.card(NumSelected)
Score = 0
time = 0
frmSolitaire.lblTime.Caption = ""
If keepingScore Then
frmSolitaire.lblScore.Caption = "Score: 0"
Else
frmSolitaire.lblScore.Caption = ""
End If
SelectedCard.card(NumSelected).FacingUp = True
SelectedCard.PosFrom = -1
GameDeck.Initialize 52
GameDeck.Shuffle
DispDeck.Initialize 0, GameDeck.DeckBack
For i = 0 To 6
Pile(i).Initialize 0, GameDeck.DeckBack
Next
For i = 0 To 6
For j = 0 To i
Pile(i).AddCardToTop GameDeck.DrawCard
Next
CardPile(i).numCards = 1
ReDim CardPile(i).card(CardPile(i).numCards)
Set CardPile(i).card(0) = Pile(i).DrawCard
Next
For i = 0 To 3
GoalDeck(i).Initialize 0, GameDeck.DeckBack
Next
End Sub
Sub Solitaire_CheckMouseDown(ByVal X As Single, ByVal Y As Single)
Dim i As Integer, j As Integer, k As Integer
Dim done As Boolean, bla As Boolean, bla2 As Boolean, bla3 As Boolean
bla4 = False
If GameDeck.CheckClicked(X, Y) Then
If CardIsSelected = False Then
If GameDeck.m_NumCards = 0 Then
For i = 0 To DispDeck.m_NumCards - 1
GameDeck.AddCardToTop DispDeck.DrawCard
done = True
AddToScore -Score
Next
End If
If done = False Then
For i = 0 To numCardsToDraw - 1
If GameDeck.m_NumCards = 0 Then Exit For
DispDeck.AddCardToTop GameDeck.DrawCard
Next
DispDeck.NumToDraw = 3
End If
End If
End If
If DispDeck.CheckClicked(X, Y) Then
If CardIsSelected = False Then
If DispDeck.m_NumCards > 0 Then
NumSelected = 1
Set SelectedCard.card(0) = DispDeck.DrawCard
If DispDeck.NumToDraw > 1 Then DispDeck.NumToDraw = DispDeck.NumToDraw - 1
SelectedCard.PosFrom = 0
CardIsSelected = True
End If
Else
ReturnSelectedCard
End If
End If
For i = 0 To 3
If GoalDeck(i).CheckClicked(X, Y) Then
If CardIsSelected = True Then
If SelectedCard.PosFrom = 0 Or SelectedCard.PosFrom > 4 Then AddToScore 10
AddCardsToGoalDecks i
Else
If GoalDeck(i).m_NumCards > 0 Then
NumSelected = 1
ReDim SelectedCard.card(NumSelected)
SelectedCard.PosFrom = i + 1
Set SelectedCard.card(0) = GoalDeck(i).DrawCard
CardIsSelected = True
End If
End If
End If
Next
done = False
bla = True
bla2 = False
bla3 = False
For i = 0 To 6
If Pile(i).CheckClicked(X, Y) Then
If CardPile(i).numCards = 0 Then
If CardIsSelected = False Then
If Pile(i).m_NumCards > 0 Then
CardPile(i).numCards = 1
ReDim CardPile(i).card(CardPile(i).numCards)
Set CardPile(i).card(0) = Pile(i).DrawCard
CardPile(i).card(0).FacingUp = True
done = True
End If
Else
If SelectedCard.card(0).value = CARD_KING And Pile(i).m_NumCards = 0 And done = False Then
If SelectedCard.PosFrom = 0 Then AddToScore 5
If SelectedCard.PosFrom >= 1 And SelectedCard.PosFrom <= 4 Then AddToScore -15
AddCardsToPiles i
bla3 = True
Else
bla2 = True
ReturnSelectedCard
Exit For
End If
End If
End If
End If
Next
bla = False
For i = 0 To 6
For j = CardPile(i).numCards - 1 To 0 Step -1
If CardPile(i).card(j).Clicked(X, Y) Then
If CardIsSelected = False Then
If done = False And bla = False And bla2 = False And bla3 = False And bla4 = False Then
GetCardsFromPile i, j
End If
Exit For
Else
If CardPile(i).numCards > 0 Then
If (SuitsAreOpposite(SelectedCard.card(0), CardPile(i).card(CardPile(i).numCards - 1))) And (SelectedCard.card(0).value = CardPile(i).card(CardPile(i).numCards - 1).value - 1) Then
If SelectedCard.PosFrom = 0 Then
AddToScore 5
ElseIf SelectedCard.PosFrom >= 1 And SelectedCard.PosFrom <= 4 Then
AddToScore -15
End If
AddCardsToPiles i
Exit For
Else
ReturnSelectedCard
bla = True
Exit For
End If
End If
End If
End If
Next
Next
If GoalDeck(0).m_NumCards = 14 And GoalDeck(1).m_NumCards = 14 And GoalDeck(2).m_NumCards = 14 And GoalDeck(3).m_NumCards = 14 Then
MsgBox "Hurrah, you won.", , "Solitaire!"
Solitaire_New_Game
End If
End Sub
Sub Solitaire_CheckMouseMove(ByVal X As Single, Y As Single)
If CardIsSelected Then
SelectedCard.card(0).left = X - CARD_WIDTH / 2
SelectedCard.card(0).Top = Y - CARD_HEIGHT / 2
End If
End Sub
Sub Solitaire_Render(Form As Form)
Dim i As Integer, j As Integer
Dim DrawOffsetX As Integer, DrawOffsetY As Integer
DrawOffsetX = 2
DrawOffsetY = 15
frmSolitaire.Cls
Rectangle offScreenDC, 0, 0, screenWidth, screenHeight
GameDeck.Draw 10, 10, 2, 2, 5
DispDeck.Draw 100, 10, 15, 0, , True, True
For i = 0 To 3
GoalDeck(i).Draw 280 + 90 * i, 10, 1, 2, 5, True, True
Next
For i = 0 To 6
Pile(i).Draw 10 + 90 * i, 130, 2, 3, 7
Next
For i = 0 To 6
For j = 0 To CardPile(i).numCards - 1
CardPile(i).card(j).Draw (Pile(i).left + 2 * Pile(i).m_NumCards) + DrawOffsetX * j, (Pile(i).Top + 3 * Pile(i).m_NumCards) + DrawOffsetY * j
Next
Next
If CardIsSelected Then
For i = 0 To NumSelected - 1
SelectedCard.card(i).Draw SelectedCard.card(0).left + DrawOffsetX * i, SelectedCard.card(0).Top + DrawOffsetY * i
Next
End If
BitBlt Form.hdc, 0, 0, screenWidth, screenHeight, offScreenDC, 0, 0, vbSrcCopy
frmSolitaire.Refresh
End Sub
Private Sub ReturnSelectedCard()
Dim Index As Integer
If SelectedCard.PosFrom = 0 Then
DispDeck.AddCardToTop SelectedCard.card(0)
DispDeck.NumToDraw = DispDeck.NumToDraw + 1
CardIsSelected = False
ElseIf SelectedCard.PosFrom >= 1 And SelectedCard.PosFrom <= 4 Then
GoalDeck(SelectedCard.PosFrom - 1).AddCardToTop SelectedCard.card(0)
CardIsSelected = False
ElseIf SelectedCard.PosFrom >= 5 And SelectedCard.PosFrom <= 11 Then
Index = SelectedCard.PosFrom - 5
AddCardsToPiles Index
End If
CardIsSelected = False
End Sub
Private Sub AddCardsToGoalDecks(Index As Integer)
Dim ItsAllGood As Boolean
If NumSelected = 1 Then
If GoalDeck(Index).m_NumCards = 0 Then
If SelectedCard.card(0).value = CARD_ACE Then
ItsAllGood = True
GoalDeck(Index).AddCardToTop SelectedCard.card(0)
CardIsSelected = False
End If
Else
If SelectedCard.card(0).value = GoalDeck(Index).GetTopCard.value + 1 Then
If SelectedCard.card(0).Suit = GoalDeck(Index).GetTopCard.Suit Then
ItsAllGood = True
GoalDeck(Index).AddCardToTop SelectedCard.card(0)
CardIsSelected = False
End If
End If
End If
Else
ReturnSelectedCard
ItsAllGood = True
bla4 = True
End If
If ItsAllGood = False Then
ReturnSelectedCard
NumSelected = 0
Else
SelectedCard.PosFrom = Index + 1
End If
CardIsSelected = False
End Sub
Private Sub AddCardsToPiles(Index As Integer)
Dim i As Integer
For i = 0 To NumSelected - 1
CardPile(Index).numCards = CardPile(Index).numCards + 1
ReDim Preserve CardPile(Index).card(CardPile(Index).numCards)
Set CardPile(Index).card(CardPile(Index).numCards - 1) = SelectedCard.card(i)
Next
CardIsSelected = False
End Sub
Private Sub GetCardsFromPile(pileIndex As Integer, cardIndex As Integer)
Dim i As Integer, curIndex As Integer
curIndex = 0
SelectedCard.PosFrom = pileIndex + 5
NumSelected = CardPile(pileIndex).numCards - cardIndex
ReDim SelectedCard.card(NumSelected)
For i = cardIndex To CardPile(pileIndex).numCards - 1
Set SelectedCard.card(curIndex) = CardPile(pileIndex).card(i)
curIndex = curIndex + 1
Next
CardPile(pileIndex).numCards = CardPile(pileIndex).numCards - NumSelected
CardIsSelected = True
End Sub
Private Sub AddToScore(ByVal amount As Integer)
If keepingScore Then
Score = Score + amount
If Score < 0 Then Score = 0
frmSolitaire.lblScore.Caption = "Score: " & Score
End If
End Sub
ClassModüle1
Option Explicit
Public Top As Integer
Public bottom As Integer
Public left As Integer
Public right As Integer
Private cardIndex As Integer
Private m_Suit As eSuit
Private m_Value As eValue
Private m_FacingUp As Boolean
Property Get Card_Index()
Card_Index = cardIndex
End Property
Property Get Suit() As eSuit
Suit = m_Suit
End Property
Property Let Suit(value As eSuit)
m_Suit = value
cardIndex = m_Suit * 13 + m_Value - 1
End Property
Property Get value() As eValue
value = m_Value
End Property
Property Let value(CardValue As eValue)
m_Value = CardValue
cardIndex = m_Suit * 13 + m_Value - 1
End Property
Property Get FacingUp() As Boolean
FacingUp = m_FacingUp
End Property
Property Let FacingUp(value As Boolean)
m_FacingUp = value
End Property
Public Sub Draw(ByVal X As Integer, ByVal Y As Integer, Optional BackIndex As Integer = 0)
Top = Y
left = X
right = X + CARD_WIDTH
bottom = Y + CARD_HEIGHT
If cardIndex <> -1 Then
If (m_Value = 0) And (m_Suit = 0) Then
BitBlt offScreenDC, X, Y, CARD_WIDTH, CARD_HEIGHT, ErrorPic.hdc, 0, 0, vbSrcCopy
Else
If m_FacingUp Then
BitBlt offScreenDC, X, Y, CARD_WIDTH, CARD_HEIGHT, CardPics(cardIndex).hdc, 0, 0, vbSrcCopy
Else
BitBlt offScreenDC, X, Y, CARD_WIDTH, CARD_HEIGHT, DeckBacks(BackIndex).hdc, 0, 0, vbSrcCopy
End If
End If
End If
End Sub
Private Sub Class_Initialize()
m_FacingUp = True
End Sub
Public Function Clicked(ByVal X As Single, ByVal Y As Single) As Boolean
Clicked = False
If cardIndex <> -1 Then
If X >= left And X <= right And Y >= Top And Y <= bottom Then
Clicked = True
End If
End If
End Function
ClassModüle2
Option Explicit
Const NumCardsInADeck = 52
Public Top As Integer
Public bottom As Integer
Public left As Integer
Public right As Integer
Public DeckBack As Integer
Public NumToDraw As Integer
Public m_NumCards As Integer
Private m_Card() As New clsCard
Property Get card(Index As Integer) As clsCard
Set card = m_Card(Index)
End Property
Property Let card(Index As Integer, CardValue As clsCard)
Set m_Card(Index) = CardValue
End Property
Private Sub Class_Initialize()
Dim i As Integer
Dim currSuit As Integer, currValue As Integer
Randomize
currSuit = 0
currValue = 1
NumToDraw = 3
m_NumCards = NumCardsInADeck
DeckBack = Rnd * 11 + 1
ReDim m_Card(m_NumCards)
For i = 0 To m_NumCards - 1
m_Card(i).Suit = currSuit
m_Card(i).value = currValue
currValue = currValue + 1
If currValue > 13 Then
currValue = 1
currSuit = currSuit + 1
End If
If currSuit > 4 Then currSuit = 1
Next
End Sub
Public Sub Initialize(DeckSize As Integer, Optional theDeckBack As Integer = -1)
Dim i As Integer
Dim currSuit As Integer, currValue As Integer
Randomize
currSuit = 0
currValue = 1
m_NumCards = DeckSize
If theDeckBack = -1 Then
DeckBack = Rnd * 9 + 2
Else
DeckBack = theDeckBack
End If
ReDim m_Card(m_NumCards)
For i = 0 To m_NumCards - 1
m_Card(i).Suit = currSuit
m_Card(i).value = currValue
currValue = currValue + 1
If currValue > 13 Then
currValue = 1
currSuit = currSuit + 1
End If
If currSuit > 4 Then currSuit = 1
Next
End Sub
Public Sub Shuffle()
Dim i As Integer
Dim Temp As Integer
Dim used() As Boolean
Dim tempCards() As New clsCard
Dim ShuffleCount As Integer
ReDim used(m_NumCards)
ReDim tempCards(m_NumCards)
For i = 0 To m_NumCards - 1
tempCards(i).Suit = m_Card(i).Suit
tempCards(i).value = m_Card(i).value
Next
For i = 0 To m_NumCards - 1
Temp = Int(Rnd * m_NumCards)
Do While used(Temp) = True
Temp = Int(Rnd * m_NumCards)
Loop
m_Card(i).Suit = tempCards(Temp).Suit
m_Card(i).value = tempCards(Temp).value
used(Temp) = True
Next
End Sub
Public Sub Draw(X As Integer, Y As Integer, OffsetX As Integer, OffsetY As Integer, Optional theNumToDraw As Integer = -1, Optional FacingUp As Boolean = False, Optional TopCardFacingUp As Boolean = False)
Dim DrawPosX As Integer, DrawPosY As Integer, i As Integer
DrawPosX = X
DrawPosY = Y
If NumToDraw < 0 Then NumToDraw = 0
If theNumToDraw <> -1 Then NumToDraw = theNumToDraw
Top = Y
left = X
right = X + OffsetX * NumToDraw + CARD_WIDTH
bottom = Y + OffsetY * NumToDraw + CARD_HEIGHT
If m_NumCards = 0 Then
BitBlt offScreenDC, DrawPosX, DrawPosY, 71, 96, DeckBacks(0).hdc, 0, 0, vbSrcCopy
Exit Sub
End If
If NumToDraw > m_NumCards Then NumToDraw = m_NumCards
For i = m_NumCards - NumToDraw To m_NumCards - 1
If i = m_NumCards - 1 Then
m_Card(i).FacingUp = TopCardFacingUp
Else
m_Card(i).FacingUp = FacingUp
End If
m_Card(i).Draw DrawPosX, DrawPosY, DeckBack
DrawPosX = DrawPosX + OffsetX
DrawPosY = DrawPosY + OffsetY
Next
End Sub
Function DrawCard() As clsCard
If m_NumCards > 0 Then
m_NumCards = m_NumCards - 1
Set DrawCard = m_Card(m_NumCards)
End If
End Function
Public Sub KillTopCard()
If m_NumCards > 0 Then
m_NumCards = m_NumCards - 1
'ReDim Preserve m_Card(m_NumCards)
End If
End Sub
Public Sub KillCards(StartIndex As Long, Optional EndIndex As Integer = 1)
Dim i As Long
For i = StartIndex To EndIndex
m_Card(i) = m_Card(i + 1)
Next
m_NumCards = m_NumCards - EndIndex - StartIndex + 1
ReDim Preserve m_Card(m_NumCards)
End Sub
Function GetTopCard() As clsCard
If m_NumCards > 0 Then
Set GetTopCard = m_Card(m_NumCards - 1)
End If
End Function
Sub AddCardToTop(card As clsCard)
m_NumCards = m_NumCards + 1
ReDim Preserve m_Card(m_NumCards)
Set m_Card(m_NumCards - 1) = card
End Sub
Function CheckClicked(ByVal X As Single, ByVal Y As Single) As Boolean
CheckClicked = (X >= left And X <= right And Y >= Top And Y <= bottom)
End Function