4k - SystemMemory

    Diese Seite verwendet Cookies. Durch die Nutzung unserer Seite erklären Sie sich damit einverstanden, dass wir Cookies setzen. Weitere Informationen

    Unsere Datenschutzerklärung wurde aktualisiert. Mit der Nutzung unseres Forums akzeptierst Du unsere Datenschutzerklärung. Du bestätigst zudem, dass Du mindestens 16 Jahre alt bist.

    • 4k - SystemMemory

      Hallo zusammen, hier mein bescheidenes Progrämmchen;). ...ein wenig getrödelt (wie immer). Hab ein richtigen Schreck gekriegt, als eben die ganzen Threads gesehen hab.
      Bitte nicht totlachen - hab ein kleines Memoryspiel gebaut:

      [Blockierte Grafik: http://s21.postimage.org/6gseah6r7/Screen_08_03_2013_14_Uhr_34_38_Sek.jpg]

      Quellcode

      1. WindowStyle 512+16:Window 200,100 - 390,241:Declare ib&[35,3],im%,s%,i%,t%,b%,r%,z%,sf%,ai%,at%,ar%,wz%,qp$,fm%,fr!,kt%,wt$,ti%
      2. wt$=" JörgG's 4k-SystemMemory -- Klick dich fit... ":WindowTitle wt$:Def GetSysColor(1) !"USER32","GetSysColor":sf% = GetSysColor(15)
      3. Proc tb
      4. s%=5:z%=5:t%=1:ib&[0,1]=Create("hIcon",Par$(0),0)
      5. WhileLoop 1,at%:ib&[&loop]=Create("IconButton",%hwnd,ib&[0,1],s%,z%,50,50):ib&[&loop,2]=s%+7:ib&[&loop,3]=z%+7:Inc t%:If t%>ar%:t%=1:s%=5:Inc z%,52:Else:Inc s%,52:EndIf:EndWhile
      6. ib&[27]=Create("Button",%hwnd,"Neu",325,170,55,40):ib&[34]=Create("text",%hwnd,"",337,145,43,25)
      7. EndProc
      8. Proc level
      9. var f$="$400080":Cls sf%:MAT ib&[]=1
      10. ib&[26]=Create("Button",%hwnd,"Ende",325,5,55,20):ib&[28]=Create("RadioButton",%hwnd,"16x",325,146,55,20):ib&[29]=Create("RadioButton",%hwnd,"20x",325,166,55,20)
      11. ib&[30]=Create("RadioButton",%hwnd,"24x",325,186,55,20):ib&[31]=Create("text",%hwnd,"Anzeigedauer bei ungleichen Pärchen:",50,43,265,25)
      12. ib&[32]=Create("choicebox",%hwnd,1,310,35,70,90):@AddString(ib&[32],"0.5 sek"):AddString(ib&[32],"1.0 sek"):AddString(ib&[32],"1.5 sek"):SelectString(ib&[32],-1,"1.0 sek")
      13. ib&[34]=Create("text",%hwnd,"Zeitlimit in Sekunden pro Runde setzen:",38,105,265,25)
      14. ib&[35]=Create("choicebox",%hwnd,0,310,105,70,110):AddString(ib&[35],"kein's"):WhileLoop 15,180,15:AddString(ib&[35],Str$(&loop)):EndWhile:SelectString(ib&[35],-1,"kein's")
      15. TextColor $00FF,-1:DrawText 50,145,"Mit welchem Level":DrawText 50,170,"möchtest du spielen?":SetTimer 10
      16. While 1
      17. WaitInput
      18. case (Clicked(ib&[28])) Or (Clicked(ib&[29])) Or (Clicked(ib&[30])):BREAK
      19. If Clicked(ib&[26]):KillTimer:End:EndIf
      20. Inc ai%,30:usepen 0,3,f$:Line ai%,80-ai%,83:If ai%>330:ai%=0:If f$="$400080":f$="$FF":Else:f$="$400080":EndIf:EndIf
      21. EndWhile
      22. If GetCheck(ib&[28])=1:ai%=8:at%=16:ar%=4:ElseIf GetCheck(ib&[29])=1:ai%=10:at%=20:ar%=5:Else:ai%=12:at%=24:ar%=6:EndIf
      23. wz%=GetCurSel(ib&[32]):If wz%=0:wz%=500:elseif wz%=1:wz%=1000:Else:wz%=1500:EndIf
      24. fm%=GetCurSel(ib&[35]):If fm%=0:fm%=301:Else:fm%=fm%*15:WindowTitle wt$+"-- Zeitlimit: "+Str$(fm%)+" Sek":EndIf:fr!=fm%
      25. KillTimer:DestroyWindow(ib&[31]):DestroyWindow(ib&[32]):DestroyWindow(ib&[33]):DestroyWindow(ib&[34]):DestroyWindow(ib&[35])
      26. ShowWindow(ib&[28],0):ShowWindow(ib&[29],0):ShowWindow(ib&[30],0)
      27. EndProc
      28. Proc neu
      29. Declare h%[im%]:WhileLoop 1,at%:ShowWindow(ib&[&loop],1):DeleteObject ib&[&loop,1]:ib&[&loop,1]=1:EndWhile:cls sf%:s%=0:Randomize
      30. While s%<ai%:t%=Rnd(im%)+1:if h%[t%]=0:h%[t%]=Create("hIcon",qp$,t%):Inc s%:z%=0:While z%<2:i%=Rnd(at%)+1:If ib&[i%,1]=1:ib&[i%,1]=h%[t%]:Inc z%:EndIf:EndWhile:EndIf:EndWhile:s%=0:t%=0:r%=0:anz:Play 75;80,16,1:If fm%<301:SetTimer 500:kt%=1:EndIf:fr!=fm%
      31. EndProc
      32. Proc ausgabe
      33. Parameters ix%:ShowWindow(ib&[ix%],0):DrawIcon ib&[ix%,1],ib&[ix%,2],ib&[ix%,3]:If s%=0:i%=ix%:inc s%:Else:If ib&[ix%,1]<>ib&[i%,1]:sleep wz%:ShowWindow(ib&[ix%],1):ShowWindow(ib&[i%],1)
      34. If fr!<301:fr!=fr!-wz%/1000:ti%=%wmtimer:SetTimer 500:EndIf:Else:Inc r%:EndIf:s%=0:EndIf
      35. If r%=ai%:Play 19;19;19,-1,0:Play 25;27;29,0,0:If fm%<301:KillTimer:kt%=0:TextColor $400080,-1:DrawText 330,110,Str$(fm%-fr!)+ "s":EndIf:sleep 1000:Play -25;-27;-29,0,0:If (b% > t%) Or (b% = 0):MUSIC "C#2 F-8 G4.":b%=t%:anz:EndIf:EndIf
      36. EndProc
      37. Proc anz
      38. rectangle 325,32-380,97:TextColor $00FF,-1:DrawText 335,33,Str$(b%):TextColor $8000,-1:DrawText 335,68,Str$(t%)
      39. EndProc
      40. qp$=$syspath+"\\shell32.dll":im%=@IconCount(qp$)-1:UseFont "courier new",30,12,1,0,0:set("NumWidth",3):set("Decimals",0):level:usepen 0,0,$FF0000:tb:neu:b%=0
      41. While 1
      42. WaitInput
      43. If %wmtimer:fr!=fr!-.5:SetText ib&[34],Str$(fr!):If fr!<.5:Play 29;35,2,1:MessageBox("Die Zeit für die neue Runde läuft, sobald du OK drückst...","Schade - die "+Str$(fm%)+" Sek sind leider abgelaufen...",262640):SetFocus((ib&[27])):neu:EndIf
      44. ElseIf Clicked(ib&[26]):WhileLoop 0,at%:DeleteObject ib&[&loop,1]:EndWhile:Case kt%=1:KillTimer:end:ElseIf Clicked(ib&[27]):neu:Endif
      45. WhileLoop 1,at%:If %getfocus=ib&[&loop]:Inc t%:anz:ausgabe &loop:BREAK:EndIf:EndWhile:EndWhile
      Alles anzeigen


      Gelegentlich erscheint beim 'würfeln' eine Fehlermeldung, daß das entsprechende Icon nicht geladen werden konnte. Einfach bestätigen - es werden trotzdem alle geladen. Auch kann es vorkommen, daß du augenscheinlich 4 gleiche Icons in der Runde hast, wo aber immer nur 2 zusammenpassen. Liegt daran, daß in der shell32 wahrsch. gleiche Icons mit verschiedenen Nummern enthalten sind.
      Ich denke noch drüber nach, ob ich die 'Icon-Quelle' frei einstellbar mach - ein paar Bytes kann ich ja noch rausschindern...
      Gruß Jörg

      Ideen gibt es viele - man muß sie nur haben...
      Win7-Pro / Linux Mint
    • oh - Danke für die Blumen :oops: & für die 'heißen' Tip's / Anregungen:-).
      -Systempfad ist umgesetzt
      -Anzahl Icons (im%) um 1 reduziert

      Mal schauen, ob ich vllt. noch einen weiteren einstellbaren Schwierigkeitsfaktor einbauen kann
      Gruß Jörg

      Ideen gibt es viele - man muß sie nur haben...
      Win7-Pro / Linux Mint
    • H.Brill;961509 schrieb:

      Spiel geht zwar, aber nach erfolgreichem Ende
      des ersten Levels steigt der Interpreter mit
      der Meldung, daß der Speicher für Integer Variablen
      erschöpft ist, aus.


      Ich bekam zwar nicht diese Meldung, aber auch einen Absturz. Grund: Der MUSIC-Befehl funktionierte nicht. (Wieder so ein Unterschied zwischen Delphi und FreePascal.) Heute Abend gibt es eine neue Version von FreeProfan32 und FreeProfan64, mit der auch Memory gespielt werden kann!

      Gruß
      Roland
      (Intel Duo E8400 3,0 GHz / 4 GB RAM / 250 GB HDD / ATI Radeon HD4770 512 MB / Windows Vista - ausgemustert zum Verkauf)
      AMD Athlon II X2 2,9 GHz / 8 GB RAM / 500 + 1000 GB HDD / ATI Radeon 3000 (onboard) / Windows 10(64) - XProfan X4


      http://www.xprofan.de
    • Danke Roland, für die Bestätigung.
      Ist halt etwas schwierig, einen Fehler zu
      lokalisieren, zumal er in der Vollversion manchmal
      nicht auftaucht.

      Kann man im xProfan Pad noch was einstellen ?
      Kurz vor der Fehlermeldung im Statusfenster kommt
      noch ein kleines weißes Fenster, was aber auch sofort
      wieder verschwindet. Wäre interessant, wenn man
      dort auch was lesen könnte, um evtl. den Fehler zu
      lokalisieren.
    • H.Brill;961524 schrieb:

      Kann man im xProfan Pad noch was einstellen ?
      Kurz vor der Fehlermeldung im Statusfenster kommt
      noch ein kleines weißes Fenster, was aber auch sofort
      wieder verschwindet. Wäre interessant, wenn man
      dort auch was lesen könnte, um evtl. den Fehler zu
      lokalisieren.


      Das würde ich auch gerne lesen, aber ich habe noch nicht herausgefunden wie ich FreePascal dazu bewegen kann, nach der Fehlermeldung zu warten. Meist ist es aber ein "RangeCheck"-Error, wegen der diesbezüglichen Unterschiede zwischen Delphi und FreePascal.

      Gruß
      Roland
      (Intel Duo E8400 3,0 GHz / 4 GB RAM / 250 GB HDD / ATI Radeon HD4770 512 MB / Windows Vista - ausgemustert zum Verkauf)
      AMD Athlon II X2 2,9 GHz / 8 GB RAM / 500 + 1000 GB HDD / ATI Radeon 3000 (onboard) / Windows 10(64) - XProfan X4


      http://www.xprofan.de
    • Hallo Zusammen, hier noch mal die leicht verbesserte Version, wie weiter oben bereits angesprochen (Systempfad wird vom Prog. ermittelt & die Anzahl der ermittelten Icons um 1 reduziert)
      Ich frickel zwar noch an einer einstellbare Zeitbegrenzung als weiteren Schwierigkeitsgrad, aber das will noch nicht so richtig klappen. Also falls ich das nicht rechtzeitig hinkriege, ist diese Version bis auf weiteres der offizielle "Wettbewerbskandidat".:-)

      Quellcode

      1. '4k-Wettbewerb 2013 by JörgG
      2. WindowStyle 512+16:Window 200,100 - 390,241:WindowTitle " * * * JörgG's 4k-SystemMemory -- Klick dich fit... * * *":Declare ib&[35,3],im%,s%,i%,t%,b%,r%,z%,sf%,ai%,at%,ar%,wz%,qp$
      3. Def GetSysColor(1) !"USER32","GetSysColor"
      4. sf% = GetSysColor(15)
      5. Proc tb
      6. s% = 5:z% = 5:t% = 1
      7. ib&[0,1] = Create("hIcon",Par$(0),0)
      8. WhileLoop 1,at%
      9. ib&[&loop] = Create("IconButton",%hwnd,ib&[0,1],s%,z%,50,50)
      10. ib&[&loop,2]=s%+7:ib&[&loop,3]=z%+7 'koordinaten merken
      11. Inc t%
      12. If t% > ar%:t% = 1:s% = 5:Inc z%, 52
      13. Else:Inc s%, 52
      14. EndIf
      15. EndWhile
      16. ib&[27] = Create("Button",%hwnd,"Neu",325,170,55,40)
      17. EndProc
      18. Proc level
      19. var f$ = "$400080"
      20. Cls sf%:MAT ib&[] = 1
      21. ib&[26] = Create("Button",%hwnd,"Ende",325,5,55,20)
      22. ib&[28] = Create("RadioButton",%hwnd,"16x",325,106,55,20)
      23. ib&[29] = Create("RadioButton",%hwnd,"20x",325,126,55,20)
      24. ib&[30] = Create("RadioButton",%hwnd,"24x",325,146,55,20)
      25. ib&[31] = Create("text",%hwnd,"Anzeigedauer bei ungleichen Pärchen:",50,43,265,25)
      26. ib&[32] = Create("choicebox",%hwnd,1,310,35,70,90):@AddString(ib&[32],"0.5 sek"):@AddString(ib&[32],"1.0 sek"):@AddString(ib&[32],"1.5 sek")
      27. ib&[33] = Create("Button",%hwnd,"Hilfe",5,5,55,20)
      28. SelectString(ib&[32],-1,"1.0 sek")
      29. TextColor $00FF,-1
      30. DrawText 50, 115, "Mit welchem Level"
      31. DrawText 50, 140, "möchtest du spielen?"
      32. SetTimer 10
      33. While 1
      34. WaitInput
      35. case (Clicked(ib&[28])) Or (Clicked(ib&[29])) Or (Clicked(ib&[30])):BREAK 'wenn level gewählt wurde
      36. Case Clicked(ib&[26]):End
      37. case Clicked(ib&[33]):MessageBox("Als Vorlage dient das klassische Spiel Memory, nur daß die Bilder in diesem Spiel allesamt aus der shell23.dll 'gewürfelt' werden. Es werden jedesmal andere Icons für eine neue Runde 'gezogen'."+Chr$(13)+"Viel Spass","Willkommen bei System-Memory",64)
      38. Inc ai%,30
      39. usepen 0,3,f$
      40. Line ai%,80 - ai%,83
      41. If ai%>330
      42. ai%=0
      43. If f$ = "$400080"
      44. f$ = "$FF"
      45. Else
      46. f$ = "$400080"
      47. EndIf
      48. EndIf
      49. EndWhile
      50. If GetCheck(ib&[28])= 1
      51. ai%=8:at%=16:ar%=4
      52. ElseIf GetCheck(ib&[29])= 1
      53. ai%=10:at%=20:ar%=5
      54. Else
      55. ai%=12:at%=24:ar%=6
      56. EndIf
      57. wz% = @GetCurSel(ib&[32])
      58. If wz% = 0
      59. wz% = 500
      60. elseif wz% = 1
      61. wz% = 1000
      62. Else
      63. wz% = 1500
      64. EndIf
      65. DestroyWindow(ib&[31]):DestroyWindow(ib&[32]):DestroyWindow(ib&[33])
      66. enableWindow ib&[28],0:enableWindow ib&[29],0:enableWindow ib&[30],0:killtimer
      67. EndProc
      68. Proc neu
      69. Declare h%[im%]
      70. cls sf%
      71. s%=0
      72. Randomize
      73. While s%<ai%
      74. t%=Rnd(im%)+1
      75. if h%[t%]=0
      76. h%[t%]=Create("hIcon",qp$,t%)
      77. Inc s%
      78. z%=0
      79. While z%<2
      80. i%=Rnd(at%)+1
      81. If ib&[i%,1]=1
      82. ib&[i%,1]=h%[t%]
      83. Inc z%
      84. EndIf
      85. EndWhile
      86. EndIf
      87. EndWhile
      88. s%=0:t%=0:r%=0
      89. anz
      90. EndProc
      91. Proc ausgabe
      92. Parameters ix%
      93. ShowWindow(ib&[ix%],0)
      94. DrawIcon ib&[ix%,1],ib&[ix%,2],ib&[ix%,3]
      95. If s%=0
      96. i%=ix%
      97. inc s%
      98. else
      99. If ib&[ix%,1] <> ib&[i%,1]
      100. sleep wz%
      101. ShowWindow(ib&[ix%],1):ShowWindow(ib&[i%],1)
      102. Else
      103. Inc r%
      104. EndIf
      105. s%=0
      106. EndIf
      107. If r%=ai%
      108. Play 19;19;19,-1,0
      109. Play 25;27;29,0,0
      110. sleep 1000
      111. Play -25;-27;-29,0,0
      112. If (b% > t%) Or (b% = 0)
      113. MUSIC "C#2 F-8 G4."
      114. b%=t%
      115. anz
      116. EndIf
      117. EndIf
      118. EndProc
      119. Proc anz
      120. rectangle 325,32-380,97
      121. TextColor $00FF,-1
      122. DrawText 335, 33, Str$(b%)
      123. TextColor $8000,-1
      124. DrawText 335, 68, Str$(t%)
      125. EndProc
      126. qp$ = $syspath + "\\shell32.dll"
      127. im% = @IconCount(qp$)-1
      128. UseFont "courier new",30,12,1,0,0
      129. set("NumWidth",3)
      130. level
      131. usepen 0,0,$FF0000
      132. tb
      133. neu
      134. b%=0
      135. While 1
      136. WaitInput
      137. If Clicked(ib&[26])
      138. WhileLoop 0,at%
      139. DeleteObject ib&[&loop,1]
      140. EndWhile
      141. end
      142. ElseIf Clicked(ib&[27])
      143. WhileLoop 1,at%
      144. ShowWindow(ib&[&loop],1)
      145. DeleteObject ib&[&loop,1]
      146. ib&[&loop,1]=1
      147. EndWhile
      148. neu
      149. Endif
      150. WhileLoop 1, at%
      151. If &lastfocus = ib&[&loop]
      152. Inc t%
      153. anz
      154. ausgabe &loop
      155. BREAK
      156. EndIf
      157. EndWhile
      158. EndWhile
      159. End
      Alles anzeigen
      Gruß Jörg

      Ideen gibt es viele - man muß sie nur haben...
      Win7-Pro / Linux Mint
    • Hallo Zusammen, hab's doch noch hingekriegt, ein Zeitlimit einzubauen.
      Hatte ganz schön zu tun, den Code auf 4k "einzudampfen". Mußte deshalb leider den Hilfetext rausnehmen. Aber ich hoffe, man sieht auch so, was das für ein Spiel ist.:-)
      Also hier der offizielle Beitrag (hfftl. ist da kein Bug drin, der Code ist nicht grad wartungsfreundlich):D

      Quellcode

      1. WindowStyle 512+16:Window 200,100 - 390,241:Declare ib&[35,3],im%,s%,i%,t%,b%,r%,z%,sf%,ai%,at%,ar%,wz%,qp$,fm%,fr!,kt%,wt$,ti%
      2. wt$=" JörgG's 4k-SystemMemory -- Klick dich fit... ":WindowTitle wt$:Def GetSysColor(1) !"USER32","GetSysColor":sf% = GetSysColor(15)
      3. Proc tb
      4. s%=5:z%=5:t%=1:ib&[0,1]=Create("hIcon",Par$(0),0)
      5. WhileLoop 1,at%:ib&[&loop]=Create("IconButton",%hwnd,ib&[0,1],s%,z%,50,50):ib&[&loop,2]=s%+7:ib&[&loop,3]=z%+7:Inc t%:If t%>ar%:t%=1:s%=5:Inc z%,52:Else:Inc s%,52:EndIf:EndWhile
      6. ib&[27]=Create("Button",%hwnd,"Neu",325,170,55,40):ib&[34]=Create("text",%hwnd,"",337,145,43,25)
      7. EndProc
      8. Proc level
      9. var f$="$400080":Cls sf%:MAT ib&[]=1
      10. ib&[26]=Create("Button",%hwnd,"Ende",325,5,55,20):ib&[28]=Create("RadioButton",%hwnd,"16x",325,146,55,20):ib&[29]=Create("RadioButton",%hwnd,"20x",325,166,55,20)
      11. ib&[30]=Create("RadioButton",%hwnd,"24x",325,186,55,20):ib&[31]=Create("text",%hwnd,"Anzeigedauer bei ungleichen Pärchen:",50,43,265,25)
      12. ib&[32]=Create("choicebox",%hwnd,1,310,35,70,90):@AddString(ib&[32],"0.5 sek"):AddString(ib&[32],"1.0 sek"):AddString(ib&[32],"1.5 sek"):SelectString(ib&[32],-1,"1.0 sek")
      13. ib&[34]=Create("text",%hwnd,"Zeitlimit in Sekunden pro Runde setzen:",38,105,265,25)
      14. ib&[35]=Create("choicebox",%hwnd,0,310,105,70,110):AddString(ib&[35],"kein's"):WhileLoop 30,300,30:AddString(ib&[35],Str$(&loop)):EndWhile:SelectString(ib&[35],-1,"kein's")
      15. TextColor $00FF,-1:DrawText 50,145,"Mit welchem Level":DrawText 50,170,"möchtest du spielen?":SetTimer 10
      16. While 1
      17. WaitInput
      18. case (Clicked(ib&[28])) Or (Clicked(ib&[29])) Or (Clicked(ib&[30])):BREAK
      19. If Clicked(ib&[26]):KillTimer:End:EndIf
      20. Inc ai%,30:usepen 0,3,f$:Line ai%,80-ai%,83:If ai%>330:ai%=0:If f$="$400080":f$="$FF":Else:f$="$400080":EndIf:EndIf
      21. EndWhile
      22. If GetCheck(ib&[28])=1:ai%=8:at%=16:ar%=4:ElseIf GetCheck(ib&[29])=1:ai%=10:at%=20:ar%=5:Else:ai%=12:at%=24:ar%=6:EndIf
      23. wz%=GetCurSel(ib&[32]):If wz%=0:wz%=500:elseif wz%=1:wz%=1000:Else:wz%=1500:EndIf
      24. fm%=GetCurSel(ib&[35]):If fm%=0:fm%=301:Else:fm%=fm%*30:WindowTitle wt$+"-- Zeitlimit: "+Str$(fm%)+" Sek":EndIf:fr!=fm%
      25. KillTimer:DestroyWindow(ib&[31]):DestroyWindow(ib&[32]):DestroyWindow(ib&[33]):DestroyWindow(ib&[34]):DestroyWindow(ib&[35])
      26. ShowWindow(ib&[28],0):ShowWindow(ib&[29],0):ShowWindow(ib&[30],0)
      27. EndProc
      28. Proc neu
      29. Declare h%[im%]:WhileLoop 1,at%:ShowWindow(ib&[&loop],1):DeleteObject ib&[&loop,1]:ib&[&loop,1]=1:EndWhile:cls sf%:s%=0:Randomize
      30. While s%<ai%:t%=Rnd(im%)+1:if h%[t%]=0:h%[t%]=Create("hIcon",qp$,t%):Inc s%:z%=0:While z%<2:i%=Rnd(at%)+1:If ib&[i%,1]=1:ib&[i%,1]=h%[t%]:Inc z%:EndIf:EndWhile:EndIf:EndWhile:s%=0:t%=0:r%=0:anz:If fm%<301:SetTimer 500:kt%=1:EndIf:fr!=fm%
      31. EndProc
      32. Proc ausgabe
      33. Parameters ix%:ShowWindow(ib&[ix%],0):DrawIcon ib&[ix%,1],ib&[ix%,2],ib&[ix%,3]:If s%=0:i%=ix%:inc s%:Else:If ib&[ix%,1]<>ib&[i%,1]:sleep wz%:ShowWindow(ib&[ix%],1):ShowWindow(ib&[i%],1)
      34. If fr!<301:fr!=fr!-wz%/1000:ti%=%wmtimer:SetTimer 500:EndIf:Else:Inc r%:EndIf:s%=0:EndIf
      35. If r%=ai%:Play 19;19;19,-1,0:Play 25;27;29,0,0:If fm%<301:KillTimer:kt%=0:TextColor $400080,-1:DrawText 330,110,Str$(fm%-fr!)+ "s":EndIf:sleep 1000:Play -25;-27;-29,0,0:If (b% > t%) Or (b% = 0):MUSIC "C#2 F-8 G4.":b%=t%:anz:EndIf:EndIf
      36. EndProc
      37. Proc anz
      38. rectangle 325,32-380,97:TextColor $00FF,-1:DrawText 335,33,Str$(b%):TextColor $8000,-1:DrawText 335,68,Str$(t%)
      39. EndProc
      40. qp$=$syspath+"\\shell32.dll":im%=@IconCount(qp$)-1:UseFont "courier new",30,12,1,0,0:set("NumWidth",3):set("Decimals",0):level:usepen 0,0,$FF0000:tb:neu:b%=0
      41. While 1
      42. WaitInput
      43. If %wmtimer:fr!=fr!-.5:SetText ib&[34],Str$(fr!):If fr!<.5:Play 29;35,2,1:MessageBox("Die Zeit für die neue Runde läuft, sobald du OK drückst...","Schade - die "+Str$(fm%)+" Sek sind leider abgelaufen...",262640):neu:EndIf
      44. ElseIf Clicked(ib&[26]):WhileLoop 0,at%:DeleteObject ib&[&loop,1]:EndWhile:Case kt%=1:KillTimer:end:ElseIf Clicked(ib&[27]):neu:Endif
      45. WhileLoop 1,at%:If &lastfocus=ib&[&loop]:Inc t%:anz:ausgabe &loop:BREAK:EndIf:EndWhile:EndWhile
      Alles anzeigen


      Edit: Ist es vllt. hilfreicher, diesen Code noch zusätzlich in einer lesbaren & kommentierten Version hochzuladen?
      Gruß Jörg

      Ideen gibt es viele - man muß sie nur haben...
      Win7-Pro / Linux Mint
    • Hab noch 'ne kleine Macke ausgebügelt & ein Startton eingebaut.
      Jetzt sind's 4022 Bytes...;)

      Quellcode

      1. WindowStyle 512+16:Window 200,100 - 390,241:Declare ib&[35,3],im%,s%,i%,t%,b%,r%,z%,sf%,ai%,at%,ar%,wz%,qp$,fm%,fr!,kt%,wt$,ti%
      2. wt$=" JörgG's 4k-SystemMemory -- Klick dich fit... ":WindowTitle wt$:Def GetSysColor(1) !"USER32","GetSysColor":sf% = GetSysColor(15)
      3. Proc tb
      4. s%=5:z%=5:t%=1:ib&[0,1]=Create("hIcon",Par$(0),0)
      5. WhileLoop 1,at%:ib&[&loop]=Create("IconButton",%hwnd,ib&[0,1],s%,z%,50,50):ib&[&loop,2]=s%+7:ib&[&loop,3]=z%+7:Inc t%:If t%>ar%:t%=1:s%=5:Inc z%,52:Else:Inc s%,52:EndIf:EndWhile
      6. ib&[27]=Create("Button",%hwnd,"Neu",325,170,55,40):ib&[34]=Create("text",%hwnd,"",337,145,43,25)
      7. EndProc
      8. Proc level
      9. var f$="$400080":Cls sf%:MAT ib&[]=1
      10. ib&[26]=Create("Button",%hwnd,"Ende",325,5,55,20):ib&[28]=Create("RadioButton",%hwnd,"16x",325,146,55,20):ib&[29]=Create("RadioButton",%hwnd,"20x",325,166,55,20)
      11. ib&[30]=Create("RadioButton",%hwnd,"24x",325,186,55,20):ib&[31]=Create("text",%hwnd,"Anzeigedauer bei ungleichen Pärchen:",50,43,265,25)
      12. ib&[32]=Create("choicebox",%hwnd,1,310,35,70,90):@AddString(ib&[32],"0.5 sek"):AddString(ib&[32],"1.0 sek"):AddString(ib&[32],"1.5 sek"):SelectString(ib&[32],-1,"1.0 sek")
      13. ib&[34]=Create("text",%hwnd,"Zeitlimit in Sekunden pro Runde setzen:",38,105,265,25)
      14. ib&[35]=Create("choicebox",%hwnd,0,310,105,70,110):AddString(ib&[35],"kein's"):WhileLoop 15,180,15:AddString(ib&[35],Str$(&loop)):EndWhile:SelectString(ib&[35],-1,"kein's")
      15. TextColor $00FF,-1:DrawText 50,145,"Mit welchem Level":DrawText 50,170,"möchtest du spielen?":SetTimer 10
      16. While 1
      17. WaitInput
      18. case (Clicked(ib&[28])) Or (Clicked(ib&[29])) Or (Clicked(ib&[30])):BREAK
      19. If Clicked(ib&[26]):KillTimer:End:EndIf
      20. Inc ai%,30:usepen 0,3,f$:Line ai%,80-ai%,83:If ai%>330:ai%=0:If f$="$400080":f$="$FF":Else:f$="$400080":EndIf:EndIf
      21. EndWhile
      22. If GetCheck(ib&[28])=1:ai%=8:at%=16:ar%=4:ElseIf GetCheck(ib&[29])=1:ai%=10:at%=20:ar%=5:Else:ai%=12:at%=24:ar%=6:EndIf
      23. wz%=GetCurSel(ib&[32]):If wz%=0:wz%=500:elseif wz%=1:wz%=1000:Else:wz%=1500:EndIf
      24. fm%=GetCurSel(ib&[35]):If fm%=0:fm%=301:Else:fm%=fm%*15:WindowTitle wt$+"-- Zeitlimit: "+Str$(fm%)+" Sek":EndIf:fr!=fm%
      25. KillTimer:DestroyWindow(ib&[31]):DestroyWindow(ib&[32]):DestroyWindow(ib&[33]):DestroyWindow(ib&[34]):DestroyWindow(ib&[35])
      26. ShowWindow(ib&[28],0):ShowWindow(ib&[29],0):ShowWindow(ib&[30],0)
      27. EndProc
      28. Proc neu
      29. Declare h%[im%]:WhileLoop 1,at%:ShowWindow(ib&[&loop],1):DeleteObject ib&[&loop,1]:ib&[&loop,1]=1:EndWhile:cls sf%:s%=0:Randomize
      30. While s%<ai%:t%=Rnd(im%)+1:if h%[t%]=0:h%[t%]=Create("hIcon",qp$,t%):Inc s%:z%=0:While z%<2:i%=Rnd(at%)+1:If ib&[i%,1]=1:ib&[i%,1]=h%[t%]:Inc z%:EndIf:EndWhile:EndIf:EndWhile:s%=0:t%=0:r%=0:anz:Play 75;80,16,1:If fm%<301:SetTimer 500:kt%=1:EndIf:fr!=fm%
      31. EndProc
      32. Proc ausgabe
      33. Parameters ix%:ShowWindow(ib&[ix%],0):DrawIcon ib&[ix%,1],ib&[ix%,2],ib&[ix%,3]:If s%=0:i%=ix%:inc s%:Else:If ib&[ix%,1]<>ib&[i%,1]:sleep wz%:ShowWindow(ib&[ix%],1):ShowWindow(ib&[i%],1)
      34. If fr!<301:fr!=fr!-wz%/1000:ti%=%wmtimer:SetTimer 500:EndIf:Else:Inc r%:EndIf:s%=0:EndIf
      35. If r%=ai%:Play 19;19;19,-1,0:Play 25;27;29,0,0:If fm%<301:KillTimer:kt%=0:TextColor $400080,-1:DrawText 330,110,Str$(fm%-fr!)+ "s":EndIf:sleep 1000:Play -25;-27;-29,0,0:If (b% > t%) Or (b% = 0):MUSIC "C#2 F-8 G4.":b%=t%:anz:EndIf:EndIf
      36. EndProc
      37. Proc anz
      38. rectangle 325,32-380,97:TextColor $00FF,-1:DrawText 335,33,Str$(b%):TextColor $8000,-1:DrawText 335,68,Str$(t%)
      39. EndProc
      40. qp$=$syspath+"\\shell32.dll":im%=@IconCount(qp$)-1:UseFont "courier new",30,12,1,0,0:set("NumWidth",3):set("Decimals",0):level:usepen 0,0,$FF0000:tb:neu:b%=0
      41. While 1
      42. WaitInput
      43. If %wmtimer:fr!=fr!-.5:SetText ib&[34],Str$(fr!):If fr!<.5:Play 29;35,2,1:MessageBox("Die Zeit für die neue Runde läuft, sobald du OK drückst...","Schade - die "+Str$(fm%)+" Sek sind leider abgelaufen...",262640):SetFocus((ib&[27])):neu:EndIf
      44. ElseIf Clicked(ib&[26]):WhileLoop 0,at%:DeleteObject ib&[&loop,1]:EndWhile:Case kt%=1:KillTimer:end:ElseIf Clicked(ib&[27]):neu:Endif
      45. WhileLoop 1,at%:If %getfocus=ib&[&loop]:Inc t%:anz:ausgabe &loop:BREAK:EndIf:EndWhile:EndWhile
      Alles anzeigen

      Edit: hab das auswählbare Zeitlimit etwas feinstufiger gemacht...
      Gruß Jörg

      Ideen gibt es viele - man muß sie nur haben...
      Win7-Pro / Linux Mint