VB下的3D如何做:

大家加入吧!留下名字,软件开发者一栏就有大家!
这个控件
[code=源代码]
VERSION 5.00
Begin VB.UserControl DEX3D 
   BackColor       =   &H00000000&
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.PictureBox Picture3 
      Height          =   495
      Left            =   2880
      ScaleHeight     =   435
      ScaleWidth      =   1155
      TabIndex        =   2
      Top             =   120
      Width           =   1215
   End
   Begin VB.PictureBox Picture2 
      Height          =   495
      Left            =   1440
      ScaleHeight     =   435
      ScaleWidth      =   1155
      TabIndex        =   1
      Top             =   120
      Width           =   1215
   End
   Begin VB.PictureBox Picture1 
      Height          =   495
      Left            =   120
      ScaleHeight     =   435
      ScaleWidth      =   1155
      TabIndex        =   0
      Top             =   120
      Width           =   1215
   End
   Begin VB.Menu mnuFile 
      Caption         =   "File"
      Begin VB.Menu mnuNew 
         Caption         =   "New"
      End
      Begin VB.Menu mnuBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuLoad 
         Caption         =   "Load"
      End
      Begin VB.Menu mnuSave 
         Caption         =   "Save"
      End
      Begin VB.Menu mnuBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "Edit"
      Begin VB.Menu mnuRename 
         Caption         =   "Rename"
      End
      Begin VB.Menu mnuBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuColorOption 
         Caption         =   "Color White"
         Index           =   0
      End
      Begin VB.Menu mnuColorOption 
         Caption         =   "Color Random"
         Index           =   1
      End
      Begin VB.Menu mnuColorOption 
         Caption         =   "Color Gradient"
         Index           =   2
      End
      Begin VB.Menu mnuBar4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTessellationOption 
         Caption         =   "Tessellate By Face"
         Index           =   0
      End
      Begin VB.Menu mnuTessellationOption 
         Caption         =   "Tessellate By Edge"
         Index           =   1
      End
   End
   Begin VB.Menu mnuView 
      Caption         =   "View"
      Begin VB.Menu mnuLight 
         Caption         =   "Light"
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuOrthographic 
         Caption         =   "Orthographic"
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuBar5 
         Caption         =   "-"
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Wireframe"
         Index           =   0
         Shortcut        =   {F1}
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Solid"
         Index           =   1
         Shortcut        =   {F2}
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Shaded"
         Index           =   2
         Shortcut        =   {F3}
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Transparent"
         Index           =   3
         Shortcut        =   {F4}
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Outlined"
         Index           =   4
         Shortcut        =   {F5}
      End
      Begin VB.Menu mnuDrawStyleOption 
         Caption         =   "Gradient"
         Index           =   5
         Shortcut        =   {F6}
      End
      Begin VB.Menu mnuBar6 
         Caption         =   "-"
      End
      Begin VB.Menu mnuDrawModeOption 
         Caption         =   "Double-Sided"
         Index           =   0
         Shortcut        =   ^D
      End
      Begin VB.Menu mnuDrawModeOption 
         Caption         =   "Metallic"
         Index           =   1
         Shortcut        =   ^M
      End
      Begin VB.Menu mnuDrawModeOption 
         Caption         =   "Atmosphere"
         Index           =   2
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuDrawModeOption 
         Caption         =   "Color-Correct"
         Index           =   3
         Shortcut        =   ^C
      End
   End
   Begin VB.Menu mnuObject 
      Caption         =   "Object"
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Box"
         Index           =   0
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Grid"
         Index           =   1
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Sphere"
         Index           =   2
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Hemisphere"
         Index           =   3
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Cone"
         Index           =   4
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Cylinder"
         Index           =   5
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Pie"
         Index           =   6
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Tetrahedron"
         Index           =   7
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Octahedron"
         Index           =   8
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Geo-Sphere"
         Index           =   9
      End
      Begin VB.Menu mnuBasicOption 
         Caption         =   "Torus"
         Index           =   10
      End
      Begin VB.Menu mnuBar7 
         Caption         =   "-"
      End
      Begin VB.Menu mnuSpecialOption 
         Caption         =   "Pixel"
         Index           =   0
      End
      Begin VB.Menu mnuSpecialOption 
         Caption         =   "Line"
         Index           =   1
      End
      Begin VB.Menu mnuSpecialOption 
         Caption         =   "Text"
         Index           =   2
      End
      Begin VB.Menu mnuSpecialOption 
         Caption         =   "Curve"
         Index           =   3
      End
      Begin VB.Menu mnuBar8 
         Caption         =   "-"
      End
      Begin VB.Menu mnuComboOption 
         Caption         =   "Bar Graph"
         Index           =   0
      End
      Begin VB.Menu mnuComboOption 
         Caption         =   "Grid Graph"
         Index           =   1
      End
      Begin VB.Menu mnuComboOption 
         Caption         =   "Pie Graph"
         Index           =   2
      End
      Begin VB.Menu mnuBar9 
         Caption         =   "-"
      End
      Begin VB.Menu mnuOtherOption 
         Caption         =   "Ripple"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "Help"
      Begin VB.Menu mnuAbout 
         Caption         =   "About"
      End
   End
