VB6 QuasiVisual3D.frm

edit

Refactoring Dex3D ⋅  Category:QuasiVisual3D ⋅  QuasiVisual3D.frm ⋅  Dex3D.frm ⋅  Dex3D Engine ⋅ 

'''   QuasiVisual3D.frm   --  modQV3D

Private mboLoading As Boolean

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then  ''' ESC = quick exit
        mnuExit_Click
    End If
End Sub

Private Sub Form_Load()
    Debug.Print "Form_Load"
    
    Dim Extension As String
    
    On Error Resume Next
    mboLoading = True       ''  Anti-recurssion flag (tested in change events)
    Me.KeyPreview = True    ''  Added -XenoEngineer, for forever-loop cancellation ''
    
    CommonDialog1.CancelError = True
    
    InitializeScene
    
    InitializeCanvas Picture1, borderStyle:=vbTransparent, backcolor:=vbBlack
    InitializeCanvas Picture2, borderStyle:=vbTransparent, backcolor:=vbBlack
    InitializeCanvas Picture3, borderStyle:=vbTransparent, backcolor:=vbBlack
        
    mboLoading = False
    
    'TickCount = 10 '' Obsolete with event-driven scheme for drawing
    
    MyCamera = AddCamera
    VCamera(MyCamera).Zoom = 1
    VCamera(MyCamera).DrawStyle = 2
    mnuDrawStyleOption(2).Checked = True
    
    MyLight = AddLight
    mnuLight.Checked = True
    
    OrbitRadius = 200
    OrbitSpeed = 0.01
    DollySpeed = 1
    
    ''  Load dex or 3ds files if on the command line  ''
    If Command <> "" Then
        Extension = LCase(Right(Command, 3))
        If Extension = "dex" Then MyMesh = LoadDexMesh(Command)
        If Extension = "3ds" Then
            MyMesh = 0
            Load3dsFile Command
            SetSceneColor ColorLongToRGB(vbWhite), 0.5
        End If
        
        Call CenterMesh(MyMesh)
        RefreshScene
    End If
    
    BeginRenderLoop = True
    
End Sub

Private Sub Form_Resize()
    Debug.Print "Form_Resize()"
    
    If mboLoading Then Exit Sub
    
    Dim PaletteWidth As Integer
    
    PaletteWidth = Me.ScaleHeight / 20
    
    Picture1.Move 0, 0, Me.ScaleWidth - PaletteWidth, Me.ScaleHeight - PaletteWidth
    Picture2.Move Me.ScaleWidth - PaletteWidth, 0, PaletteWidth, Me.ScaleHeight - PaletteWidth
    Picture3.Move 0, Me.ScaleHeight - PaletteWidth, Me.ScaleWidth, PaletteWidth
    
    RefreshScene
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Debug.Print "Form_Unload()    "
End Sub

Private Sub mnuAbout_Click()

    Call ShowAbout
    
End Sub

Private Sub mnuBasicOption_Click(Index As Integer)

    Randomize
    
    Call ResetScene(0, MyCamera, MyLight)
    Select Case Index
        Case 0
            MyMesh = AddMeshBox(VectorInput(40, 40, 40))
        Case 1
            MyMesh = AddMeshGrid(80, 80, 4, 4, False)
        Case 2
            MyMesh = AddMeshSphere(40, 16, 8)
        Case 3
            MyMesh = AddMeshHemisphere(40, 16, 4)
        Case 4
            MyMesh = AddMeshCone(40, 60, 16)
        Case 5
            MyMesh = AddMeshCylinder(40, 60, 16)
        Case 6
            MyMesh = AddMeshPie(80, 20, 0, 60, 32)
        Case 7
            MyMesh = AddMeshTetrahedron(40)
        Case 8
            MyMesh = AddMeshSphere(40, 4, 2)
        Case 9
            MyMesh = AddMeshGeoSphere(40, 2)
        Case 10
            MyMesh = AddMeshTorus(10, 68.541, 13, 8)
    End Select
    Call CenterMesh(MyMesh)
    Call SetMeshColor(MyMesh, ColorRandom, 0.5)
    RefreshScene
    
End Sub
Private Sub mnuColorOption_Click(Index As Integer)

    Select Case Index
        Case 0
            Call SetMeshColor(MyMesh, ColorLongToRGB(vbWhite), 0.5)
        Case 1
            Call SetMeshColorRandom(MyMesh)
        Case 2
            Call _
                SetMeshColorGradient( _
                    MyMesh, _
                    2, _
                    ColorLongToRGB(vbBlue), _
                    ColorLongToRGB(vbRed), _
                    0.5 _
                )
    End Select
    RefreshScene
    
