Excel – makro – kulička, do které se dá „cvrnknout“* Vyřešeno

[Francimour]

Zdravím,
mám prosbu! Mám za úkol udělat v Excelu pomoci makra a VBA obdélnik, ve kterem je náhodně daná kulička a do té se dá „cvrknout“ a ona se v obdélníku odrazi!Je to podle mého zadavatele tak na pět min. Já jsem nad tím strávil 14 dni a nic…
POMŮŽE MI NĚKDO?

// Četl jsi pravidla tohoto fóra?
// „Název tématu zvolte takový, aby co nejvýstižněji charakterizoval obsah tématu.“
// Nadpis „EXCEL“ je hodně nevýstižný, tvůj problém nepopisuje ani trochu.
// Název jsem opravil; příště vol vhodný název sám.
// Taktéž se snaž psát víc s diakritikou (i to jsem opravil), líp se to čte.
// Myloš

[Reklama]

[mike007]

Tvůj zadavatel je vtipálek. Za prvé makro a VBA je svým způsobem jedno a to samé. Makra se píší v jazyku Visual basic for applications, vyvinutý Microsoftem. Za druhé, takové makro se nedá napsat za pět minut. Je potřeba pořádně promyslet, jakým způsobem to bude pracovat a jak to bude v konečné fázi vypadat. Už jen toto zabere dost času. Nemluvě o napsání kódu, testování ...

Osobně bych dokázal toto napsat. Myslím, že i něco podobného jsem tehdy udělal, ale chce to pořádný kus času, který teď o vánocích bohužel nemám. Jsem rád, že sem na forum mohu alespoň nakouknout a napsat pár vět.

[Francimour]

hm tak to jsem v ri**:( me rekl ze to udela za prestavku... tak to nebude zapocet:( ale kdyby nekdo ZLATY mel na to cas ocenim kazdou pomoc dekuji

//Není potřeba citovat poslední příspěvek. Upraveno
//mike007

[navstevnik]

Tak asi dve hodiny vcetne testovani parametru, nize mas pouzitelny polotovar, ve kterem si dores vstup pro pozadovany smer vychoziho pohybu (goniometricke funkce). Kulicka cti zakon dopadu a odrazu.
Spustit proceduru SetObdelnikKulicka klavesovou zkratkou, ukonceni Ctrl+Break (muzes take doresit vcetne smazani obdelniku a kulicky). Pred dalsim spustenim "rucne" odstanit objekty obdelnik a kulicku, jinak se budou vrstvit!

Kód: Vybrat vše

Option Explicit

Dim Obd As Shape, Kul As Shape
Dim ObdLeft As Single, ObdTop As Single, ObdWidth As Single, ObdHeight As Single, ObdRight As Single, ObdBottom As Single
Dim KulLeft As Single, KulTop As Single, KulWidth As Single, KulHeight As Single, KulPrum As Single
Dim HorIncr As Single, VertIncr As Single, HorMove As Single, VertMove As Single

Sub SetObdelnikKulicka()
  ObdLeft = 100: ObdTop = 100: ObdWidth = 403: ObdHeight = 207: ObdRight = ObdLeft + ObdWidth: ObdBottom = ObdTop + ObdHeight
  KulPrum = 20: KulLeft = 150: KulTop = 150: KulWidth = KulPrum: KulHeight = KulPrum
  Set Obd = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ObdLeft, ObdTop, ObdWidth, ObdHeight)
  With Obd
    .Line.Visible = True  ' obvodova linka
    .Fill.Transparency = 0.5 ' pruhlednost
    .Fill.ForeColor.SchemeColor = 13  ' barva vyplne
  End With
  Set Kul = ActiveSheet.Shapes.AddShape(msoShapeOval, KulLeft, KulTop, KulWidth, KulHeight)
  With Kul
    .Line.Visible = True  ' obvodova linka
    .Fill.Transparency = 0 ' pruhlednost
    .Fill.ForeColor.SchemeColor = 10  ' barva vyplne
  End With
  ' ziskat pozadovany uhel: InputBox
  ' z pozadovaneho vychoziho uhlu vypocitat (goniometricke funkce) nasledujici parametry,
  ' zde demonstracni parametry:
  HorIncr = 1.25
  VertIncr = 0.75
  HorMove = 1
  VertMove = -1
  '***************
  MoveKulicka
End Sub
Sub MoveKulicka()
  Do
    With Kul
      ' pohyb kulicky
      .IncrementLeft HorIncr * HorMove
      .IncrementTop VertIncr * VertMove
      ' testovani dopadu a zmena smeru pohybu
      If .Top + KulPrum >= ObdBottom Then VertMove = -1
      If .Left + KulPrum >= ObdRight Then HorMove = -1
      If .Top <= ObdTop Then VertMove = 1
      If .Left <= ObdLeft Then HorMove = 1
    End With
    Delay
    DoEvents
  Loop
End Sub
Sub Delay()
  Dim t As Single
  t = Timer
  Do
    If Timer > t + 0.005 Then Exit Do
  Loop
End Sub

[mike007]

navstevnik: Moc hezká práce

[Francimour]

Děkuji!snad mi to alespoň nějak pomůže;)

[mike007]

Údajně nepomůže, když mě žádáš přes SZ o pomoc. Popros navstevnika, jestli by si pro tebe nenašel ještě kousek času a nedodělal ti to. Pokud ale máš něco za úkol, předpokládám, že Visual basic studuješ. Měl by si to tedy umět sám udělat. Proč by měl někdo za tebe dělat úkoly? Vysvětli mi to, prosím...
Výborné "nakopnutí" ti navstevnik připravil. Teď už si s tím stačí jen malinko pohrát a je hotovo.
Vždyť už tam chybí jen to cvrknutí...

[navstevnik]

V prilozenem souboru je doplneno to cvrnknuti.

[Francimour]

Ty si bůh!děkuji moc!!!Díky díky

[mike007]

Vyřešeno? Jestli ano, označ vlákno za vyřešené.

[navstevnik]

Prehanis, jinak doufam, ze se procedurou prokouses a bude ti to k uzitku pri zdolavani VBA. Podstane v tomto pripade je vyuziti znalosti matematiky, z VBA je spise jen zaklad.