１．２つのピクチャウィンドウを用いた立体視プログラム

２．アニメーション

３．コード

'Stereo Graphics sample
'Form1上にCommand1,Command2,Picture1(0),Picture1(1)（コントロール配列）が必要
Option Explicit
Dim m_hGLRC(0 To 1) As Long
Private Type axis
    X As Single
    Y As Single
    z As Single
End Type

Dim rot As axis
Dim tr As axis
Dim addt As axis
Dim addr As axis
Dim r As Single
Dim z As Single
Dim eye As Single

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        addt.X = 0: addt.Y = 0: addt.z = 0
        addr.X = 0: addr.Y = 1: addr.z = 0
    Else
        addt.X = 0: addt.Y = 0: addt.z = 0
        addr.X = 0: addr.Y = -1: addr.z = 0
    End If
    Timer1.Enabled = Not Timer1.Enabled
End Sub

Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = Not Timer1.Enabled
End Sub

Private Sub Command2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = Not Timer1.Enabled
End Sub

Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        addt.X = 0: addt.Y = 0: addt.z = 0
        addr.X = 0: addr.Y = 0: addr.z = 1
    Else
        addt.X = 0: addt.Y = 0: addt.z = 0
        addr.X = 0: addr.Y = 0: addr.z = -1
    End If
    Timer1.Enabled = Not Timer1.Enabled

End Sub

Private Sub Form_Load()
    Timer1.Interval = 10
    Timer1.Enabled = False
    '初期設定としてCommand2_MouseDownを動かす．
    Call Command2_MouseDown(vbLeftButton, 0, 0, 0)

    Command1.Caption = "回転"
    Command2.Caption = "アーム"
    tr.z = 0
    eye = 0.2  '両眼の間隔

End Sub

Private Sub SetView(index As Integer)
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 50, Picture1(index).ScaleWidth / Picture1(index).ScaleHeight, 0.1, 20
    glMatrixMode GL_MODELVIEW
    glViewport 0, 0, Picture1(index).Width, Picture1(index).Height
End Sub

Private Sub Form_Initialize()
    Initialize (0)
    Initialize (1)
End Sub

Private Function Initialize(index As Integer) As Boolean
    Dim pfd As PIXELFORMATDESCRIPTOR
    Dim r&
    Picture1(index).ScaleMode = vbPixels

    'set standard parameters
    pfd.nSize = Len(pfd)
    pfd.nVersion = 1
    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(index).hDC, pfd)
    If r = 0 Then
        MsgBox "ChoosePixelFormat failed"
        Exit Function
    End If
    r = SetPixelFormat(Picture1(index).hDC, r, pfd)
    'palette?
    m_hGLRC(index) = wglCreateContext(Picture1(index).hDC)
    wglMakeCurrent Picture1(index).hDC, m_hGLRC(index)

    glDisable GL_DEPTH_TEST

    SetView 0
    Initialize = True
End Function

Private Sub Form_Unload(Cancel As Integer)
    If m_hGLRC(0) <> 0 Or m_hGLRC(1) <> 0 Then
        wglMakeCurrent 0, 0
        wglDeleteContext m_hGLRC(0)
        wglDeleteContext m_hGLRC(1)
    End If
End Sub
 

Private Sub display(index As Integer)
    wglMakeCurrent Picture1(index).hDC, m_hGLRC(index)
    glClearColor 0, 0, 0, 0
    glClear GL_COLOR_BUFFER_BIT
    glColor3f 1#, 1#, 1#
    glLoadIdentity

    If index = 0 Then
        glTranslatef eye / 2, 0, 0
    Else
        glTranslatef -eye / 2, 0, 0
    End If
 

    glTranslatef 0#, 0#, -3#

    glPushMatrix
        glTranslatef 0, -1, -0
        glTranslatef tr.X, tr.Y, tr.z
        glRotatef rot.Y, 0, 1, 0
        glRotatef rot.z, 0, 0, 1
        glPushMatrix
            glTranslatef 0, 0.5, 0
            glScalef 0.2, 1, 0.2
            glutWireCube 1
        glPopMatrix
        glTranslatef 0, 1, 0
        glRotatef rot.z * 2, 0, 0, 1
        glPushMatrix
            glTranslatef 0, 0.5, 0
            glScalef 0.2, 1, 0.2
            glutWireCube 1
        glPopMatrix
    glPopMatrix

    glPushMatrix
        glTranslatef 0, 0, -7
        glRotatef 90, 1, 0, 0
        glRotatef r, 0, 1, 0
        glutWireSphere 4, 20, 20
    glPopMatrix

    glPushMatrix
        glTranslatef 0, 0, -15
        glRotatef r, 0, 1, 0
        glutWireCube 4
    glPopMatrix

    glPushMatrix
        glColor3f 1, 0, 0
        glTranslatef 0, 0, -5
        glTranslatef 0, 0, z * 5
        glScalef 0.2, 1, 0.2
        glutWireCube 2
    glPopMatrix

    SwapBuffers Picture1(index).hDC
End Sub
 

Private Sub Picture1_Paint(index As Integer)
    display index
End Sub

Private Sub Timer1_Timer()
    rot.Y = rot.Y + 3 * addr.Y
    rot.z = rot.z + 3 * addr.z
    tr.X = tr.X + 0.2 * Sin((rot.Y) / 180 * 3.1415) * addt.z
    tr.z = tr.z + 0.2 * Cos((rot.Y) / 180 * 3.1415) * addt.z
    r = (r + 10) Mod 360
    z = Sin(r / 360 * 3.1415)
    display 0
    display 1
End Sub