Kirjautuminen

Haku

Tehtävät

Keskustelu: Koodit: VB6: Miinaharava

Sivun loppuun

hunajavohveli [24.10.2004 19:31:16]

#

Yksinkertainen miinaharava. Microsoftin versiossa käytetään kai CommandButtoneita, mutta havaitsin sen jostain syystä hidastavan kauheasti suoritusta, joten ruudukko tehdään ihan vain Linellä piirtämällä ja tarkistus hiiren koordinaattien perusteella. Jos avattu ruutu on harmaa, se tarkoittaa, ettei sen vieressä ole yhtään miinaa, vaan kaikki ympäröivät ruudut voi huoletta avata, ja ohjelma avaakin ne automaattisesti nyt, kun lisäsin rekursiivisen tarkistuksen. Oletetun miinan paikan voi merkitä hiiren oikealla näppäimellä. Merkinnän voi myös poistaa painamalla uudestaan.
Form_Loadista voi muuttaa ruudukon kokoa ja miinojen määrää. Formille ei tarvitse pistää mitään komponentteja.

Tuosta voi ladata käännetyn ohjelman: http://koodaa.mine.nu/~vohveli/miinaharava.exe

Option Explicit
Dim gLeft As Integer, gTop As Integer, gHor As Integer, gVer As Integer, gSize As Integer  'ruudukon tiedot
Dim xi As Integer, yi As Integer, vxi As Integer, vyi As Integer  'ruutu, jossa hiiri on
Dim Grid(-1 To 200, -1 To 200) As Boolean   'ruudussa miina -taulukko
Dim GridC(-1 To 200, -1 To 200) As Boolean   'ruutu avattu -taulukko
Dim ButtonDown As Boolean, GameOver As Boolean   'nappipohjassa ja peliohi -liput

Private Sub Form_Load()

Randomize
Form1.AutoRedraw = True
Form1.Width = 10000: Form1.Height = 10000   'ikkunan mitat
Form1.Caption = "Miinaharava by Hunajavohveli"
SetGrid 30, 30, InputBox("Ruutujen määrä vaakatasossa?"), InputBox("Ruutujen määrä pystytasossa?"), InputBox("Ruutujen koko pikseleinä? (oletus=25)"), InputBox("Montako miinaa?") 'Alustetaan (vasen, ylä, leveys, korkeus, ruutujen koko, miinat)

End Sub

Sub SetGrid(Left As Integer, Top As Integer, Hor As Integer, Ver As Integer, Size As Integer, Mines As Integer)
Dim i As Integer, x As Integer, y As Integer
Cls

Form1.ScaleMode = 3   'pikselit käyttöön

'vaakaviivat
For i = 0 To Hor
  Line (i * Size + Left, Top)-(i * Size + Left, Top + Ver * Size + 1)
Next i

'pystyviivat
For i = 0 To Ver
  Line (Left, i * Size + Top)-(Left + Hor * Size, i * Size + Top)
Next i

'ruudukon ominaisuudet muistiin
gLeft = Left: gTop = Top: gHor = Hor: gVer = Ver: gSize = Size

'arvotaan miinat ruudukkoon
For i = 1 To Mines
  Do
    x = Int(Rnd * gHor)
    y = Int(Rnd * gVer)
  DoEvents
  Loop Until Grid(x, y) = False   'ei saa arpoa samaan kohtaan useampaa
  Grid(x, y) = True
Next i

End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If GameOver Then Exit Sub   'jos peli ohi...

If xi >= 0 And yi >= 0 And xi < gHor And yi < gVer Then   'jos hiiri alueen sisällä
  If Button = 2 Then    'jos oikea näppäin
      If GridC(xi, yi) = False Then  'jos ruutua ei ole merkitty
        LightSquare xi, yi, Form1.BackColor
        GridPrint xi, yi, "X"   'merkitään miina
        GridC(xi, yi) = True   'nyt on merkitty
      Else    'jos on merkitty
        LightSquare xi, yi, Form1.BackColor
        GridC(xi, yi) = False   'poistetaan merkintä
      End If
    Exit Sub   'poistutaan
  End If
    ButtonDown = True
    If GridC(xi, yi) = False Then LightSquare vxi, vyi, RGB(200, 0, 0)  'korostetaan ruutua
End If

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If GameOver Then Exit Sub   'jos peli ohi...

If vxi >= 0 And vyi >= 0 And vxi < gHor And vyi < gVer Then
If GridC(vxi, vyi) = False Then LightSquare vxi, vyi, Form1.BackColor   'poistetaan ruudun korostus
End If

'lasketaan ruutu hiiren koordinaattien perusteella
CurrentX = 50
CurrentY = 50
xi = Int((x - gLeft) / gSize)
yi = Int((y - gTop) / gSize)

'korostetaan ruutua. jossa hiiri on
If xi >= 0 And yi >= 0 And xi < gHor And yi < gVer Then
If GridC(xi, yi) = False Then
  If ButtonDown Then
    LightSquare xi, yi, RGB(200, 0, 0)
  Else
    LightSquare xi, yi, RGB(0, 0, 140)
  End If
End If
End If

'muistiin edellinen kohta
vxi = xi
vyi = yi

