Přeskočit navigaci | Přeskočit na novinky
     

Jste zde: Úvodní stránka » excel » ostatni » Tetris-jak-vytvorit-Excel-VBA
Microsoft Excel logo

Tetris - jak vytvořit v Excel VBA

Videokurzy Excel

Ve spolupráci se SEDUO jsem vytvořil několik videokurzů:

Vytvořte si Tetris využitím Excel a VBA. V tomto článku kostičky rozpohybujeme.

Pokračování předchozího článku, kde máte vytvořen základní koncept hry, kdy zbývá jen dodat kostičkám pohyb.

Předpokládám hotovou předlohu Tetrisu bez VBA a minimální znalost VBA.

Úvodem do Tetris

Vytvořit hru v Tetris (spíše hru velice podobnou Tetris) není vůbec problém (to už víte z předchozího článku), kde se vám kostičky pohybují pokud využíváte formulářová pole. V tomto článku jen přidáme pár VBA kódu a hru rozpohybujeme.

Protože článek je rozsáhlejší rozdělil jsme jej na kapitoly:


Jak vypadá příprava pro VBA

Pokud máte hotovo (více v předchozím článku). Máte připraveno pro programování VBA.

TETRIS v Excel - příprava pro VBA.

Dejme tedy kostičky do pohybu.

Tip

Na pomocné buňky můžete využít pojmenované odkazy.

Rozpohybovat

Začneme základem, potřebuji po kliku na tlačítko Start Tetris zvyšovat číslo řádku (nebo snižovat) pro pohyb kostičky.

Inspiroval jsem se na StackOwerflow, pokud se budete chtít dozvědět více, Googlete. Kód se skládá ze tří části, které umístěte do Modulu.

Option Explicit ' potřeba nadefinovat jinak někdy nejde zastavit Timer Dim RunTime ' První startovací část Sub StartTetris() ' vypnutí překreslování obrazovky Application.ScreenUpdating = False ' zajistí přepočet funkcí ActiveWorkbook.RefreshAll RunTime = Now + TimeValue("00:00:01") ' zavolá co se bude provádět (přičítat hodnota atd.) Application.OnTime RunTime, "RefreshTime" 'zapnutí překreslování obrazovky Application.ScreenUpdating = True End Sub Sub StopTetris() ' ošetření chybového stavu On Error Resume Next Application.OnTime RunTime, "RefreshTime", Schedule:=False ' vynulování případné chyby On Error GoTo 0 End Sub Sub TetrisPrepocet() Application.ScreenUpdating = False ' Zde se budou posouvat kostička a kontrolovat další věci Sheets("Tetris").Range("BW6").Value = Sheets("Tetris").Range("BW6").Value - 1 ' BW6 .. v teto buňce se posouvá kostička dolů ' Tetris máte umístěn v liste Tetris ' Spustí časovač pro Tetris StartTetris Application.ScreenUpdating = True End Sub

V modulu máte a teď potřebujete spouštět, proto stačí přidat dvě tlačítka na list s hrou Tetris.

  • Start Tetris
  • Stop Tetris

Tlačítka doplníte o spouštění Sub procedur přes Call.

Call StartTetris Call StopTetris

Pokud po kliku na Start se začne číslo v buňce BW6 zmenšovat (kostička padá), máte vyhráno. Doděláte pohyb, pár podmínek a hra je hotova.

Pohyb vpravo vlevo

Přidejte tlačítko, kód pro jednoduchost přidám přímo do tlačítka, ale klidně v modulech si přidejte nový modul pro pohyb a pak volejte příslušnou Proceduru.

Vyzkouším pohyb, za předpokladu že v buňce BV7 je pozice vlevo/vpravo a v buňce BX30 se kontroluje kostička:

' posun vlevo na příkaz Sheets("Makra").Range("BV7").Value = Sheets("Makra").Range("BV7").Value - 1

Funguje? Doplním o kontrolu, zda je kostička (nebo kostičky) v kolizi (neboli Excel vidí v hrací ploše K). Tím pádem vím že musím přičíst řádek (kostička nesmí zasahovat do již existujících kostiček). No a pak ještě provedu kontrolu, zda nejsem moc vpravo, že by kostička nebyla celá.

Samozřejmě dočasně vypnu Timer a budu mít vypnuto překreslování. Po provedení opět zapnu překreslování i Timer.

' překreslování Application.ScreenUpdating = False ' zastavim timer Call StopTimer ' posun vlevo na příkaz Sheets("Makra").Range("BV7").Value = Sheets("Makra").Range("BV7").Value - 1 ' Kontrola zda je kolize kostička If Sheets("Makra").Range("BX30").Value >= 1 Then Range("BV7").Value = Range("BV7").Value + 1 End If ' kontrola vlevo If Sheets("Makra").Range("DG22").Value = 1 Then Range("BV7").Value = Range("BV7").Value + 1 End If ' pustim timer Call StartTimer ' prekreslování Application.ScreenUpdating = True

