frmsimple.frm

老外用VB写的CNC仿真程序源码

VERSION 5.00
Begin VB.Form frm3D 
   BorderStyle     =   0  'None
   Caption         =   "3D"
   ClientHeight    =   6645
   ClientLeft      =   180
   ClientTop       =   1485
   ClientWidth     =   7770
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   443
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   518
   ShowInTaskbar   =   0   'False
   WindowState     =   2  'Maximized
End
Attribute VB_Name = "frm3D"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'/******************************Module*Header******************************
'FUNCTION: simple demo of the basics of opengl
'    - gl setup, resize, and drawing
'AUTHOR: edx - [e-mail], Feb 98
'HISTORY: -
'/*************************************************************************
Const WORLD_LIST = 1000000
Private m_fieldOfView As Double
Private m_NearPlane As Double
Private m_FarPlane As Double
Private m_AspectRatio As Double
Dim m_hGLRC&
Dim XAngle, YAngle, ZAngle As Double
Dim R&, pos!(0 To 3)
Dim axes As Boolean

    Dim lbgColor As Long

Dim BC As Double
Dim GC As Double
Dim RC As Double

Dim rotate As Boolean
    
Public Function Initialize() As Boolean
XAngle = 0
YAngle = 0
ZAngle = 0
lbgColor = SimWindow.WPColor
    RC = (lbgColor Mod &H100) / 255
    lbgColor = lbgColor \ &H100
    GC = (lbgColor Mod &H100) / 255
    lbgColor = lbgColor \ &H100
    BC = (lbgColor Mod &H100) / 255
    
Dim pfd As PIXELFORMATDESCRIPTOR

'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(hdc, pfd)
    
    If R = 0 Then
        MsgBox "ChoosePixelFormat failed"
        Exit Function
    End If
    
    R = SetPixelFormat(hdc, R, pfd)
    'palette?
    '
    m_hGLRC = wglCreateContext(hdc)
    wglMakeCurrent hdc, m_hGLRC
    glClearColor 0, 0, 0, 1
    'depth
    glClearDepth 1
    glEnable GL_DEPTH_TEST
    'color
    glEnable glcColorMaterial
    glColorMaterial faceFrontAndBack, cmmAmbientAndDiffuse
    'lighting
    glEnable GL_LIGHTING
    glEnable glcLight0
       
    'viewport
    m_AspectRatio = 1
    m_FarPlane = 200
    m_NearPlane = 0.5
    m_fieldOfView = 30
    '
    DrawWorld
    Initialize = True
End Function

Public Sub DrawWorld()
Dim obj&
Dim i As Integer

lbgColor = SimWindow.WPColor
    RC = (lbgColor Mod &H100) / 255
    lbgColor = lbgColor \ &H100
    GC = (lbgColor Mod &H100) / 255
    lbgColor = lbgColor \ &H100
    BC = (lbgColor Mod &H100) / 255
    
glPushMatrix
    glNewList WORLD_LIST, GL_COMPILE
        obj = gluNewQuadric
        
     

If axes = True Then
            glColor3f 0, 0, 1
            gluCylinder obj, 0.02, 0.02, 10, 6, 6

            glRotatef 90, 0, 1, 0
            glColor3f 1, 0, 0
            gluCylinder obj, 0.02, 0.02, 10, 6, 6

            glRotatef -90, 1, 0, 0
            glColor3f 0, 1, 0
            gluCylinder obj, 0.02, 0.02, 10, 6, 6

            glRotatef 90, 1, 0, 0
            glRotatef -90, 0, 1, 0
        End If

          
       glRotatef XAngle, 1, 0, 0
        glRotatef YAngle, 0, 1, 0
        glRotatef ZAngle, 0, 0, 1
 



        glColor3f 0.7, 0.7, 0.7

        glRotatef 90, 0, 1, 0
        Dim length, radius, radiusP As Double
    Static TapperStart As Boolean
    i = 0
    length = 0#
    radius = ThreeDArray(0, 0)
    glTranslatef 0#, 0#, UBound(ThreeDArray) / 100
    radiusP = ThreeDArray(1, 0)
    glColor3f RC + 0.1, GC + 0.1, BC + 0.1
    gluDisk obj, 0, radius / 50, 64, 64
    glColor3f RC, GC, BC

    Do While (i < UBound(ThreeDArray))

   If (ThreeDArray(i, 1) <> ThreeDArray(i + 1, 1)) Then
                glTranslatef 0#, 0#, -length
                gluCylinder obj, radius / 50, radiusP / 50, length, 64, 1
                If i = 0 Then i = 2
                    radiusP = ThreeDArray(i - 1, 0)
                
                length = 0
       
            
        ElseIf (ThreeDArray(i, 0) <> ThreeDArray(i + 1, 0)) And ThreeDArray(i, 1) = 0 Then
            glTranslatef 0#, 0#, -length
            gluCylinder obj, radius / 50, radiusP / 50, length, 64, 1
            If i <> 0 Then radiusP = ThreeDArray(i + 1, 0)
            If length > 0.1 Then gluDisk obj, 0, ThreeDArray(i + 1, 0) / 50, 64, 64
            length = 0
    End If

        radius = ThreeDArray(i, 0)
        length = length + 0.02
       i = i + 1
