1)初期設定
VB上でglutによる初期化がうまく稼動しないため,Initialize部分を以下のように設定する.Private Function Initialize() As Boolean
Dim pfd As PIXELFORMATDESCRIPTOR
Dim r&
Picture1.ScaleMode = vbPixels
pfd.nSize = Len(pfd)
pfd.nVersion = 1
pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW OrPFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
pfd.iPixelType = PFD_TYPE_RGBA
pfd.cColorBits = 24
pfd.cDepthBits = 16
pfd.iLayerType = PFD_MAIN_PLANE
r = ChoosePixelFormat(Picture1.hDC, pfd)
If r = 0 Then
MsgBox "ChoosePixelFormat failed"
Exit Function
End If
r = SetPixelFormat(Picture1.hDC, r, pfd)
m_hGLRC = wglCreateContext(Picture1.hDC)
wglMakeCurrent Picture1.hDC, m_hGLRC
Initialize = True
End Function2)バッファの切り替え
これまで利用していたglflushに代えて,以下のコマンドを用いる(Picture1を切り替える場合)SwapBuffers Picture1.hDC
1)シェーディングの設定
Initialize中に以下のコマンドを加える.
glDepthFunc GL_LEQUAL '陰面処理におけるDepthの判定方法
glEnable GL_DEPTH_TEST 'DepthTestをONにする.
glShadeModel GL_FLAT 'フラットシェーディングを行うことを宣言Draw中のglClearを以下のように変更する.
glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
Form_Initialize(), Picture1_Paint()プロシージャからの呼び出しを変更する.2)ライティングの設定
Private Sub Form_Initialize()
Timer1.Interval = 10
Timer1.Enabled = False
Initialize
End Sub
Private Sub Picture1_Paint()
ViewSet 50, Picture1.ScaleWidth / Picture1.ScaleHeight, 1, 100
SetLight
Draw
End Sub
以下のサブプロシージャを作成する.
Private Sub SetLight()
Dim ambientLight0(3) As Single
Dim positionLight0(3) As Single'fillarray4fはユーザー定義
FillArray4f ambientLight0(), 0.3!, 0.3!, 0.3!, 1!
FillArray4f positionLight0(), -2!, 10!, -4!, 1!
glLightfv GL_LIGHT0, GL_AMBIENT, ambientLight0(0)
glEnable GL_LIGHTING
glEnable GL_LIGHT0
End SubPrivate Sub FillArray4f(a() As Single, f1 As Single, f2 As Single, f3 As Single, f4 As Single)
a(0) = f1: a(1) = f2: a(2) = f3: a(3) = f4
End Sub
glNewList gluint, GL_COMPILEglEndList
gluintは整数
Option Explicit 'Form1上にPicture1及びCommand1(0), Command1(1)を配置する. '重要 Command1ボタンをコントロール配列に (Command1ボタンをコピー&貼り付けで作成できる) Dim m_hGLRC As Long Private Type pnt3d x As Single y As Single z As Single End Type Dim r As pnt3d Dim addr As pnt3d Private Sub Form_Initialize() Timer1.Interval = 10 Timer1.Enabled = False Initialize makemodel End Sub Private Sub Command1_MouseDown(index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) Dim add As Integer If Button = vbLeftButton Then add = 1 Else add = -1 Select Case index Case 0 addr.y = 0 addr.z = add * 1 Case 1 addr.y = add * 1 addr.z = 0 End Select Timer1.Enabled = True End Sub Private Sub Command1_MouseUp(index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) Timer1.Enabled = False End Sub Private Sub Picture1_Paint() ViewSet 50, Picture1.ScaleWidth / Picture1.ScaleHeight, 1, 100 SetLight Draw End Sub Private Function Initialize() As Boolean Dim pfd As PIXELFORMATDESCRIPTOR Dim r& Picture1.ScaleMode = vbPixels pfd.nSize = Len(pfd) pfd.nVersion = 1
' ダブルバッファ切替 ' ダブルバッファを使わない場合:pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW ' ダブルバッファを使う場合 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 pfd.iLayerType = PFD_MAIN_PLANE r = ChoosePixelFormat(Picture1.hDC, pfd) If r = 0 Then MsgBox "ChoosePixelFormat failed" Exit Function End If r = SetPixelFormat(Picture1.hDC, r, pfd) m_hGLRC = wglCreateContext(Picture1.hDC) wglMakeCurrent Picture1.hDC, m_hGLRC glDepthFunc GL_LEQUAL glEnable GL_DEPTH_TEST glShadeModel GL_FLAT Initialize = True End Function Private Sub Form_Unload(Cancel As Integer) If m_hGLRC <> 0 Then wglMakeCurrent 0, 0 wglDeleteContext m_hGLRC End If End Sub Private Sub ViewSet(fov As Single, aspect As Single, near As Single, far As Single) glMatrixMode GL_PROJECTION glLoadIdentity gluPerspective fov, aspect, near, far glViewport 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight '視点の設定 glTranslatef 0#, 0#, -10# glRotatef 20, 1, 0, 0 'Matrixの切替 glMatrixMode GL_MODELVIEW glLoadIdentity End Sub Private Sub makemodel() glNewList 1, GL_COMPILE glutSolidSphere 0.3, 10, 10 glutWireTorus 0.1, 0.3, 10, 20 glEndList End Sub Public Sub Draw() Dim n As Integer glClearColor 0.3, 0.3, 0.4, 0 glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT glColor3f 1#, 1#, 1# glTranslatef addr.z / 25, 0, 0 glRotatef addr.y, 0, 1, 0 drawAxisGlobal glPushMatrix glPushMatrix glTranslatef -0.5, 0, -0.3 glRotatef -r.z, 0, 0, 1 glCallList 1 glPopMatrix glPushMatrix glTranslatef 0.5, 0, -0.3 glRotatef -r.z, 0, 0, 1 glCallList 1 glPopMatrix glPushMatrix glTranslatef -0.5, 0, 0.3 glRotatef -r.z, 0, 0, 1 glCallList 1 glPopMatrix glPushMatrix glTranslatef 0.5, 0, 0.3 glRotatef -r.z, 0, 0, 1 glCallList 1 glPopMatrix glPopMatrix SwapBuffers Picture1.hDC End Sub Private Sub Timer1_Timer() r.z = r.z + addr.z r.y = r.y + addr.y Draw End Sub Public Sub drawAxisGlobal() glBegin GL_LINES glVertex3f -5, 0, 0 glVertex3f 5, 0, 0 glEnd glBegin GL_LINES glVertex3f 0, -5, 0 glVertex3f 0, 5, 0 glEnd End Sub Private Sub FillArray4f(a() As Single, f1 As Single, f2 As Single, f3 As Single, f4 As Single) a(0) = f1: a(1) = f2: a(2) = f3: a(3) = f4 End Sub Private Sub SetLight() Dim ambientLight0(3) As Single Dim positionLight0(3) As Single 'fillarray4fはユーザー定義 FillArray4f ambientLight0(), 0.3!, 0.3!, 0.3!, 1! FillArray4f positionLight0(), -2!, 10!, -4!, 1! glLightfv GL_LIGHT0, GL_AMBIENT, ambientLight0(0) glEnable GL_LIGHTING glEnable GL_LIGHT0 End Sub