This repository has been archived by the owner on Nov 18, 2022. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 8
/
Cube.cls
480 lines (406 loc) · 13 KB
/
Cube.cls
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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Cube"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'**********************************************
'Author - Mark Gordon (msg555)
'Member of VbCity.com
'Date September 19th, 2004
'Copyright Mark Gordon. 2004
'
'This class is free for use in any application
'**********************************************
Private Type Point3D
x As Long
y As Long
z As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "GDI32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateBitmap Lib "GDI32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetPixel Lib "GDI32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePolygonRgn Lib "GDI32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function FillRgn Lib "GDI32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Long
Private Declare Function SetBkColor Lib "GDI32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateDCAsNull Lib "GDI32" Alias "CreateDCA" (ByVal lpDriverName As String, _
lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateDC Lib "GDI32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetObjectAPI Lib "GDI32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'*******************************
'Internal Sizes
'*******************************
Private cWIDTH As Long
Private cHEIGHT As Long
Private cDEPTH As Long
'*******************************
'Constants used for Rotation
'*******************************
'Private Const Pi = 3.14159265
Private Const SPIN = 0.3 / 180
'*******************************
'These represent the ORIGINAL Verticies of the object
'*******************************
Private Vert(7) As Point3D
'*******************************
'Array of Collections that holds the Coordinates of each Face. See CreateCube()
'*******************************
Private Faces(5) As Collection
'Public Variables
'*******************************
'Roll
' Determines The Rotation around the Z axis
'Pitch
' Determines The Rotation around the X axis
'Yaw
' Determines The Rotation around the Y axis
'*******************************
Public Roll As Double, Pitch As Double, Yaw As Double
'*******************************
'All values are the Center Positions of the Cube
'Z determines how close the Cube appears
'The higher Z, the Further away the Cube is
'*******************************
Public x As Long, y As Long, z As Long
'*******************************
'DoubleBuffer
' All Faces are Draw in Memory, and then are drawn to the specified Device Context (hDc) ounce
'TransparentBackground
' Determines if the Background color should be drawn to the specified Device Context (hDc).
' Note. The Background color has to be white for drawing purposes
'*******************************
Public DoubleBuffer As Boolean, TransparentBackground As Boolean
'*******************************
'GDI Variables
'Memory Dc's
Private MemoryDc As Long
Private TempDC As Long
Private MonoMaskDC As Long
'Bitmaps
Private hMonoMask As Long
'Width and Height of the Memory DC's. Equal to the Maximum distance on point in the cube could be from another
Private MemorySize As Long
'Brushes
Private WhiteBrsh As Long
'*******************************
'SideColor
' Holds the Color of the Side of the Face(FaceConst)
'SidBrsh
' Holds the Brush Object for the Face(FaceConst)
'*******************************
Private SideColor(5) As Long
Private SideBrsh(5) As Long
'*******************************
'Used purely for Intellesence purposes
Public Enum FaceConst
One = 0
Two = 1
Three = 2
Four = 3
Five = 4
Six = 5
End Enum
'*******************************
'Draws the Cube at the position given by the cube's x, y, and z properties
' with rotation given by Roll, Pitch, and Yaw properties
'*******************************
Public Sub Draw(hDC As Long)
Dim TwoD(7) As POINTAPI
Dim LowZ As Long
'*******************************
'This was a rather ingenious method of figuring out which faces to draw
'The ConvertVertsto2d function returns what the index of the closest Z Value
'Knowing this we can assume that any Face not containing that point is should not be drawn
'Only three faces can be seen on a Cube
'*******************************
LowZ = CovertVertsto2d(TwoD) 'Note that it returns the index of the Closest Z, not the value
Dim Rc As RECT
If DoubleBuffer Then
'Redraw Background
Rc.Right = MemorySize
Rc.Bottom = MemorySize
FillRect MemoryDc, Rc, WhiteBrsh
ElseIf Not TransparentBackground Then
'Draw Background Color if not double buffering
With Rc
.Left = Me.x - MemorySize / 2
.Right = .Left + MemorySize
.Top = Me.y - MemorySize / 2
.Bottom = .Top + MemorySize
End With
FillRect hDC, Rc, WhiteBrsh
End If
Dim i As Long
For i = 0 To 5
If MemberInCollection(LowZ, Faces(i)) Then
DrawFace hDC, Faces(i), TwoD, i
End If
Next
If DoubleBuffer Then
Dim DstLeft As Long, DstTop As Long
DstLeft = Me.x - MemorySize / 2
DstTop = Me.y - MemorySize / 2
If TransparentBackground Then
'Get B&W Mask. Black Represents the Cube and White Represents the Background
BitBlt MonoMaskDC, 0, 0, MemorySize, MemorySize, MemoryDc, 0, 0, vbSrcCopy
'Draw the Background on TempDC
BitBlt TempDC, 0, 0, MemorySize, MemorySize, hDC, DstLeft, DstTop, vbSrcCopy
'Draw the Mask onto the Target DC
BitBlt TempDC, 0, 0, MemorySize, MemorySize, MonoMaskDC, 0, 0, vbSrcAnd
'Get the Negative of MonoMask
BitBlt MonoMaskDC, 0, 0, MemorySize, MemorySize, MonoMaskDC, 0, 0, vbNotSrcCopy
'Change MemoryDC's Background Color
BitBlt MemoryDc, 0, 0, MemorySize, MemorySize, MonoMaskDC, 0, 0, vbSrcAnd
'Draw MemoryDC Normally
BitBlt TempDC, 0, 0, MemorySize, MemorySize, MemoryDc, 0, 0, vbSrcPaint
'Finnally Draw The Contents
BitBlt hDC, DstLeft, DstTop, MemorySize, MemorySize, TempDC, 0, 0, vbSrcCopy
Else
BitBlt hDC, DstLeft, DstTop, MemorySize, MemorySize, MemoryDc, 0, 0, vbSrcCopy
End If
End If
End Sub
'Returns the Index of the Lowest (Closest) Z Value
Private Function CovertVertsto2d(Point2D() As POINTAPI) As Long
Dim LowZ As Double
Dim i As Long
Dim CosX As Double, CosY As Double, CosZ As Double, SinX As Double, SinY As Double, SinZ As Double
CosX = Cos(SPIN * Pitch)
SinX = Sin(SPIN * Pitch)
CosY = Cos(SPIN * Yaw)
SinY = Sin(SPIN * Yaw)
CosZ = Cos(SPIN * Roll)
SinZ = Sin(SPIN * Roll)
Dim t As Point3D
Dim n As Point3D
For i = 0 To 7
n = Vert(i)
With n
t = n
.x = CosZ * t.x - SinZ * t.y
.y = CosZ * t.y + SinZ * t.x
t = n
.x = CosY * t.x - SinY * t.z
.z = CosY * t.z + SinY * t.x
t = n
.y = CosX * t.y - SinX * t.z
.z = CosX * t.z + SinX * t.y
'Add Depth and Coordinates
Point2D(i).x = n.x * 0.999 ^ (n.z + Me.z) + Me.x
Point2D(i).y = n.y * 0.999 ^ (n.z + Me.z) + Me.y
If i = 0 Then
CovertVertsto2d = 0
LowZ = n.z
ElseIf n.z < LowZ Then
CovertVertsto2d = i
LowZ = n.z
End If
End With
Next
End Function
Private Sub Class_Initialize()
Me.TransparentBackground = True
Me.DoubleBuffer = True
Randomize
SetColor 0, Rnd * &HFFFFFF
SetColor 1, Rnd * &HFFFFFF
SetColor 2, Rnd * &HFFFFFF
SetColor 3, Rnd * &HFFFFFF
SetColor 4, Rnd * &HFFFFFF
SetColor 5, Rnd * &HFFFFFF
cWIDTH = 100
cHEIGHT = 100
cDEPTH = 100
CreateCube
End Sub
Private Sub CreateCube()
Dim i As Long
For i = 0 To 7
With Vert(i)
.x = IIf(i Mod 4 = 0 Or i Mod 4 = 3, -cWIDTH / 2, cWIDTH / 2)
.y = IIf(i Mod 4 = 0 Or i Mod 4 = 1, -cHEIGHT / 2, cHEIGHT / 2)
.z = IIf(i <= 3, -cDEPTH / 2, cDEPTH / 2)
End With
Next
'Create Face Objects (Collections)
Dim n As Collection
'Face 1
Set n = New Collection
n.Add 0
n.Add 1
n.Add 2
n.Add 3
Set Faces(0) = n
'Face 2
Set n = New Collection
n.Add 0
n.Add 1
n.Add 5
n.Add 4
Set Faces(1) = n
'Face 3
Set n = New Collection
n.Add 0
n.Add 3
n.Add 7
n.Add 4
Set Faces(2) = n
'Face 4
Set n = New Collection
n.Add 1
n.Add 2
n.Add 6
n.Add 5
Set Faces(3) = n
'Face 5
Set n = New Collection
n.Add 2
n.Add 3
n.Add 7
n.Add 6
Set Faces(4) = n
'Face 6
Set n = New Collection
n.Add 4
n.Add 5
n.Add 6
n.Add 7
Set Faces(5) = n
'Yayy!! Memory Dc time
DeleteDC MemoryDc
MemorySize = Sqr(cWIDTH ^ 2 + cHEIGHT ^ 2 + cDEPTH ^ 2)
MemoryDc = newDc(MemorySize, MemorySize)
TempDC = newDc(MemorySize, MemorySize)
MonoMaskDC = CreateCompatibleDC(MemoryDc)
hMonoMask = CreateBitmap(MemorySize, MemorySize, 1, 1, ByVal 0&)
SelectObject MonoMaskDC, hMonoMask
WhiteBrsh = CreateSolidBrush(RGB(127, 127, 0))
'All Done :)
End Sub
Private Function Dist(p1 As Point3D, p2 As Point3D) As Double
Dist = Sqr((p1.x - p2.x) ^ 2 + (p1.y - p2.y) ^ 2 + (p1.z - p2.z) ^ 2)
End Function
Private Sub DrawFace(hDC As Long, Face As Collection, P2D() As POINTAPI, SideNumber As Long)
Dim Pts(3) As POINTAPI
Pts(0) = P2D(Face(1))
Pts(1) = P2D(Face(2))
Pts(2) = P2D(Face(3))
Pts(3) = P2D(Face(4))
Dim Rgn As Long
If DoubleBuffer Then
'MovePoints About
Dim i As Long
For i = 0 To 3
With Pts(i)
.x = .x - Me.x + MemorySize / 2
.y = .y - Me.y + MemorySize / 2
End With
Next
Rgn = CreatePolygonRgn(Pts(0), UBound(Pts) + 1, 1)
FillRgn MemoryDc, Rgn, SideBrsh(SideNumber)
Else
Rgn = CreatePolygonRgn(Pts(0), UBound(Pts) + 1, 1)
FillRgn hDC, Rgn, SideBrsh(SideNumber)
End If
DeleteObject Rgn
End Sub
Private Function MemberInCollection(Member, C As Collection) As Boolean
Dim i As Long
For i = 1 To C.Count
If Member = C(i) Then
MemberInCollection = True
Exit Function
End If
Next
End Function
Public Sub SetColor(Face As FaceConst, Value As OLE_COLOR)
If Face < One Or Face > Six Then Debug.Assert False
SideColor(Face) = Value
DeleteObject SideBrsh(Face)
SideBrsh(Face) = CreateSolidBrush(Value)
End Sub
Public Function GetColor(Face As FaceConst) As OLE_COLOR
If Face < 0 Or Face > 5 Then Debug.Assert False
GetColor = SideColor(Face)
End Function
Private Function newDc(ByVal Width As Long, ByVal Height As Long) As Long
Dim m_hDC As Long
Dim m_hBmp As Long
Dim m_hBmpOld
If Width And Height Then
Dim lhDCC As Long
lhDCC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If Not (lhDCC = 0) Then
newDc = CreateCompatibleDC(lhDCC)
If Not (newDc = 0) Then
m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)
If Not (m_hBmp = 0) Then
m_hBmpOld = SelectObject(newDc, m_hBmp)
If Not (m_hBmpOld = 0) Then
DeleteDC lhDCC
Exit Function
End If
End If
End If
DeleteDC lhDCC
End If
newDc = 0
'Insufficient Memory
End If
End Function
Private Sub Class_Terminate()
DeleteDC MemoryDc
DeleteDC MonoMaskDC
DeleteDC TempDC
DeleteObject WhiteBrsh
Dim i As Long
For i = 0 To 5
DeleteObject SideBrsh(i)
Next
End Sub
Public Property Get Width() As Long
Width = cWIDTH
End Property
Public Property Let Width(n As Long)
cWIDTH = n
CreateCube
End Property
Public Property Get Height() As Long
Height = cHEIGHT
End Property
Public Property Let Height(n As Long)
cHEIGHT = n
CreateCube
End Property
Public Property Get Depth() As Long
Depth = cDEPTH
End Property
Public Property Let Depth(n As Long)
cDEPTH = n
CreateCube
End Property