frmmain.frm

3ds文件浏览程序

gCtl.Render
End Sub


Private Sub glxCtl1_KeyDown(KeyCode As Integer, Shift As Integer)
    GL.KeyDown KeyCode, Shift
End Sub


Private Sub glxCtl1_Draw()
GL.Draw
End Sub

Private Sub glxCtl1_InitGL()
GL.InitGL
End Sub

Private Sub glxCtl1_Init()
GL.Init
End Sub

Private Sub glxCtl1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
GL.MouseDown Button, Shift, x, y
End Sub

Private Sub glxCtl1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
GL.MouseMove Button, Shift, x, y
End Sub

Private Sub glxCtl1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
GL.MouseUp Button, Shift, x, y
End Sub

Private Sub glxCtl1_Paint()
gCtl.Render
End Sub

Private Sub glxCtl1_Pick(items() As Long)
'
End Sub

Private Sub glxCtl1_Resize(width As Long, height As Long, default As Boolean)
default = GL.Reshape(width, height)
End Sub

Private Sub mnuHelpAbout_Click()
    'frmAbout.Show vbModal, Me
End Sub

Private Sub mnuFErrors_Click()
    frmLog.Show
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuFileMaterials_Click()
    frmMaterials.Show
End Sub

Private Sub mnuFileOpen_Click()
Dim File As String
Dim s$
On Error Resume Next
With CD
    .DialogTitle = "Open"
    .InitDir = LastPath
    'ToDo: set the flags and attributes of the common dialog control
    s = "3DS files(*.3ds)|*.3ds|Obj files(*.obj)|*.obj|All Files (*.*)|*.*"
    .Filter = s
    .FilterIndex = 3
    .ShowOpen
    If Err Then Exit Sub
    File = .Filename
    If Len(File) = 0 Then
        Exit Sub
    End If
    If StrComp(Right$(File, 3), "3ds", 1) = 0 Then
        Read3ds File
    ElseIf StrComp(Right$(File, 3), "obj", 1) = 0 Then
        ReadOBJ File
    End If
End With
gCtl.Render
End Sub

Private Sub mnuFileProperties_Click()
'
End Sub

Private Sub mnuFileSaveAs_Click()
'
End Sub

Private Sub mnuVCull_Click()
    mnuVCull.Checked = Not mnuVCull.Checked
    If mnuVCull.Checked Then
        glEnable GL_CULL_FACE
    Else
        glDisable GL_CULL_FACE
    End If
    Scene.Compile
End Sub

Private Sub mnuViewGrid_Click()
    mnuViewGrid.Checked = Not mnuViewGrid.Checked
    GL.Grid = (mnuViewGrid.Checked = True)
    If mnuViewGrid.Checked Then
        Toolbar1.Buttons("grid").Value = tbrPressed
    Else
        Toolbar1.Buttons("grid").Value = tbrUnpressed
    End If
End Sub

Private Sub mnuViews_Click(Index As Integer)
    GL.View = Index
End Sub

Private Sub mnuViewTexture_Click()
    mnuViewTexture.Checked = Not mnuViewTexture.Checked
    optTextures = mnuViewTexture.Checked
    Scene.Compile
End Sub

Private Sub mnuWireframe_Click()
Dim i&
    mnuWireframe.Checked = Not mnuWireframe.Checked
    If mnuWireframe.Checked Then
        glPolygonMode GL_FRONT_AND_BACK, GL_LINE
        glDisable GL_LIGHTING
        Toolbar1.Buttons("displaymode").Value = tbrPressed
        optWireFrame = True
    Else
        glPolygonMode GL_FRONT_AND_BACK, GL_FILL
        glEnable GL_LIGHTING
        Toolbar1.Buttons("displaymode").Value = tbrUnpressed
        optWireFrame = False
    End If
    Scene.Compile
End Sub

Private Sub Split_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim r&, rc As RECT, pt As POINTL
On Error GoTo ErrorHandler
'------------------------------------------------------------
r = SetCapture(Split.hWnd)
    '------------------------------
    'set clip rect to current mouse y
    pt.x = x: pt.y = y
    r = ClientToScreen(Split.hWnd, pt)
    rc.Top = pt.y: rc.bottom = pt.y
    '-----------------------------
    'set clip rect x values to form's size
    pt.y = 0 'dummy
    pt.x = 15 'minimum left travel
    r = ClientToScreen(Me.hWnd, pt)
    rc.Left = pt.x
    pt.y = 0
    pt.x = ScaleWidth - 3  'max right travel
    r = ClientToScreen(Me.hWnd, pt)
    rc.Right = pt.x