End Sub
Private Sub mnuComboOption_Click(Index As Integer)

    Dim A As Integer
    Dim B As Integer
    Dim C As Integer
    Dim D() As Single
    Dim E() As Long
    
    Randomize
    
    Call ResetScene(0, MyCamera, MyLight)
    Select Case Index
        Case 0
            ReDim D(1 To 18)
            ReDim E(1 To 18)
            C = 1
            For A = 1 To 3
                For B = 1 To 6
                    D(C) = Rnd
                    E(C) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
                    C = C + 1
                Next B
            Next A
            MyMesh = AddMeshBarGraph(6, 3, VectorInput(80, 40, 40), 5, D(), E())
        Case 1
            ReDim D(1 To 25)
            ReDim E(1 To 25)
            C = 1
            For A = 1 To 5
                For B = 1 To 5
                    D(C) = Rnd
                    E(C) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
                    C = C + 1
                Next B
            Next A
            MyMesh = AddMeshGridGraph(5, 5, VectorInput(80, 40, 80), D(), vbBlue, vbRed, False)
        Case 2
            ReDim D(1 To 4)
            ReDim E(1 To 4)
            For A = 1 To 4
                D(A) = Rnd
                E(A) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
            Next A
            MyMesh = AddMeshPieGraph(40, 10, 16, D(), E())
    End Select
    RefreshScene
    
End Sub
Private Sub mnuDrawModeOption_Click(Index As Integer)

    mnuDrawModeOption(Index).Checked = Not mnuDrawModeOption(Index).Checked
    Select Case Index
        Case 0
            VCamera(MyCamera).DoubleSided = mnuDrawModeOption(Index).Checked
        Case 1
            VCamera(MyCamera).Metallic = mnuDrawModeOption(Index).Checked
        Case 2
            VCamera(MyCamera).Atmosphere = mnuDrawModeOption(Index).Checked
        Case 3
            VCamera(MyCamera).ColorCorrect = mnuDrawModeOption(Index).Checked
    End Select
    RefreshScene
    
End Sub
Private Sub mnuDrawStyleOption_Click(Index As Integer)

    mnuDrawStyleOption(VCamera(MyCamera).DrawStyle).Checked = False
    mnuDrawStyleOption(Index).Checked = True
    VCamera(MyCamera).DrawStyle = Index
    RefreshScene
    
End Sub
Private Sub mnuExit_Click()
    Debug.Print "mnuExit_Click"
    
    Unload Me
    
End Sub

Private Sub mnuHomepage_Click()

    Explore "https://groupkos.com/dev/index.php/Dex3D_Graphics"
    
End Sub
Private Sub mnuLight_Click()

    mnuLight.Checked = Not mnuLight.Checked
    VLight(MyLight).Enabled = mnuLight.Checked
    RefreshScene
    
End Sub
Private Sub mnuLoad_Click()

    Dim Extension As String
    
    On Error Resume Next
    
    CommonDialog1.Filter = _
        "Dex3D Files (*.dex)|*.dex|3D Studio Files (*.3ds)|*.3ds|All Files (*.*)|*.*"
        
    CommonDialog1.ShowOpen
    
    If Err = 0 Then
        Call ResetScene(0, MyCamera, MyLight)
        Extension = LCase(Right(CommonDialog1.Filename, 3))
        If Extension = "dex" Then MyMesh = LoadDexMesh(CommonDialog1.Filename)
        If Extension = "3ds" Then
            MyMesh = 1
            Call Load3dsFile(CommonDialog1.Filename)
            Call SetSceneColor(ColorLongToRGB(vbWhite), 0.5)
        End If
        RefreshScene
    End If
    
End Sub
Private Sub mnuNew_Click()

    Call ResetScene(0, MyCamera, MyLight)
    RefreshScene
    
End Sub

Private Sub mnuOrthographic_Click()

    mnuOrthographic.Checked = Not mnuOrthographic.Checked
    VCamera(MyCamera).Orthographic = mnuOrthographic.Checked
    RefreshScene
    
End Sub
Private Sub mnuOtherOption_Click()

    Call ResetScene(0, MyCamera, MyLight)
    MyMesh = AddMeshGrid(80, 80, 10, 10, False)
    Call CenterMesh(MyMesh)
    Call RippleMesh(MyMesh, 40, 20, 0)
    Call SetMeshColorGradient(MyMesh, 2, ColorLongToRGB(vbBlue), ColorLongToRGB(vbRed), 0.5)
    RefreshScene
    