End
[/code]
把内容保存为ctl.ctl.
如何动态载入控件?

解决方案 »

  1.   


    Attribute VB_Name = "DEx3D"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = True
    Attribute VB_PredeclaredId = False
    Attribute VB_Exposed = True
    Public Enum Color
        White = 0
        Random = 1
        Gradient = 2
    End Enum
    Public Enum Obj3D
        Box = 0
        Grid = 1
        CircleSphare = 2
        Hemisphere = 3
        Cone = 4
        Cylinder = 5
        Pie = 6
        Tetrahedron = 7
        Sphere = 8
        GeoSphere = 9
        Torus = 10
    End Enum
    Public Enum Combo
        Bar = 0
        Grid = 1
        OPie = 2
    End Enum
    Public Enum DrawStyle
        Wireframe = 0
        Solid = 1
        Shaded = 2
        Transparent = 3
        Outlined = 4
        Super = 5
    End Enum
    Public Enum DrawMode
        DoubleSided = 0
        Metallic = 1
        Atmosphere = 2
        ColorCorrect = 3
    End Enum
    Public Enum Tessellation
        Face = 0
        Edge = 1
    End Enum
    Public Enum Special
    Pixel = 0
    Line = 1
    Text = 2
    Curve = 3
    End Enum
    Dim Info As String
    Public MH, MW
    Dim exits
    Public Sub Activate()    Dim FrameRate As Single
        
        If BeginRenderLoop = True Then
            BeginRenderLoop = False
            Do
                If RefreshScene = True Then
                    RefreshScene = False
                    If TickCount < 10 Then
                        TickCount = TickCount + 1
                    Else
                        FinishTime = Timer
                        If FinishTime <> BeginTime Then
                            FrameRate = TickCount / (FinishTime - BeginTime)
                            'UserControl1.Caption = App.Title & " - " & Format(FrameRate, "0.00") & " fps"
                            TickCount = 0
                            BeginTime = Timer
                        End If
                    End If
                    LastFaceOver = 0
                    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
                    Picture1.Cls
                    Call RenderImage(Picture1, MyCamera)
                    Picture1.ForeColor = vbWhite
                    Picture1.Print "Longitude: " & Int(RadianToDegree(OrbitLongitude))
                    Picture1.Print "Latitude: " & Int(RadianToDegree(OrbitLatitude))
                    Picture1.Print "Radius: " & Int(OrbitRadius)
                    Picture1.Print
                    Picture1.Print "Name: " & VMesh(MyMesh).Tag
                    Picture1.Print "Vertices: " & VMesh(MyMesh).Vertices.Length
                    Picture1.Print "Faces: " & VMesh(MyMesh).Faces.Length
                    Info = "Longitude: " & Int(RadianToDegree(OrbitLongitude)) & vbCrLf & _
    "Latitude: " & Int(RadianToDegree(OrbitLatitude)) & vbCrLf & _
    "Radius: " & Int(OrbitRadius) & vbCrLf & vbCrLf & _
    "Name: " & VMesh(MyMesh).Tag & vbCrLf & _
    "Vertices: " & VMesh(MyMesh).Vertices.Length & vbCrLf & _
    "Faces: " & VMesh(MyMesh).Faces.Length
                End If
                If exits = True Then Exit Do Else DoEvents
            Loop
        End If
        
    End Sub
    Public Sub Load()
    exits = False
        Dim Extension As String
        
       ' CommonDialog1.CancelError = True
        
        Call InitializeScene(Picture1)
        Call InitializeCanvas(Picture2)
        Call InitializeCanvas(Picture3)
        Picture1.BorderStyle = 0
        Picture2.BorderStyle = 0
        Picture3.BorderStyle = 0
        Picture1.BackColor = vbBlack
        Picture2.BackColor = vbBlack
        Picture3.BackColor = vbBlack
        
        TickCount = 10
        
        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
        
        If Command <> "" Then
            Extension = LCase(Right(Command, 3))
            If Extension = "dex" Then MyMesh = LoadDexMesh(Command)
            If Extension = "3ds" Then
                MyMesh = 0
                Call Load3dsFile(Command)
                Call SetSceneColor(ColorLongToRGB(vbWhite), 0.5)
            End If
            Call CenterMesh(MyMesh)
            RefreshScene = True
        End If
        
        BeginRenderLoop = True
        
    End SubPublic Sub Resize()    Dim PaletteWidth As Integer
        
        PaletteWidth = MH / 20
        
        Picture1.Move 0, 0, MW - PaletteWidth, MH - PaletteWidth
        Picture2.Move MW - PaletteWidth, 0, PaletteWidth, MH - PaletteWidth
        Picture3.Move 0, MH - PaletteWidth, MW, PaletteWidth
        
        RefreshScene = True
        
    End Sub
      

  2.   


    '===================================================================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)
                UserControl1.mnuFile.Enabled = False
                UserControl1.mnuEdit.Enabled = False
                UserControl1.mnuView.Enabled = False
                UserControl1.mnuObject.Enabled = False
                UserControl1.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
                UserControl1.mnuFile.Enabled = True
                UserControl1.mnuEdit.Enabled = True
                UserControl1.mnuView.Enabled = True
                UserControl1.mnuObject.Enabled = True
                UserControl1.mnuHelp.Enabled = True
            End If
            RefreshScene = True
        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 = True
                    Case 2
                        BrushColor = ColorRGBToLong(VFace(FaceOver).Color)
                        BrushAlpha = VFace(FaceOver).Alpha
                        Call 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 = True
        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()    Picture2.Cls
        Call 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
            Call Picture3_Resize
        End If
        
    End Sub
    Private Sub Picture3_Resize()    Picture3.Cls
        Call DrawColorShades(Picture3, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, 1, BrushColor)
        Call _
            DrawArrow( _
                Picture3, _
                Picture3.ScaleWidth / 2 + BrushAlpha * Picture3.ScaleWidth / 2, _
                0, _
                1, _
                Picture3.Height, _
                vbWhite, _
                5 _
            )
        Call _
            DrawArrow( _
                Picture3, _
                Picture3.ScaleWidth / 2 - BrushAlpha * Picture3.ScaleWidth / 2, _
                0, _
                1, _
                Picture3.Height, _
                vbWhite, _
                5 _
            )
            
    End Sub
      

  3.   


    Public Function LoadDEX3D(Filename As String) As Boolean
        Dim Extension As String
        On Error GoTo ErrorErr
            Call ResetScene(0, MyCamera, MyLight)
            Extension = LCase(Right(Filename, 3))
            If Extension = "dex" Then MyMesh = LoadDexMesh(Filename)
            If Extension = "3ds" Then
                MyMesh = 1
                Call Load3dsFile(Filename)
                Call SetSceneColor(ColorLongToRGB(vbWhite), 0.5)
            End If
            RefreshScene = True
            LoadDEX3D = True
            Exit Function
    ErrorErr:
            LoadDEX3D = False
    End Function
    Public Function SaveDEX3D(Filename As String) As Boolean
        On Error GoTo ErrorErr
        Call SaveDexMesh(MyMesh, Filename)
        SaveDEX3D = True
        Exit Function
    ErrorErr:
        SaveDEX3D = False
    End Function
    Public Sub Rename(Tag)
    On Error GoTo exx
        VMesh(MyMesh).Tag = Tag
        RefreshScene = True
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End SubPublic Sub New3D()
    On Error GoTo exx
        Call ResetScene(0, MyCamera, MyLight)
        RefreshScene = True
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End SubPublic Sub About()
    On Error GoTo exx
        Call ShowAbout
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End Sub
    Public Sub ColorOption(Optional ColorMode As Color = Gradient)
        On Error GoTo exx
        Select Case ColorMode
            Case 0
                Call SetMeshColor(MyMesh, ColorLongToRGB(vbWhite), 0.5)
            Case 1
                Call SetMeshColorRandom(MyMesh)
            Case 2
                Call SetMeshColorGradient(MyMesh, 2, ColorLongToRGB(vbRed), ColorLongToRGB(vbBlue), 0.5)
        End Select
        RefreshScene = True
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End SubPublic Sub ObjectOption(Optional Obj As Obj3D = Box, Optional length1 As Single = 40, Optional length2 As Single = 40, Optional length3 As Single = 40, Optional length4 As Single = 4)
        On Error GoTo exx
        Randomize
        Call ResetScene(0, MyCamera, MyLight)
        Select Case Obj
            Case 0
                MyMesh = AddMeshBox(VectorInput(length1, length2, length3))
            Case 1
                MyMesh = AddMeshGrid(length1, length2, Int(length3), Int(length4), False)
            Case 2
                MyMesh = AddMeshSphere(length1, Int(length2), Int(length3))
            Case 3
                MyMesh = AddMeshHemisphere(length1, Int(length2), Int(length3))
            Case 4
                MyMesh = AddMeshCone(length1, length2, Int(length3))
            Case 5
                MyMesh = AddMeshCylinder(length1, length2, Int(length3))
            Case 6
                MyMesh = AddMeshPie(length1, length2, 0, length3, Int(length4))
            Case 7
                MyMesh = AddMeshTetrahedron(length1)
            Case 8
                MyMesh = AddMeshSphere(length1, Int(length2), Int(length3))
            Case 9
                MyMesh = AddMeshGeoSphere(length1, Int(length2))
            Case 10
                MyMesh = AddMeshTorus(length1, length2, Int(length3), Int(length4))
        End Select
        Call CenterMesh(MyMesh)
        Call SetMeshColor(MyMesh, ColorRandom, 0.5)
        RefreshScene = True
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End Sub
    Public Sub ComboOption(Optional MyCombo As Combo = OPie, Optional Length As Single = 40)
    On Error GoTo exx
        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 MyCombo
            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(Length * 2, Length, Length), 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(Length * 2, Length, Length * 2), 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(Length, 10, 16, D(), E())
        End Select
        RefreshScene = True
    Exit Sub
    exx: MsgBox "Error" & Err.Number & ":" & Err.Description
    End Sub