Stejným postupem provedete i pro opačný směr a máte pohyb vpravo a vlevo hotov.

V další vylepšení využiji pojmenované oblasti pro ony pomocné buňky.

Otáčení

Velice podobné jako posun, jen měníte buňku která je určena pro otáčení obrazce.

Otočením mohou nastat tři stavy, které musíte ošetřit:

  • jste vlevo a otočením kostička vyskočí z hrací plochy - já jsem nepovolil otočení
  • jste vpravo a otočením kostička vyskočí z hrací plochy - já jsem nepovolil otočení
  • narazíte do existujících kostiček - nepovolím otočení

můžete řeši i jinak posunout a povolot otočení pokud je možné atd. Já si to v prvním kroku zjednodušil.

' překreslování Application.ScreenUpdating = False ' zastavim timer Call StopTimer ' posun vlevo Range("BR8").Value = Range("BR8").Value + 1 ' okraje If Sheets("Makra").Range("DG22").Value = 1 Or Sheets("Makra").Range("DG23").Value = 1 Then Range("BR8").Value = Range("BR8").Value - 1 End If ' kolize s kostičkou If Sheets("Makra").Range("BX30").Value >= 1 Then Range("BR8").Value = Range("BR8").Value - 1 End If ' pustim timer Call StartTimer ' prekreslování Application.ScreenUpdating = True

Uložení kostky po kolizí/dopadu

Kostka spadla a před spuštěním nové kostičky, musím její pozici zaznamenat.

Vím v které pomocné oblasti mám onu padající kostičku a v které pomocné oblasti mám už spadné kostičky. No a tu spadlou ostičku přičtu do pomocné oblasti ve které sjosu spadlé kostičky

Sub SlouciPevnePadajiciKostky() Application.ScreenUpdating = False ' pozice kde se nachází pomocné oblasti ' 11, 89 až 28,98 ' 11, 100 až 28 109 Dim i As Integer Dim j As Integer For i = 11 To 28 For j = 89 To 98 ' slucuji kostky ' MsgBox (Sheets("Makra").Cells(i, j + 11).Value & " " & Sheets("Makra").Cells(i, j).Value) If Sheets("Makra").Cells(i, j).Value + Sheets("Makra").Cells(i, j + 11).Value = 0 Then Sheets("Makra").Cells(i, j).Value = "" Else Sheets("Makra").Cells(i, j).Value = Sheets("Makra").Cells(i, j).Value + Sheets("Makra").Cells(i, j + 11).Value ' !!! vrátit rovnici Sheets("Makra").Cells(i, j + 11).FormulaR1C1 = "=IF(OR(RC[-43]=R11C70,RC[-43]=R12C70,RC[-43]=R13C70,RC[-43]=R14C70),R5C70,0)" End If Next j Next i Application.ScreenUpdating = True End Sub

V další vylepšení využiji pojmenované oblasti.

Smazání pokud doplním řadu

Tetris je o tom, že plná řada se smaže, proto máme pomocí klasických funkcí spočteno zda jde o plnou řadu a pokud ano příslušná buňka obsahuje slovo smaž. Skript projde sloupec a pokud řádek slovo smaž obsahuje, tak jej smaže a zároveň obsah buněk, co jsou nad tímto řádkem posune o jedničku dolů. Tak to provede od prvního do posledního řádku (chápu že max počet mazaných řádku může být 4 a mohu si čás provádění ušetřit, ale na to se podíváme u vylepšení).

Sub SmazCeleRadky() Application.ScreenUpdating = False Dim i As Integer ' v i od ktarého řádku po který For i = 28 To 12 Step -1 'pokud smaz, kontroluji příslušná sloupec 87 If Sheets("Makra").Cells(i, 87).Value = "smaž" Then ' MsgBox (i) Sheets("Makra").Range(Cells(i, 89), Cells(i, 98)) = "" ' překopírovat buňky > 1) využiji nahrání makra a převezmu kus kódu ' ukázka kódu - jde dělat lépe a efektivněji Range(Cells(11, 89), Cells(i - 1, 98)).Select Application.CutCopyMode = False Selection.Copy Cells(12, 89).Select ActiveSheet.Paste End If ' posun Next i Application.ScreenUpdating = True End Sub

Tento kus kódu bude ještě bude vylepšen.

Nová kostička a její natočení

Po dopadu musíte zvolit novou kostičku a její natočení (můžete si zvolit i polohu od které se bude spouštět, posunutí vpravo vlevo). Tady je výhoda, že umístěni vpravo a vlevo bude napevno (v rozšíření vylepšíme).