End Sub
Private Sub mnuRename_Click()

    VMesh(MyMesh).Tag = InputBox("Enter new name:", "Rename", VMesh(MyMesh).Tag)
    RefreshScene
    
End Sub
Private Sub mnuSave_Click()

    On Error Resume Next
    
    CommonDialog1.Filter = "Dex3D Files (*.dex)|*.dex|All Files (*.*)|*.*"
    CommonDialog1.ShowSave
    If Err = 0 Then Call SaveDexMesh(MyMesh, CommonDialog1.Filename)
    
End Sub
Private Sub mnuSpecialOption_Click(Index As Integer)

    Dim A As Integer
    
    Randomize
    
    Call ResetScene(0, MyCamera, MyLight)
    Select Case Index
        Case 0
            For A = 1 To 40
                MyMesh = AddMeshPoint(VectorScale(VectorRandom, 40))
                Call SetMeshColorRandom(MyMesh)
            Next A
        Case 1
            For A = 1 To 10
                MyMesh = _
                    AddMeshLine( _
                        VectorScale(VectorRandom, 40), _
                        VectorScale(VectorRandom, 40) _
                    )
                Call SetMeshColorRandom(MyMesh)
            Next A
        Case 2
            For A = 1 To 20
                MyMesh = AddMeshText("3D", VectorScale(VectorRandom, 40))
                Call SetMeshColorRandom(MyMesh)
            Next A
        Case 3
            For A = 1 To 10
                MyMesh = _
                    AddMeshCurve( _
                        VectorScale(VectorRandom, 40), _
                        VectorScale(VectorRandom, 40), _
                        VectorScale(VectorRandom, 40), _
                        VectorScale(VectorRandom, 40) _
                    )
                Call SetMeshColorRandom(MyMesh)
            Next A
    End Select
    RefreshScene
    
End Sub
Private Sub mnuTessellationOption_Click(Index As Integer)

    Select Case Index
        Case 0
            Call TessellateMeshByFace(MyMesh, 1)
        Case 1
            Call TessellateMeshByEdge(MyMesh, 1)
    End Select
    Call SetMeshColor(MyMesh, ColorLongToRGB(vbWhite), 0.5)
    RefreshScene
    
End Sub

Private Sub RefreshScene()
    
    If LockCamera = True Then
        VLight(MyLight).Origin = _
            VectorAdd( _
                VectorNull, _
                VectorScale( _
                    OrientationToVector(OrientationInput(0, OrbitLatitude, -OrbitLongitude)), _
                    -OrbitRadius _
                ) _
            )
        If CameraModel <> 0 Then
            VMesh(CameraModel).Origin = VLight(MyLight).Origin
            VMesh(CameraModel).Angles.Pitch = OrbitLatitude
            VMesh(CameraModel).Angles.Yaw = -OrbitLongitude
            VMesh(CameraModel).UpdateTransformation = True
        End If
    
    Else
        
        Call OrbitCamera(MyCamera, VectorNull, OrbitRadius, OrbitLongitude, OrbitLatitude)
        VLight(MyLight).Origin = VCamera(MyCamera).Origin
    
    End If
    
    ''  Render the new bitmap
    paintCanvas Picture1
    
End Sub

Sub paintCanvas(C As PictureBox)
    C.Cls
    RenderImage C, MyCamera
    
    LastFaceOver = 0  ''  The active mesh face(triangle) under the mouse pointer.
    
    ''  Print UI properties to the canvas  ''
    C.ForeColor = vbWhite
    C.Print "Longitude: " & Int(RadianToDegree(OrbitLongitude))
    C.Print "Latitude: " & Int(RadianToDegree(OrbitLatitude))
    C.Print "Radius: " & Int(OrbitRadius)
    C.Print
    C.Print "Name: " & VMesh(MyMesh).Tag
    C.Print "Vertices: " & VMesh(MyMesh).Vertices.Length
    C.Print "Faces: " & VMesh(MyMesh).Faces.Length
    
End Sub


Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)

    If KeyCode = CShift Then
        LockCamera = True
        If CameraModel = 0 Then
            CameraModel = AddMeshCone(10, 20, 4)
            Call CenterMesh(CameraModel)
            Call TransformMesh(CameraModel, TransformationTranslate(VectorInput(0, 20, 0)))
            Call TransformMesh(CameraModel, TransformationRotate(1, -Pi / 2))
            Call TransformMesh(CameraModel, TransformationRotate(3, Pi / 4))
            Call SetMeshColor(CameraModel, ColorLongToRGB(vbRed), 0.5)
            Me.mnuFile.Enabled = False
            Me.mnuEdit.Enabled = False
            Me.mnuView.Enabled = False
            Me.mnuObject.Enabled = False
            Me.mnuHelp.Enabled = False
        End If
    End If
    
