Wuhu Danke :D
Nur noch ein kleines, winziges, minimales Problem :S
Wenn ich nun meine Snake laufen lasse, kann ich nur einen Knopf drücken aber dann die richtung nicht wechseln...:S
Hier mein Code:
Dim Kopf_Zeile As Integer, Kopf_Spalte As Integer
Dim Letzte_Zeile As Integer, Letzte_Spalte As Integer
Dim Laenge() As String
Dim Wand As Boolean
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Snake()
'====================================================================
'Alles Löschen und Spaltenbreite und -höhe anpassen
'====================================================================
Cells.Select
Selection.ClearContents
Range("A1").Select
Cells.Select
Selection.ClearFormats
Range("A1").Select
Cells.Select
Selection.RowHeight = 12
Selection.ColumnWidth = 2.5
Range("A1").Select
'====================================================================
'Spielbereich festlegen
'====================================================================
Range("J10:AM39").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
'====================================================================
'Snake entstehen lassen
'====================================================================
Dim Groesse As Integer, a As Boolean
Wand = False
Groesse = 5
Range("V24:Z24").Select
Selection.Interior.Color = 5287936
ReDim Laenge(4)
Laenge(0) = "V24"
Laenge(1) = "W24"
Laenge(2) = "X24"
Laenge(3) = "Y24"
Laenge(4) = "Z24"
Range("V24").Select
Letzte_Spalte = ActiveCell.Column
Letzte_Zeile = ActiveCell.Row
Range("Z24").Select
Kopf_Spalte = ActiveCell.Column
Kopf_Zeile = ActiveCell.Row
Application.OnKey "{RIGHT}", "Rechts"
Application.OnKey "{UP}", "Rauf"
Application.OnKey "{DOWN}", "Runter"
End Sub
Sub Rechts()
Dim j As Integer
Do
Range(Laenge(0)).Select
Selection.Interior.Pattern = xlNone
For j = 0 To (UBound(Laenge)) - 1
Laenge(j) = Laenge(j + 1)
Next j
Range(Laenge(4)).Select
ActiveCell.Offset(0, 1).Select
Selection.Interior.Color = 5287936
Laenge(4) = ActiveCell.Address
Sleep 100
DoEvents
If Wand = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeLeft).Weight = xlMedium Or Wand = True Then
MsgBox ("Verloren!!!!!!!")
Wand = True
Exit Sub
End If
Loop While 0 = 0
Application.OnKey "{RIGHT}", "Rechts"
Application.OnKey "{UP}", "Rauf"
Application.OnKey "{DOWN}", "Runter"
End Sub
Sub Links()
Dim j As Integer
Do
Range(Laenge(0)).Select
Selection.Interior.Pattern = xlNone
For j = 0 To (UBound(Laenge)) - 1
Laenge(j) = Laenge(j + 1)
Next j
Range(Laenge(4)).Select
ActiveCell.Offset(0, -1).Select
Selection.Interior.Color = 5287936
Laenge(4) = ActiveCell.Address
Sleep 100
DoEvents
If Wand = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeRight).Weight = xlMedium Then
MsgBox ("Verloren!!!!!!!")
Wand = True
Exit Sub
End If
Loop While 0 = 0
Application.OnKey "{LEFT}", "Links"
Application.OnKey "{UP}", "Rauf"
Application.OnKey "{DOWN}", "Runter"
End Sub
Sub Rauf()
Dim j As Integer
Do
Range(Laenge(0)).Select
Selection.Interior.Pattern = xlNone
For j = 0 To (UBound(Laenge)) - 1
Laenge(j) = Laenge(j + 1)
Next j
Range(Laenge(4)).Select
ActiveCell.Offset(-1, 0).Select
Selection.Interior.Color = 5287936
Laenge(4) = ActiveCell.Address
Sleep 100
DoEvents
If Wand = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeBottom).Weight = xlMedium Or Wand = True Then
MsgBox ("Verloren!!!!!!!")
Wand = True
Exit Sub
End If
Loop While 0 = 0
Application.OnKey "{RIGHT}", "Rechts"
Application.OnKey "{LEFT}", "Links"
Application.OnKey "{UP}", "Rauf"
End Sub
Sub Runter()
Dim j As Integer
Do
Range(Laenge(0)).Select
Selection.Interior.Pattern = xlNone
For j = 0 To (UBound(Laenge)) - 1
Laenge(j) = Laenge(j + 1)
Next j
Range(Laenge(4)).Select
ActiveCell.Offset(1, 0).Select
Selection.Interior.Color = 5287936
Laenge(4) = ActiveCell.Address
Sleep 100
DoEvents
If Wand = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeTop).Weight = xlMedium Or Wand = True Then
MsgBox ("Verloren!!!!!!!")
Wand = True
Exit Sub
End If
Loop While 0 = 0
Application.OnKey "{RIGHT}", "Rechts"
Application.OnKey "{LEFT}", "Links"
Application.OnKey "{DOWN}", "Runter"
End Sub
Gruss
Samse
|