リスト−１　物体の移動プロシージャを組み込む．

Private Sub Command1_Click()
    Call draw
End Sub

Private Sub Form_Load()
    Form1.ScaleMode = vbTwips
    With Picture1      'With...EndWithを用いるとプロパティの設定をブロック化できる．
        .Width = 3000
        .Height = 3000
        .ScaleHeight = -2
        .ScaleWidth = 2
        .ScaleTop = 1
        .ScaleLeft = -1
        .AutoRedraw = True
    End With
    f = -2      '投影面の位置を-2に設定する．
End Sub

Private Sub draw()
    pnt(0) = setpnt(-1, 1.5, -5)
    pnt(1) = setpnt(-1, -1.5, -5)
    pnt(2) = setpnt(1, -1.5, -5)
    pnt(3) = setpnt(1, 1.5, -5)
    pnt(4) = setpnt(-1, 1.5, -6)
    pnt(5) = setpnt(-1, -1.5, -6)
    pnt(6) = setpnt(1, -1.5, -6)
    pnt(7) = setpnt(1, 1.5, -6)
 
    Translate pnt(), 0, 7, 0, -1, -2    'X方向に0，Y方向に-1，Z方向に-2移動する．
 
    Quad pnt(0), pnt(1), pnt(2), pnt(3)
    Quad pnt(3), pnt(2), pnt(6), pnt(7)
    Quad pnt(7), pnt(6), pnt(5), pnt(4)
    Quad pnt(0), pnt(4), pnt(5), pnt(1)
    Quad pnt(0), pnt(3), pnt(7), pnt(4)
    Quad pnt(1), pnt(5), pnt(6), pnt(2)
End Sub
Private Function U(p As point3D) As Single
    U = p.x * f / p.z
End Function
Private Function V(p As point3D) As Single
    V = p.y * f / p.z
End Function

Private Function setpnt(x As Single, y As Single, z As Single) As point3D
    setpnt.x = x
    setpnt.y = y
    setpnt.z = z
End Function

Private Sub Quad(p0 As point3D, p1 As point3D, p2 As point3D, p3 As point3D)
    Picture1.Line (U(p0), V(p0))-(U(p1), V(p1))
    Picture1.Line -(U(p2), V(p2))
    Picture1.Line -(U(p3), V(p3))
    Picture1.Line (U(p3), V(p3))-(U(p0), V(p0))
End Sub

Private Sub Translate(p() As point3D, s As Integer, e As Integer, tx As Single, ty As Single, tz As Single)
    Dim n As Integer
    For n = s To e
        p(n).x = p(n).x + tx
        p(n).y = p(n).y + ty
        p(n).z = p(n).z + tz
    Next
End Sub

'プログラムが起動すると描画するように，Picture1_Paint()イベントを使う．
Private Sub Picture1_Paint()
    Call draw
End Sub
 
 

リスト−２　図形の回転（追加部分）

Private Sub draw()
    pnt(0) = setpnt(-1, 1.5, -5)
    pnt(1) = setpnt(-1, -1.5, -5)
    pnt(2) = setpnt(1, -1.5, -5)
    pnt(3) = setpnt(1, 1.5, -5)
    pnt(4) = setpnt(-1, 1.5, -6)
    pnt(5) = setpnt(-1, -1.5, -6)
    pnt(6) = setpnt(1, -1.5, -6)
    pnt(7) = setpnt(1, 1.5, -6)
 
    Translate pnt(), 0, 7, 0, -1, -2
    rotateZ pnt(), 0, 7, 40　　　　'Z軸回りで40度回転させる．
 
    Quad pnt(0), pnt(1), pnt(2), pnt(3)
    Quad pnt(3), pnt(2), pnt(6), pnt(7)
    Quad pnt(7), pnt(6), pnt(5), pnt(4)
    Quad pnt(0), pnt(4), pnt(5), pnt(1)
    Quad pnt(0), pnt(3), pnt(7), pnt(4)
    Quad pnt(1), pnt(5), pnt(6), pnt(2)
End Sub

'以下プロシージャを追加する．