End Sub
Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer)

    If KeyCode = CShift Then
        LockCamera = False
        If CameraModel <> 0 Then
            Call RemoveMesh(CameraModel)
            CameraModel = 0
            Me.mnuFile.Enabled = True
            Me.mnuEdit.Enabled = True
            Me.mnuView.Enabled = True
            Me.mnuObject.Enabled = True
            Me.mnuHelp.Enabled = True
        End If
        RefreshScene
    End If
    
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If FaceOver <> 0 Then
        If CameraModel = 0 Then
            Select Case Button
                Case 1
                    VFace(FaceOver).Color = ColorLongToRGB(BrushColor)
                    VFace(FaceOver).Alpha = BrushAlpha
                    RefreshScene
                Case 2
                    BrushColor = ColorRGBToLong(VFace(FaceOver).Color)
                    BrushAlpha = VFace(FaceOver).Alpha
                    Picture3_Resize
            End Select
        End If
    End If
    
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button <> 0 Then
        Select Case Button
            Case 1 'orbit
                Picture1.MousePointer = 15
                OrbitLongitude = OrbitLongitude - (X - LastMousePosition.X) * OrbitSpeed
                OrbitLatitude = OrbitLatitude + (Y - LastMousePosition.Y) * OrbitSpeed
                If OrbitLongitude > Pi Then OrbitLongitude = OrbitLongitude - (2 * Pi)
                If OrbitLongitude < -Pi Then OrbitLongitude = OrbitLongitude + (2 * Pi)
                If OrbitLatitude > (Pi / 2) Then OrbitLatitude = (Pi / 2)
                If OrbitLatitude < -(Pi / 2) Then OrbitLatitude = -(Pi / 2)
            Case 2 'dolly
                Picture1.MousePointer = 7
                OrbitRadius = OrbitRadius + (Y - LastMousePosition.Y) * DollySpeed
                If OrbitRadius < 0 Then OrbitRadius = 0
        End Select
        RefreshScene
    Else
        If CameraModel = 0 Then
            FaceOver = FaceByPoint(POINTAPIInput(Int(X), Int(Y)))
            If FaceOver <> 0 Then
                Picture1.MousePointer = 2
            Else
                Picture1.MousePointer = 0
            End If
            If FaceOver <> LastFaceOver Then
                Picture1.DrawMode = 6
                Picture1.DrawStyle = 0
                Picture1.FillStyle = 1
                If LastFaceOver <> 0 Then Call DrawFace(Picture1, LastFaceOver, ColorNull)
                LastFaceOver = FaceOver
                Call DrawFace(Picture1, FaceOver, ColorNull)
                Picture1.Refresh
            End If
        Else
            Picture1.MousePointer = 0
        End If
    End If
    LastMousePosition.X = X
    LastMousePosition.Y = Y
    
End Sub
Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Call Picture2_MouseMove(Button, Shift, X, Y)
    
End Sub

Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Picture2.MousePointer = 2
    
    If Button <> 0 Then
        PaletteColor = GetPixel(Picture2.hdc, X, Y)
        If PaletteColor <> -1 Then BrushColor = PaletteColor
        Call Picture3_Resize
    End If
    
End Sub

Private Sub Picture2_Resize()
    If mboLoading Then Exit Sub
    
    Picture2.Cls
    DrawColorSpectrum Picture2, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, 2
    
End Sub

Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Call Picture3_MouseMove(Button, Shift, X, Y)
    
End Sub

Private Sub Picture3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Picture3.MousePointer = 9
    
    If Button <> 0 Then
        BrushAlpha = Abs(X - Picture3.ScaleWidth / 2) / (Picture3.ScaleWidth / 2)
        If BrushAlpha > 1 Then BrushAlpha = 1
        Picture3_Resize
    End If
    
End Sub

Private Sub Picture3_Resize()
    If mboLoading = True Then Exit Sub
    
    Picture3.Cls
    DrawColorShades Picture3, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, 1, BrushColor
    DrawArrow _
            Picture3, _
            Picture3.ScaleWidth / 2 + BrushAlpha * Picture3.ScaleWidth / 2, _
            0, _
            1, _
            Picture3.Height, _
            vbWhite, _
             5
        
        DrawArrow _
            Picture3, _
            Picture3.ScaleWidth / 2 - BrushAlpha * Picture3.ScaleWidth / 2, _
            0, _
            1, _
            Picture3.Height, _
            vbWhite, _
            5
        
End Sub