End Sub
Sub LightSquare(x As Integer, y As Integer, col As Long)

'ruudun korostus
If x >= 0 And y >= 0 And x < gHor And y < gVer Then
Line (x * gSize + gLeft + 1, y * gSize + gTop + 1)-(x * gSize + gLeft + gSize - 1, y * gSize + gTop + gSize - 1), col, BF
End If

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If GameOver Then Exit Sub   'jos peli ohi...

If ButtonDown Then
  ButtonDown = False
If xi >= 0 And yi >= 0 And xi < gHor And yi < gVer Then  'jos alueen sisällä, avataan ruutu
  If Grid(xi, yi) = True Then ShowMines: Exit Sub  'jos ruudussa miina...
  CheckSquare xi, yi
End If
End If

End Sub

Sub GridPrint(x As Integer, y As Integer, Char As String)

Form1.ScaleMode = 4
Form1.CurrentX = x * 2.25 / 18 * gSize + gLeft / 8 + 0.7 / 18 * gSize
Form1.CurrentY = y * 1.125 / 18 * gSize + gTop / 16 + 0.2 / 18 * gSize
Form1.FontSize = 8 / 18 * gSize
Form1.FontBold = True
Form1.ForeColor = QBColor(Val(Char))

If Char = "0" Then    'jos ei miinoja ympärillä
  Form1.ScaleMode = 3
  LightSquare x, y, RGB(128, 128, 128)   'tummennetaan
Else
  Print Char    'näytetään numero
  Form1.ScaleMode = 3
End If

End Sub

Function Around(x As Integer, y As Integer)
Dim Am As Integer
'palauttaa ruudun ympärillä olevien miinojen määrän

If Grid(x - 1, y - 1) Then Am = Am + 1
If Grid(x, y - 1) Then Am = Am + 1
If Grid(x + 1, y - 1) Then Am = Am + 1
If Grid(x - 1, y) Then Am = Am + 1
If Grid(x + 1, y) Then Am = Am + 1
If Grid(x - 1, y + 1) Then Am = Am + 1
If Grid(x, y + 1) Then Am = Am + 1
If Grid(x + 1, y + 1) Then Am = Am + 1
Around = Am

End Function

Sub ShowMines()
Dim i As Integer, j As Integer
'näytetään miinat

Form1.ScaleMode = 4
Form1.FontSize = 8 / 18 * gSize
Form1.FontBold = True
Form1.ForeColor = 0

For j = 0 To gVer - 1
For i = 0 To gHor - 1
  Form1.CurrentX = i * 2.25 / 18 * gSize + gLeft / 8 + 0.7 / 18 * gSize
  Form1.CurrentY = j * 1.125 / 18 * gSize + gTop / 16 + 0.2 / 18 * gSize
  If Grid(i, j) Then Print "X"
Next i
Next j
GameOver = True

End Sub
Sub CheckSquare(x As Integer, y As Integer)

If Not (x >= 0 And y >= 0 And x < gHor And y < gVer) Then Exit Sub

GridC(x, y) = True      'merkitään ruutu avatuksi
LightSquare x, y, Form1.BackColor
GridPrint x, y, Around(x, y)   'tulostetaan ruudun numero
If Around(x, y) = 0 And GridC(x, y) Then
  If GridC(x - 1, y - 1) = False Then CheckSquare x - 1, y - 1
  If GridC(x, y - 1) = False Then CheckSquare x, y - 1
  If GridC(x + 1, y - 1) = False Then CheckSquare x + 1, y - 1
  If GridC(x + 1, y) = False Then CheckSquare x + 1, y
  If GridC(x + 1, y + 1) = False Then CheckSquare x + 1, y + 1
  If GridC(x, y + 1) = False Then CheckSquare x, y + 1
  If GridC(x - 1, y + 1) = False Then CheckSquare x - 1, y + 1
  If GridC(x - 1, y) = False Then CheckSquare x - 1, y
End If

End Sub

jrantala [27.10.2004 06:59:22]

#

Juuh, ihan näppärähän tää... :)

Meitsi [27.10.2004 11:13:44]

#

Just kova. Laitappa vielä ääniefektit!

Bill Keltanen [27.10.2004 15:34:52]

#

hiennno

hunajavohveli [28.10.2004 18:56:23]

#

Osaisin kyllä tehdä ääniefektien soittamisen, mutta itse niitä ääniä en kyllä tiedä, miten tekisin.
Voihan sitä yrittää itsekin tuohon soveltaa, jos vain hoksaa, missä kohdassa tehdään mitäkin. :)

tejeez [18.11.2004 19:10:36]

#

No ei mitään ääniturhamultimediaärsytyksiä tarvikaan. PÖÖ

hunajavohveli [18.11.2004 19:32:59]

#

Päivitin koodin. Lisäsin siihen rekursiivisen tarkistuksen, joten tyhjien ruutujen vieressä olevia ruutuja ei tarvitse enää itse avata.
Ja tästä saa nyt uuden version exenä.

Jakke1 [14.12.2007 20:45:05]

#

Meitsi kirjoitti:

Just kova. Laitappa vielä ääniefektit!

Laitappa itte, tämä on koodivinkki.

Kauan kirjoitit tuota koodia?


Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Tietoa sivustosta