Private Sub rotateX(p() As point3D, s As Integer, e As Integer, rx As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rrx As Single
    rrx = rx / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x
        p(n).y = y * Cos(rrx) - z * Sin(rrx)
        p(n).z = y * Sin(rrx) + z * Cos(rrx)
   Next
End Sub

Private Sub rotateY(p() As point3D, s As Integer, e As Integer, ry As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rry As Single
    rry = ry / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x * Cos(rry) - z * Sin(rry)
        p(n).y = y
        p(n).z = x * Sin(rry) + z * Cos(rry)
    Next
End Sub

Private Sub rotateZ(p() As point3D, s As Integer, e As Integer, rz As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rrz As Single
    rrz = rz / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x * Cos(rrz) - y * Sin(rrz)
        p(n).y = x * Sin(rrz) + y * Cos(rrz)
        p(n).z = z
    Next
End Sub
 
 

リスト-3　 任意の点を中心に回転する．（図形の中心点で回転させる）

    Quad pnt(0), pnt(1), pnt(2), pnt(3)
    Quad pnt(3), pnt(2), pnt(6), pnt(7)
    Quad pnt(7), pnt(6), pnt(5), pnt(4)
    Quad pnt(0), pnt(4), pnt(5), pnt(1)
    Quad pnt(0), pnt(3), pnt(7), pnt(4)
    Quad pnt(1), pnt(5), pnt(6), pnt(2)
End Sub
 
 

リスト-4　視点の移動（相対的な物体の移動）

    '視点の移動(視点の移動として考える場合は，正負反対で与える）
    Translate pnt(), 0, 7, 0, 1, -3  '視点をY方向に-1,z方向に＋3移動
　　　　　　　　　　　　　　　　　　　　'=物体をY方向に+1，Z方向に-3移動したのと同じこと．　　

    Quad pnt(0), pnt(1), pnt(2), pnt(3)
    Quad pnt(3), pnt(2), pnt(6), pnt(7)
    Quad pnt(7), pnt(6), pnt(5), pnt(4)
    Quad pnt(0), pnt(4), pnt(5), pnt(1)
    Quad pnt(0), pnt(3), pnt(7), pnt(4)
    Quad pnt(1), pnt(5), pnt(6), pnt(2)
End Sub

リスト-5　図形回転アニメーション

'Command1ボタンは何も効果しないので削除しても構わない．
'以下３行も削除して構わない．
'Private Sub Command1_Click()
'    Call draw
'End Sub

Private Sub Form_Load()
    Form1.ScaleMode = vbTwips
    With Picture1      'With...EndWithを用いるとプロパティの設定をブロック化できる．
        .Width = 3000
        .Height = 3000
        .ScaleHeight = -2
        .ScaleWidth = 2
        .ScaleTop = 1
        .ScaleLeft = -1
        .AutoRedraw = True  'ダブルバッファリング効果を出す
    End With
    f = -2      '投影面の位置を-2に設定する．
 
    eye.x = 0: eye.y = 1: eye.z = 8
    eyeR.x = -5: eyeR.y = 0: eyeR.z = 0
 
    Timer1.Interval = 100
    Timer1.Enabled = True
End Sub

Private Sub draw()
    Picture1.Cls  '描画の前に画面をクリア．．これを外すとどうなるか試してみること．．
 
    '図形の中心が原点になるように数値を変えているので要注意．．
    pnt(0) = setpnt(-1, 1.5, 0.5)
    pnt(1) = setpnt(-1, -1.5, 0.5)
    pnt(2) = setpnt(1, -1.5, 0.5)
    pnt(3) = setpnt(1, 1.5, 0.5)
    pnt(4) = setpnt(-1, 1.5, -0.5)
    pnt(5) = setpnt(-1, -1.5, -0.5)
    pnt(6) = setpnt(1, -1.5, -0.5)
    pnt(7) = setpnt(1, 1.5, -0.5)
 
    '図形中心点での図形回転
    rotateY pnt(), 0, 7, rot.y
    Debug.Print rot.y　　　'デバック用ウィンドウに現在のrot.yを表示させてみる．
 
    '視点の回転と移動
    rotateX pnt(), 0, 7, -eyeR.x
    Translate pnt(), 0, 7, -eye.x, -eye.y, -eye.z
 
    Quad pnt(0), pnt(1), pnt(2), pnt(3)
    Quad pnt(3), pnt(2), pnt(6), pnt(7)
    Quad pnt(7), pnt(6), pnt(5), pnt(4)
    Quad pnt(0), pnt(4), pnt(5), pnt(1)
    Quad pnt(0), pnt(3), pnt(7), pnt(4)
    Quad pnt(1), pnt(5), pnt(6), pnt(2)
End Sub

Private Function u(p As point3D) As Single
    u = p.x * f / p.z
End Function

Private Function v(p As point3D) As Single
    v = p.y * f / p.z
End Function

Private Function setpnt(x As Single, y As Single, z As Single) As point3D
    setpnt.x = x
    setpnt.y = y
    setpnt.z = z
End Function

Private Sub Quad(p0 As point3D, p1 As point3D, p2 As point3D, p3 As point3D)
    Picture1.Line (u(p0), v(p0))-(u(p1), v(p1))
    Picture1.Line -(u(p2), v(p2))
    Picture1.Line -(u(p3), v(p3))
    Picture1.Line (u(p3), v(p3))-(u(p0), v(p0))
End Sub

Private Sub Translate(p() As point3D, s As Integer, e As Integer, tx As Single, ty As Single, tz As Single)
    Dim n As Integer
    For n = s To e
        p(n).x = p(n).x + tx
        p(n).y = p(n).y + ty
        p(n).z = p(n).z + tz
    Next
End Sub
 

Private Sub rotateX(p() As point3D, s As Integer, e As Integer, rx As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rrx As Single
    rrx = rx / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x
        p(n).y = y * Cos(rrx) - z * Sin(rrx)
        p(n).z = y * Sin(rrx) + z * Cos(rrx)
    Next
End Sub

Private Sub rotateY(p() As point3D, s As Integer, e As Integer, ry As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rry As Single
    rry = ry / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x * Cos(rry) - z * Sin(rry)
        p(n).y = y
        p(n).z = x * Sin(rry) + z * Cos(rry)
    Next
End Sub

Private Sub rotateZ(p() As point3D, s As Integer, e As Integer, rz As Single)
    Dim n As Integer
    Dim x As Single, y As Single, z As Single, rrz As Single
    rrz = rz / 180 * PAI
    For n = s To e
        x = p(n).x: y = p(n).y: z = p(n).z
        p(n).x = x * Cos(rrz) - y * Sin(rrz)
        p(n).y = x * Sin(rrz) + y * Cos(rrz)
        p(n).z = z
    Next
End Sub

Private Sub Picture1_Paint()
    Call draw
End Sub

Private Sub Timer1_Timer()
    '回しつづけると将来的にはオーバーフローするので，
    '360度を越えないように Mod 360で 360で割った余りを算出する．
    rot.y = (rot.y + 5) Mod 360
    draw
End Sub