Option Explicit
Dim Kopf_Zeile As Integer, Kopf_Spalte As Integer
Dim Letzte_Zeile As Integer, Letzte_Spalte As Integer
Dim Laenge() As String
Dim Wand_L As Boolean
Dim Wand_R As Boolean
Dim Wand_O As Boolean
Dim Wand_U 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_L = False
Wand_R = False
Wand_O = False
Wand_U = 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"
Application.OnKey "{LEFT}", "Links"
End Sub
Sub Rechts()
Dim j As Integer
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
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
If Wand_R = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeLeft).Weight = xlMedium Or Wand_R = True Then
MsgBox ("Verloren!!!!!!!")
Wand_R = True
Exit Sub
End If
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub
Sub Links()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Dim j As Integer
Range(Laenge(0)).Select
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
If Wand_L = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeRight).Weight = xlMedium Or Wand_L = True Then
MsgBox ("Verloren!!!!!!!")
Wand_L = True
Exit Sub
End If
Application.OnTime Now + TimeValue("00:00:01"), "Links", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub
Sub Rauf()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Dim j As Integer
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
If Wand_O = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeBottom).Weight = xlMedium Or Wand_O = True Then
MsgBox ("Verloren!!!!!!!")
Wand_O = True
Exit Sub
End If
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub
Sub Runter()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Dim j As Integer
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
If Wand_U = True Then
Exit Sub
End If
If Selection.Borders(xlEdgeTop).Weight = xlMedium Or Wand_U = True Then
MsgBox ("Verloren!!!!!!!")
Wand_U = True
Exit Sub
End If
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub
|