forked from AllenMattson/VBA_personal
-
Notifications
You must be signed in to change notification settings - Fork 0
/
SnakeAttempt.vb
179 lines (122 loc) · 4.23 KB
/
SnakeAttempt.vb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
Option Explicit
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646299(v=vs.85).aspx
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646293(v=vs.85).aspx
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
Private Const SIZE_WIDTH As Long = 7
Private Const SIZE_HEIGTH As Long = 5
Private Const COL_WIDTH As Double = 2.3
Private Const BORDER_COL As Long = 190
Private wks As Worksheet
Private pointX As Long
Private pointY As Long
Private leadPoint As Range
Private pointField As Range
Private movingDirection As Direction
Public Enum Direction
GoUp = 1
GoRight = 2
GoDown = 3
GoLeft = 4
End Enum
Private Sub Main()
FixThePitch
InitializePoint
PrintInformation
MoveAround
End Sub
Public Sub PrintInformation()
Debug.Print "Press Home to exit."
End Sub
Private Sub ShowNewFood()
Dim positionRow As Long
Dim positionCol As Long
positionRow = 1
positionCol = 1
End Sub
Private Function MakeRandom(down As Long, up As Long) As Long
MakeRandom = CLng((up - down) * Rnd + down)
End Function
Public Sub ChangePoints(pointToChange As Long)
pointField.value = pointField + pointToChange
End Sub
Public Sub GoMove(moveDir As Direction)
Debug.Print moveDir
End Sub
Public Sub ColorSnake()
With wks
.Range(.Cells(1, 1), .Cells(SIZE_HEIGTH, SIZE_WIDTH)).Clear
End With
leadPoint.Interior.COLOR = vbWhite
End Sub
Private Sub MoveFurther()
Select Case movingDirection
Case GoUp:
If leadPoint.row = 1 Then
Set leadPoint = Cells(SIZE_HEIGTH, leadPoint.Column)
Else
Set leadPoint = Cells(leadPoint.row - 1, leadPoint.Column)
End If
Case GoRight:
If leadPoint.Column = SIZE_WIDTH Then
Set leadPoint = Cells(leadPoint.row, 1)
Else
Set leadPoint = Cells(leadPoint.row, leadPoint.Column + 1)
End If
Case GoDown:
If leadPoint.row = SIZE_HEIGTH Then
Set leadPoint = Cells(1, leadPoint.Column)
Else
Set leadPoint = Cells(leadPoint.row + 1, leadPoint.Column)
End If
Case GoLeft:
If leadPoint.Column = 1 Then
Set leadPoint = Cells(leadPoint.row, SIZE_WIDTH)
Else
Set leadPoint = Cells(leadPoint.row, leadPoint.Column - 1)
End If
End Select
End Sub
Private Sub ReadKey()
Debug.Assert Not IsEmpty(GetAsyncKeyState(vbKeyUp))
Select Case True
Case GetAsyncKeyState(vbKeyHome)
Debug.Print "Exiting..."
End
Case GetAsyncKeyState(vbKeyUp):
movingDirection = GoUp
Case GetAsyncKeyState(vbKeyRight):
movingDirection = GoRight
Case GetAsyncKeyState(vbKeyDown):
movingDirection = GoDown
Case GetAsyncKeyState(vbKeyLeft):
movingDirection = GoLeft
End Select
End Sub
Private Sub MoveAround()
movingDirection = Direction.GoRight
Do While True
DoEvents
ReadKey
ColorSnake
MoveFurther
Sleep (200)
Loop
End Sub
Private Sub InitializePoint()
Set leadPoint = wks.Cells(2, 3)
End Sub
Private Sub FixThePitch()
Set wks = tbl_Internal1
wks.visible = xlSheetVisible
wks.Activate
With wks
.Cells.Delete
.Cells(1, 1).Select
.Range(.Cells(1), .Cells(1 + SIZE_WIDTH)).ColumnWidth = COL_WIDTH
.Range(.Cells(SIZE_HEIGTH + 1, 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL)
.Range(.Cells(1, SIZE_WIDTH + 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH + 1)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL)
End With
Set pointField = wks.Cells(8, 1)
ChangePoints (0)
End Sub