r = ClipCursor(rc) 'set clip rect
'
Splitting = -1
hDCScreen = GetDC(0)
If hDCScreen = 0 Then
    GoTo ErrorHandler
End If

hRegion = CreateRectRgn(0, 0, (Screen.width) \ tx, (Screen.height) \ ty)
If hRegion = 0 Then GoTo ErrorHandler
r = SelectClipRgn(hDCScreen, hRegion)
hBrush = GetStockObject(NULL_BRUSH)
hObjOld = SelectObject(hDCScreen, hBrush)
oldROP = SetROP2(hDCScreen, R2_NOTXORPEN) 'oldROP = SetROP2(hDCScreen, R2_NOT)
'
pt.x = TV1.width
pt.y = TV1.Top
r = ClientToScreen(Me.hWnd, pt)
sLength = TV1.height
mx = pt.x
my = pt.y
r = Rectangle(hDCScreen, mx, my, mx + 6, my + sLength)
Exit Sub
'
ErrorHandler:
    Splitting = 0
    ReleaseCapture
    r = ClipCursorFree(0)
    r = DeleteObject(hRegion)
    r = UnrealizeObject(hDCScreen)
    hDCScreen = ReleaseDC(0, hDCScreen)
    Exit Sub
End Sub

Private Sub Split_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim r&, pt As POINTL
On Error GoTo ErrorHandler
'------------------------------------------------------------
If Splitting Then
    r = Rectangle(hDCScreen, mx, my, mx + 6, my + sLength)
    '
    pt.x = x + TV1.width
    pt.y = 0 'dummy
    r = ClientToScreen(Me.hWnd, pt)
    mx = pt.x
    r = Rectangle(hDCScreen, mx, my, mx + 6, my + sLength)
End If
'------------------------------------------------------------
Exit Sub
ErrorHandler:
Debug.Assert 0
Resume Next
End Sub

Private Sub Split_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim r&, pt As POINTAPI
On Error GoTo ErrorHandler
'------------------------------------------------------------
'
If Splitting Then
    r = Rectangle(hDCScreen, mx, my, mx + 6, my + sLength)
    Splitting = 0
    ReleaseCapture
    r = ClipCursorFree(0)
    r = DeleteObject(hRegion)
    r = UnrealizeObject(hDCScreen)
    hDCScreen = ReleaseDC(0, hDCScreen)
    Debug.Print x, y
    TV1.width = TV1.width + x
    Form_Resize
End If
'------------------------------------------------------------
Exit Sub
ErrorHandler:
Debug.Assert 0
Resume Next
End Sub

Private Sub TimeSlider_Click()

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "open": mnuFileOpen_Click
        Case "save": mnuFileSaveAs_Click
        Case "properties": mnuFileProperties_Click
        '
        Case "perspective": mnuViews_Click GLVIEW_PERSPECTIVE
        Case "front": mnuViews_Click GLVIEW_FRONT
        Case "top": mnuViews_Click GLVIEW_TOP
        Case "right": mnuViews_Click GLVIEW_RIGHT
        Case "left": mnuViews_Click GLVIEW_LEFT
        Case "back": mnuViews_Click GLVIEW_BACK
        Case "bottom": mnuViews_Click GLVIEW_BOTTOM
        '
        Case "select": GL.EditState = STATE_SELECT
        Case "zoom": GL.EditState = STATE_ZOOM
        Case "pan": GL.EditState = STATE_PAN
        '
        Case "displaymode": mnuWireframe_Click
        Case "grid": mnuViewGrid_Click
        Case "texture": mnuViewTexture_Click
    End Select
End Sub

Public Sub SetCursor(s$)
Select Case s
Case "move"
    gCtl.MousePointer = 5
    'Set gCtl.MouseIcon = CursorPan.Picture
Case "rotate"
    gCtl.MousePointer = 99
    Set gCtl.MouseIcon = CursorRotate.Picture
Case "scale"
    gCtl.MousePointer = 99
    Set gCtl.MouseIcon = CursorScale.Picture
Case "zoom"
    gCtl.MousePointer = 99
    Set gCtl.MouseIcon = CursorZoom.Picture
Case "arcrotate"
    gCtl.MousePointer = 99
    Set gCtl.MouseIcon = CursorArcRotate.Picture
Case "pan"
    gCtl.MousePointer = 99
    Set gCtl.MouseIcon = CursorPan.Picture
Case Else
    gCtl.MousePointer = 0
End Select
End Sub

Public Sub SetStatusView(s$)
    sts.Panels("view").Text = s
End Sub


Private Sub TV1_NodeClick(ByVal Node As MSComctlLib.Node)
Dim s$
    s = Scene.GetTreeNodeValue(Node)
    sts.Panels(1) = s
    Debug.Print "s=" & s
End Sub