'        If ThreeDArray(i, 1) = 1 Then
'            glTranslatef 0#, 0#, -length
'            gluCylinder obj, radius / 50, radiusP / 50, length, 64, 1
'            radius = ThreeDArray(i, 0)
'            radiusP = ThreeDArray(i - 1, 0)
'            length = 0.02
'        End If
'        length = length + 0.02
'
'        If (ThreeDArray(i, 0) <> CInt(radius)) Or TapperStart = True Then
'                glTranslatef 0#, 0#, -length
'                gluCylinder obj, radius / 50, radiusP / 50, length, 64, 1
'                radius = ThreeDArray(i, 0)
'                radiusP = ThreeDArray(i - 1, 0)
'                length = 0.02
'           ' End If
'        Else
'            length = length + 0.02
'        End If
    Loop

    glTranslatef 0#, 0#, -length
    gluCylinder obj, radius / 50, radiusP / 50, length, 64, 1
    glColor3f RC + 0.1, GC + 0.1, BC + 0.1
    gluDisk obj, 0, radius / 50, 64, 64
    glEndList
    TapperStart = False
glPopMatrix
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    'MsgBox KeyCode
    Select Case KeyCode
    Case 27:
        Unload Me
    Case 88:
        axes = Not axes
        DrawWorld
        Display
    Case 97:
        XAngle = XAngle + 3
        DrawWorld
        Display
    Case 100:
        XAngle = XAngle - 3
        DrawWorld
        Display
    Case 98:
        YAngle = YAngle + 3
        DrawWorld
        Display
    Case 101:
        YAngle = YAngle - 3
        DrawWorld
        Display
    Case 99:
        ZAngle = ZAngle + 3
        DrawWorld
        Display
    Case 102:
        ZAngle = ZAngle - 3
        DrawWorld
        Display
    Case 103:
        XAngle = 0
        DrawWorld
        Display
    Case 104:
        YAngle = 0
        DrawWorld
        Display
    Case 105:
        ZAngle = 0
        DrawWorld
        Display
    
    Case 107:
        
        m_fieldOfView = m_fieldOfView - 1
        SetViewPort
        Display
    Case 109:
        m_fieldOfView = m_fieldOfView + 1
        SetViewPort
        Display
    Case 96:
        XAngle = 0
        YAngle = 0
        ZAngle = 0
        DrawWorld
        Display
    Case 116:
        rotate = True
        While (rotate = True)
            YAngle = YAngle - 1
            DrawWorld
            Display
            DoEvents
        Wend
    Case 117:
        rotate = False
    End Select
    
End Sub



Private Sub Form_Load()
Initialize
End Sub

Private Sub Form_Paint()
    Display
End Sub

Private Sub Form_Resize()
Static W&, H&
Dim w1&, h1&
    w1 = ScaleWidth
    h1 = ScaleHeight
    OnSize w1, h1
    If w1 <= W And h1 <= H Then Display 'force a repaint
    W = w1: H = h1
End Sub

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

Public Sub Display()
Static Busy As Boolean
    If Busy Then Exit Sub
    Busy = True
    glClear clrColorBufferBit Or clrDepthBufferBit
    glPushMatrix
        gluLookAt 10, 10, 10, 0, 0, 0, 0, 1, 0
        glCallList WORLD_LIST
    glPopMatrix
    glFinish
    SwapBuffers hdc
    Busy = False
End Sub

'Adjusts the viewport to match the window size.
Public Sub OnSize(ByVal W&, ByVal H&)
If H = 0 Then H = 1
m_AspectRatio = W / H
glViewport 0, 0, W, H
SetViewPort
End Sub

Private Sub SetViewPort()
Dim W&, H&
Dim X#, Y#, Z#

glMatrixMode mmProjection
glLoadIdentity
gluPerspective m_fieldOfView, _
                   m_AspectRatio, _
                   m_NearPlane, _
                   m_FarPlane
glMatrixMode mmModelView
glLoadIdentity
End Sub