'vyber obrazce a natočení a umístění Sheets("Makra").Range("BR5").Value = (WorksheetFunction.RandBetween(1, 7)) Sheets("Makra").Range("BR8").Value = (WorksheetFunction.RandBetween(0, 3)) ' umístění padající kostičky Sheets("Makra").Range("BW6").Value = 14 Sheets("Makra").Range("BV7").Value = 6

Ukončení hry

V posledních třech řadách kontroluji kolizi, pokud k ní dojde jde o konec hry. Pokud se objeví K v buňce DG27 bude slovo Konec.

If Sheets("Tetris").Range("DG27").Value = "konec" Then ' Informace, že jsme skončily hrát MsgBox ("Konec hry resetujte.") ' zároveň se ukončí Timer StopTimer Else ' ... ' co se bude dít mazaní řádku, nové kostky .... End If

Spojení do funkční hry

Stačí se jen odkázat na pomocné procedury, které mažou řádky a spadlou kostičku převádějí do pomocné hrací plochy a kontrolují konec hry a máte téměř hotovo.

Sub TetrisPrepocet() Application.ScreenUpdating = False ' pokud je ukoncena hra, tak ceká na reset If Sheets("Tetris").Range("DG27").Value = "konec" Then ' Informace, že jse skončily hrát MsgBox ("Konec hry resetujte.") StopTimer Else ' Docházi k přepisu čísla (neboli posun kostičky) Sheets("Tetris").Range("BW6").Value = Sheets("Tetris").Range("BW6").Value - 1 ' došlo ke kolizi musíme něco provést If Sheets("Tetris").Range("BX30").Value >= 1 Then StopTimer ' MsgBox ("kolize") ' vraceni kostičky o jednu polohu nahoru Sheets("Tetris").Range("BW6").Value = Sheets("Tetris").Range("BW6").Value + 1 ' MsgBox ("prevedeme na statické") ' spadlou kostku prevedeme na statickou Call SlouciPevnePadajiciKostky ' MsgBox ("smaz radky") ' smazu rádky Call SmazCeleRadky 'vyber obrazce a natočení a umístění Sheets("Tetris").Range("BR5").Value = (WorksheetFunction.RandBetween(1, 7)) Sheets("Tetris").Range("BR8").Value = (WorksheetFunction.RandBetween(0, 3)) Sheets("Tetris").Range("BW6").Value = 14 Sheets("Tetris").Range("BV7").Value = 6 End If StartTimer End If Application.ScreenUpdating = True End Sub

Reset hry

Reset hry je jednoduchý, jen se vymaže pomocná hrací plocha s napadanými kostičkami. Nemít toho tlačítko, tak si zahrajete jen jednou ;)

' Reset hry Sheets("Makra").Range("CL11:CV28").Value = ""

Ať můžete hrát znova.

Hotovo

Funguje? Gratulace, vaše hra Tetris je na světě.

Stačí skrýt pomocné sloupce a můžete hrát.

TETRIS v Excel -

Vím hra není dokonalé a je potřeba jí ještě vylepšit a zdokonalit. Což bude předmětem dalšího článku.

Související články

Související články:

Microsoft Excel VBA - stahuj logo

Ke stažení

Soubor v přípravě ke stažení zdarma. Soubor využívá makra.


V dalším článku

V následujícím článku si tuto hru vylepšíme počítání bodů, řad, následující kostička atd.

Článek byl aktualizován: 12.03.2019 09:09

Odměna

Ušetřil vám tento web čas, peníze? Pomohl vyřešit problém? Jste ochotni poskytnout symbolickou odměnu na další rozvoj? Vybrte si formu odměny, která vám vyhovuje.


Pavel Lasák - autor webu

Pavel Lasák

Microsoft Office (Word, Excel, Google tabulky, PowerPoint) se věnuji od roku 2000 (od 2004 na této doméně) - V roce 2017 jsem od Microsoft získal prestižní ocenění MVP (zatím jsem jediný z ČR v kategorií Excel). Své vědomosti a zkušenosti dávám k dispozici i on-line ve videích pro SEDUO. Ve firmách školím a konzultuji, učím na MUNI. Tento web již tvořím přes 15 let. Zdarma je zde přes 1.000 návodu, tipů a triků, včetně přes 250 různých šablon, sešitů.

   Pavel Lasák LinkedIn Profil    Pavel Lasák Google+ Profil    Pavel Lasák facebook Profil    Pavel Lasák twitter Profil


Komentáře zatím nejsou

Můžete být prvními co zanechají smysluplný komentář.






Excel


Sdílejte

Pomohl Vám návod?
Sdílejte na Facebooku, G+
LinkedIn...

Nové články


Reklama


TOPlist Licence Creative Commons webarchiv rss XML

Stránky o MS Office (Excel) produktu společnosti Microsoft. Neslouží jako technická podpora.
| Email na autora: pavel.lasak@gmail.com | Copyright © : Pavel Lasák 2004 - 2019 | 396

Tento web zatím neprošel jazykovou korekturou. Beta verze redakčního systému.