-
Notifications
You must be signed in to change notification settings - Fork 0
/
Procedures.bas
201 lines (189 loc) · 7.68 KB
/
Procedures.bas
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
Attribute VB_Name = "Procedures"
Option Explicit
Public AspectRatio As Double
Public hGLRC&
Public obj&
Public startx&, starty&
Public anglez&, anglex&, border&, titlebar&, height&, width&, koeff&
Public Speed!
Public Sub InitOpenGL()
Dim pfd As PIXELFORMATDESCRIPTOR
Dim R&, pos!(0 To 3)
pfd.nSize = Len(pfd)
pfd.nVersion = 1
'Ïîñêîëüêó ñîáèðàþñü âûâîäèòü ãðàôè÷åñêèå îáúåêòû â îêíî, òî íóæíî âûñòàâèòü ôëàã PFD_DRAW_TO_WINDOW
'ñîîáùàþ, ÷òî áóôåð êàäðà ïîääåðæèâàåò âûâîä ÷åðåç OpenGL - PFD_SUPPORT_OPENGL
'è, òàê êàê èñïîëüçóåòñÿ äâà áóôåðà êàäðîâ (Back è Front), óñòàíàâëèâàåì ôëàã PFD_DOUBLEBUFFER
'PFD_TYPE_RGBA - äëÿ èñïîëüçîâàíèÿ öâåòîâîé ñõåìû RGBA äëÿ ïèêñåëåé
pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW Or PFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
'pfd.iPixelType = PFD_TYPE_RGBA
pfd.cColorBits = 24 '÷èñëî áèòîâûõ ïëîñêîñòåé â êàæäîì áóôåðå öâåòà
pfd.cDepthBits = 16 'ðàçìåð áóôåðà ãëóáèíû (îñü z)
pfd.iLayerType = PFD_MAIN_PLANE 'òèï ïëîñêîñòè
R = ChoosePixelFormat(Trackball.hDC, pfd) 'çàïðîñ íà âûáîð ñàìîãî ïîäõîäÿùåãî ôîðìàòà äëÿ ôîðìû-òðåêáîëà. Ýòà ôóíêöèÿ
' âîçâðàùàåò ïîäîáðàííûé äëÿ óêàçàííîãî êîíòåêñòà óñòðîéñòâà èíäåêñ ôîðìàòà
If R = 0 Then 'åñëè ïîäîáðàòü íå óäàëîñü
MsgBox "ChoosePixelFormat failed"
Exit Sub
End If
R = SetPixelFormat(Trackball.hDC, R, pfd) 'âûñòàâëåíèå ïèêñåëüíîãî ôîðìàòà
hGLRC = wglCreateContext(Trackball.hDC) 'ñîçäàíèå ãðàôè÷åñêîãî êîíòåêñòà äëÿ ôîðìû-òðåêáîëà
wglMakeCurrent Trackball.hDC, hGLRC 'ñîçäàííûé êîíòåêñò âûñòàâëÿåòñÿ òåêóùèì
glClearColor 0, 0, 0, 1 'óñòàíàâëèâàåò ÷åðíûé íåïðîçðà÷íûé öâåò ôîíà
glClearDepth 1 'î÷èñòêà áóôåðà ãëóáèíû
glEnable GL_DEPTH_TEST 'âêëþ÷åíèå òåñòà ãëóáèíû êàäðîâ
glEnable glcColorMaterial
glColorMaterial faceFront, GL_AMBIENT_AND_DIFFUSE 'óñòàíîâêà ñâîéñòâ ìàòåðèàëà
glEnable GL_LIGHTING '"âêëþ÷åíèå" îñâåùåíèÿ
glEnable glcLight0 '"âêëþ÷åíèå" èñòî÷íèêà îñâåùåíèÿ
pos(0) = 10: pos(1) = 10: pos(2) = 10: pos(3) = 1 'ïîëîæåíèå ëàìïû
glLightfv ltLight0, lpmPosition, pos(0) 'íàïðàâëåíèå ñâåòà
AspectRatio = 1 'ñîîòíîøåíèå ñòîðîí. íóæíî äëÿ óñòàíîâêè òî÷êè îáçîðà
obj = gluNewQuadric 'îáúÿâëÿþ îáüåêò êàê êàðêàñíûé
End Sub
Public Sub TrackballMouseMove(X As Single, Y As Single)
anglez = anglez + Speed / 8 * (X - startx) 'ïåðåâîä ïåðåìåùåíèÿ óêàçàòåëÿ îòíîñèòåëüíî íà÷àëüíîãî ïîëîæåíèÿ ïðè íàæàòèè
anglex = anglex + Speed / 8 * (Y - starty)
If anglez < 0 Then anglez = 0 'åñëè óãëû âûõîäÿò çà äîïóñòèìûå ãðàíèöû, òî óãëû "çàìîðàæèâàþòñÿ"=âðàùåíèå òðåêáîëà ïðåêðàùàåòñÿ
If anglez > 360 Then anglez = 360
If anglex < 0 Then anglex = 0
If anglex > 360 Then anglex = 360
If (anglez > 0) And (anglez < 360) And (anglex > 0) And (anglex < 360) Then Draw 'ïåðåðèñîâêà øàðà ïðè äîïóñòèìûõ óãëàõ ïîâîðîòà
PicField.Image1.Left = anglez / 360 * PicField.ScaleWidth - PicField.Image1.width / 2 'ïåðåâîä óãëîâ â ýêðàííûå êîîðäèíàòû
PicField.Image1.Top = anglex / 360 * PicField.ScaleHeight - PicField.Image1.height / 2
Trackball.Label1.Caption = PicField.Image1.Left + PicField.Image1.width / 2
Trackball.Label2.Caption = PicField.Image1.Top + PicField.Image1.height / 2
startx = X
starty = Y
End Sub
Public Sub DrawTable()
glBegin (GL_POLYGON) 'êðûøêà
glNormal3f 0, 1, 0 'íîðìàëü íóæíà äëÿ îñâåùåíèÿ
glColor3f 1, 1, 1 'öâåò - áåëûé
glVertex3f 0, -1, 1 'ïåðåäíÿÿ òî÷êà
glVertex3f 2, 0, 0 'ïðàâàÿ
glVertex3f 0, 1, -2 'çàäíÿÿ
glVertex3f -2, 0, 0 'ëåâàÿ
glEnd
glBegin (GL_POLYGON) 'ëåâàÿ ñòåíêà
glNormal3f -1, 0, 1
glColor3f 1, 1, 1
glVertex3f 0, -1, 1 'ïåðåäíÿÿ òî÷êà
glVertex3f -2, 0, 0 'ëåâàÿ
glVertex3f -2, -0.25, 0 '
glVertex3f 0, -1.25, 1
glEnd
glBegin (GL_POLYGON)
glNormal3f 0.5, 0, 0.5
glColor3f 1, 1, 1
glVertex3f 0, -1, 1 'ïåðåäíÿÿ òî÷êà
glVertex3f 0, -1.25, 1
glVertex3f 2, -0.25, 0
glVertex3f 2, 0, 0 'ïðàâàÿ
glEnd
End Sub
Public Sub PicFieldSetCursor()
PicField.MousePointer = 99
PicField.MouseIcon = LoadPicture(App.Path & "\hand.ico")
End Sub
Public Sub PicFieldEscape(Keycode)
Select Case (Keycode)
Case 27: Unload PicField
End Select
End Sub
Public Sub TrackballEscape(Keycode)
Select Case (Keycode)
Case 27: Unload Trackball: Unload PicField
End Select
End Sub
Public Sub Sizing(ByVal W&, ByVal H&)
If H = 0 Then H = 1
AspectRatio = W / H
glViewport 0, 0, W, H
glMatrixMode mmProjection
glLoadIdentity
gluPerspective 45, AspectRatio, 0.5, 200
gluLookAt 0, 0, 6, 0, 0, 0, 0, 1, 0
glMatrixMode mmModelView
glLoadIdentity
End Sub
Public Sub TrackballSetCursor()
Trackball.MousePointer = 99
Trackball.MouseIcon = LoadPicture(App.Path & "\hand.ico")
PicField.Image1.Picture = LoadPicture(App.Path & "\cross.cur")
Trackball.SpeedEight.Checked = True
End Sub
Public Sub UnloadGL()
If hGLRC <> 0 Then
wglMakeCurrent 0, 0
wglDeleteContext hGLRC
End If
End Sub
Public Sub Draw()
wglMakeCurrent Trackball.hDC, hGLRC
glClear clrColorBufferBit Or clrDepthBufferBit
glMatrixMode (mmModelView)
glLoadIdentity
glPushMatrix
glRotatef anglex, 1, 0, 0
glRotatef anglez, 0, 1, 0
glColor3f 1, 0, 0
gluSphere obj, 1, 20, 20
glPopMatrix
DrawTable
glFlush
SwapBuffers Trackball.hDC
End Sub
Public Sub TrackballMouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
startx = X
starty = Y
If Trackball.SpeedOne.Checked Then Speed = 1
If Trackball.SpeedTwo.Checked Then Speed = 2
If Trackball.SpeedFour.Checked Then Speed = 4
If Trackball.SpeedEight.Checked Then Speed = 8
If Trackball.Speed16.Checked Then Speed = 16
End If
If Button = 2 Then
On Error GoTo ErrorHandler
Trackball.CommonDialog1.CancelError = True
Trackball.CommonDialog1.Filter = "Ãðàôèêà|*.jpg;*.bmp|"
Trackball.CommonDialog1.ShowOpen
border = (PicField.width - PicField.ScaleWidth * Screen.TwipsPerPixelX) / 2
titlebar = PicField.height - PicField.ScaleHeight * Screen.TwipsPerPixelY
PicField.Picture = LoadPicture(Trackball.CommonDialog1.FileName)
height = PicField.ScaleY(PicField.Picture.height, vbHimetric, vbPixels)
width = PicField.ScaleX(PicField.Picture.width, vbHimetric, vbPixels)
koeff = height / width
If width > (Screen.width - Trackball.width - Trackball.Left) / Screen.TwipsPerPixelX Or height > Screen.height / Screen.TwipsPerPixelY Then
MsgBox "Âû ïûòàåòåñü çàãðóçèòü èçîáðàæåíèå, êîòîðîå áîëüøå ñâîáîäíîé îáëàñòè ýêðàíà! Ïðàâèëüíîå îòîáðàæåíèå íå ãàðàíòèðóåòñÿ!", vbOKOnly, "Ïðåäóïðåæäåíèå"
If height > width Then
PicField.height = Screen.height
PicField.width = PicField.height / koeff
Else:
PicField.width = Screen.width - Trackball.width - Trackball.Left
PicField.height = PicField.width * koeff
End If
Else: PicField.width = width * Screen.TwipsPerPixelX + 2 * border
PicField.height = height * Screen.TwipsPerPixelY + titlebar
End If
PicField.Top = 0
PicField.Left = Trackball.Left + Trackball.width
PicField.Image1.ZOrder vbBringToFront
anglez = 0: anglex = 0
PicField.Image1.Left = anglez - PicField.Image1.width / 2
PicField.Image1.Top = anglex - PicField.Image1.height / 2
PicField.Show
ErrorHandler:
If Err.Number = 32755 Then
Exit Sub
End If
End If
End Sub
Public Sub UnCheckMenu()
Trackball.SpeedOne.Checked = False
Trackball.SpeedTwo.Checked = False
Trackball.SpeedFour.Checked = False
Trackball.SpeedEight.Checked = False
Trackball.Speed16.Checked = False
End Sub