哪位仁兄有用VB编的三维图形显示的程序

Question

哪位仁兄有用VB编的三维图形显示的程序
是图形显示，必要时可以进行旋转、放大、缩小等操作。

Answer 1

没有人知道吗，快来人啦，HELP ME！！！

Answer 2

使用stretchblt 进行缩放，使用PatBlt进行旋转并缩放

Answer 3

http://www.yesky.com/20020627/1618051.shtml

Answer 4

一个三维图象在方向键按下时转动的程序。Option Explicit
Const pi As Single = 3.141592Const NUM_CUBE_VERTICES As Integer = 4 * 6
Dim g_vCube(NUM_CUBE_VERTICES) As D3DVERTEX'定义三个材质表面
Dim TextureSurface1 As DirectDrawSurface7
Dim TextureSurface2 As DirectDrawSurface7
Dim TextureSurface3 As DirectDrawSurface7Dim g_dx As New DirectX7
Dim g_dd As DirectDraw7
Dim g_ddsd As DDSURFACEDESC2
Dim MainBuffer As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim Direct3DDevice As Direct3DDevice7
Dim g_rcDest As RECT, g_rcSrc As RECT
Dim ViewPortRect(0) As D3DRECT
Dim bIsRunning As Boolean
Dim bRoAn As Boolean
Dim CNT As Single
Dim iViewSize As IntegerPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    '根据不同的击键值来决定角度的变化
    Select Case KeyCode
        Case vbKeyUp
            CNT = CNT + 6
            bRoAn = True
        Case vbKeyDown
            CNT = CNT - 6
            bRoAn = True
        Case vbKeyLeft
            CNT = CNT + 6
            bRoAn = False
        Case vbKeyRight
            CNT = CNT - 6
            bRoAn = False
        Case vbKeySubtract
            If iViewSize < 12 Then
                iViewSize = iViewSize + 1
            End If
        Case vbKeyAdd
            If iViewSize > 4 Then
                iViewSize = iViewSize - 1
            End If
    End Select
End SubPrivate Sub Form_Load()
    Dim j As Long    InitDDraw
    InitD3D
    InitDeviceObjects
    
    Me.Show
    
    bIsRunning = True
    Do While bIsRunning = True
        RenderScene
        FrameMove (CNT / 360), bRoAn
        
        g_dx.GetWindowRect Me.hWnd, g_rcDest
    
        '将后台绘图平面的内容复制到前台
        j = MainBuffer.Blt(g_rcDest, BackBuffer, g_rcSrc, DDBLT_WAIT)
        If j <> DD_OK Then
            MsgBox "无法将后台绘图平面的内容拷贝到前台，错误代码：" & Hex(j)
            End
        End If
        DoEvents
    Loop
End SubPrivate Sub FrameMove(stepVal As Single, bType As Boolean)
    Dim matView As D3DMATRIX
    Dim matTemp As D3DMATRIX
    
    '建立线形矩阵
    g_dx.IdentityMatrix matView
    
'    matView.rc11 = Cos(0.5)
'    matView.rc12 = Sin(0.5)
'    matView.rc21 = Sin(-0.5)
'    matView.rc22 = Cos(0.5)
'    matView.rc33 = 1
'    matView.rc43 = iviewsize
    '你可以尝试将下面5句注释掉而使用上面5句进行视矩阵变换，看有什么效果
    matView.rc11 = 1
    matView.rc22 = Cos(-0.5)
    matView.rc23 = Sin(-0.5)
    matView.rc32 = -Sin(-0.5)
    matView.rc33 = Cos(-0.5)
    matView.rc43 = iViewSize
    
    '对视矩阵进行角度变换
    Direct3DDevice.SetTransform D3DTRANSFORMSTATE_VIEW, matView
    
    Dim matWorld As D3DMATRIX
    
    g_dx.IdentityMatrix matWorld
    If bType Then
        g_dx.RotateXMatrix matWorld, stepVal
    Else
        g_dx.RotateYMatrix matWorld, stepVal
    End If
    Direct3DDevice.SetTransform D3DTRANSFORMSTATE_WORLD, matWorld
End Sub'RenderScene函数执行场景重绘和渲染
Private Sub RenderScene()
    Dim i As Integer
          
    '将整个视界背景设置为蓝色，并清除Z缓冲
    Direct3DDevice.Clear 1, ViewPortRect(), D3DCLEAR_TARGET, &HFF, 1, 0
    
    '开始绘制场景
    Direct3DDevice.BeginScene
    
    '将TextureSurface1设置为Direct3DDevice的纹理平面
    Direct3DDevice.SetTexture 0, TextureSurface1
    '使用TextureSurface1作为纹理绘制g_vCube(0)到g_vCube(3)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(0), _
         4, D3DDP_DEFAULT)
    '使用TextureSurface1作为纹理绘制g_vCube(4)到g_vCube(7)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(4), _
         4, D3DDP_DEFAULT)
         
    '将TextureSurface2设置为Direct3DDevice的纹理平面
    Direct3DDevice.SetTexture 0, TextureSurface2
    '使用TextureSurface2作为纹理绘制g_vCube(8)到g_vCube(11)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(8), _
         4, D3DDP_DEFAULT)
    '使用TextureSurface2作为纹理绘制g_vCube(12)到g_vCube(15)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(12), _
         4, D3DDP_DEFAULT)
   
    '将TextureSurface3设置为Direct3DDevice的纹理平面
    Direct3DDevice.SetTexture 0, TextureSurface3
    '使用TextureSurface3作为纹理绘制g_vCube(16)到g_vCube(19)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(16), _
         4, D3DDP_DEFAULT)
    '使用TextureSurface3作为纹理绘制g_vCube(20)到g_vCube(23)顶点之间的平面，
    Call Direct3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_VERTEX, g_vCube(20), _
         4, D3DDP_DEFAULT)
   
    '结束绘制场景
    Direct3DDevice.EndScene
End SubPrivate Sub Form_Unload(Cancel As Integer)
    bIsRunning = False
End Sub'InitDDraw函数初始化DirectDraw对象，包括建立主绘图平面以及后台绘图平面
Private Sub InitDDraw()
    '建立DirectDraw对象
    Set g_dd = g_dx.DirectDrawCreate("")
    '设定DirectDraw对象的协作模式
    g_dd.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
    
    '预先定义主绘图平面的属性
    g_ddsd.lFlags = DDSD_CAPS
    g_ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
    
    '建立主绘图平面
    Set MainBuffer = g_dd.CreateSurface(g_ddsd)
    
    g_ddsd.lFlags = DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_CAPS
    g_ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_3DDEVICE
    g_dx.GetWindowRect Me.hWnd, g_rcDest
    g_ddsd.lWidth = g_rcDest.Right - g_rcDest.Left
    g_ddsd.lHeight = g_rcDest.Bottom - g_rcDest.Top
    
    '建立后台绘图平面
    Set BackBuffer = g_dd.CreateSurface(g_ddsd)
        
    

Answer 5

'将后台绘图平面的尺寸保存到g_rcSrc中
    With g_rcSrc
        .Left = 0: .Top = 0
        .Bottom = g_ddsd.lHeight
        .Right = g_ddsd.lWidth
    End With
    
    Dim pcClipper As DirectDrawClipper
    
    Set pcClipper = g_dd.CreateClipper(0)
    pcClipper.SetHWnd Me.hWnd
    
    MainBuffer.SetClipper pcClipper
End Sub'InitD3D函数初始化Direct3D对象，包括3D设备、光源、视角以及材质
Sub InitD3D()
    Dim d3d As Direct3D7
    Dim ddsd As DDSURFACEDESC2
        
    '从DirectDraw对象中获得Direct3D对象
    Set d3d = g_dd.GetDirect3D
    
    '获得DirectDraw对象的显示颜色深度，如果小于16位色，则程序出错退出
    g_dd.GetDisplayMode ddsd
    If ddsd.ddpfPixelFormat.lRGBBitCount <= 8 Then
        MsgBox "本程序不支持颜色位数小于16bit的显示模式，程序将退出"
        End
    End If
    
    On Error Resume Next
    '首先尝试建立硬件3维设备对象(HAL)
    Set Direct3DDevice = d3d.CreateDevice("IID_IDirect3DHALDevice", BackBuffer)
    '如果Direct3DDevice为Nothing说明显示卡不支持硬件Direct3D设备
    '尝试建立RGB3维设备。
    If Direct3DDevice Is Nothing Then
        Set Direct3DDevice = d3d.CreateDevice("IID_IDirect3DRGBDevice", BackBuffer)
    End If
    
    '定义视角区域
    Dim VPDesc As D3DVIEWPORT7
        
    VPDesc.lWidth = g_rcDest.Right - g_rcDest.Left
    VPDesc.lHeight = g_rcDest.Bottom - g_rcDest.Top
    VPDesc.minz = 0#
    VPDesc.maxz = 1#
    '设置Direct3DDevice对象的视角
    Direct3DDevice.SetViewport VPDesc
    
    '保存对视角的设置
    With ViewPortRect(0)
        .X1 = 0: .Y1 = 0
        .X2 = VPDesc.lWidth
        .Y2 = VPDesc.lHeight
    End With
    iViewSize = 4
End Sub'InitDeviceObjects函数建立三维物体
Private Sub InitDeviceObjects()    '建立立方体的顶点数据
    CreateCube g_vCube
     
    '通过位图文件建立三个纹理表面
    Set TextureSurface1 = CreateTextureSurface("t1.bmp")
    Set TextureSurface2 = CreateTextureSurface("t2.bmp")
    Set TextureSurface3 = CreateTextureSurface("t3.bmp")
    
    '使用泛光源以及白色的普通材质
    Dim mtrl As D3DMATERIAL7
    '定义材质对光源的的反射属性，你可以尝试改变它们的值看一下材质
    '的反射效果
    mtrl.diffuse.r = 1#: mtrl.diffuse.g = 0#: mtrl.diffuse.b = 1#
    mtrl.Ambient.r = 1#: mtrl.Ambient.g = 1#: mtrl.Ambient.b = 1#: mtrl.Ambient.a = 1
    mtrl.emissive.r = 1#: mtrl.emissive.g = 0#: mtrl.emissive.b = 1#
    mtrl.emissive.r = 1#: mtrl.specular.g = 1#: mtrl.specular.b = 1#
    '将材质的清晰度设置为10
    mtrl.power = 10
    Direct3DDevice.SetMaterial mtrl
    
    '设置Direct3DDevice的光源为泛光源，你可以尝试对SetRenderState函数的
    '第一个参数使用不同的值，看看光源的效果。
    Direct3DDevice.SetRenderState D3DRENDERSTATE_AMBIENT, _
            g_dx.CreateColorRGBA(1#, 1#, 0#, 1#)
    
    Dim matProj As D3DMATRIX    g_dx.IdentityMatrix matProj    Call g_dx.ProjectionMatrix(matProj, 1, 1000, pi / 4#)
    Direct3DDevice.SetTransform D3DTRANSFORMSTATE_PROJECTION, matProj
End Sub'CreateCube函数建立立方体的顶点数据
Private Sub CreateCube(vertices() As D3DVERTEX)
    '一个立方体有6个面，每面有是一个正方形，有4个顶点，下面共定义了
    '这6个面的24个顶点
    g_dx.CreateD3DVertex -1, 1, -1, 0, 0, -1, 0, 0, vertices(0)
    g_dx.CreateD3DVertex 1, 1, -1, 0, 0, -1, 1, 0, vertices(1)
    g_dx.CreateD3DVertex -1, -1, -1, 0, 0, -1, 0, 1, vertices(2)
    g_dx.CreateD3DVertex 1, -1, -1, 0, 0, -1, 1, 1, vertices(3)
        
    g_dx.CreateD3DVertex -1, 1, 1, 0, 0, 1, 1, 0, vertices(4)
    g_dx.CreateD3DVertex -1, -1, 1, 0, 0, 1, 1, 1, vertices(5)
    g_dx.CreateD3DVertex 1, 1, 1, 0, 0, 1, 0, 0, vertices(6)
    g_dx.CreateD3DVertex 1, -1, 1, 0, 0, 1, 0, 1, vertices(7)
        
    g_dx.CreateD3DVertex -1, 1, 1, 0, 1, 0, 0, 0, vertices(8)
    g_dx.CreateD3DVertex 1, 1, 1, 0, 1, 0, 1, 0, vertices(9)
    g_dx.CreateD3DVertex -1, 1, -1, 0, 1, 0, 0, 1, vertices(10)
    g_dx.CreateD3DVertex 1, 1, -1, 0, 1, 0, 1, 1, vertices(11)
        
    g_dx.CreateD3DVertex -1, -1, 1, 0, -1, 0, 0, 0, vertices(12)
    g_dx.CreateD3DVertex -1, -1, -1, 0, -1, 0, 0, 1, vertices(13)
    g_dx.CreateD3DVertex 1, -1, 1, 0, -1, 0, 1, 0, vertices(14)
    g_dx.CreateD3DVertex 1, -1, -1, 0, -1, 0, 1, 1, vertices(15)
        
    g_dx.CreateD3DVertex 1, 1, -1, 1, 0, 0, 0, 0, vertices(16)
    g_dx.CreateD3DVertex 1, 1, 1, 1, 0, 0, 1, 0, vertices(17)
    g_dx.CreateD3DVertex 1, -1, -1, 1, 0, 0, 0, 1, vertices(18)
    g_dx.CreateD3DVertex 1, -1, 1, 1, 0, 0, 1, 1, vertices(19)
        
    g_dx.CreateD3DVertex -1, 1, -1, -1, 0, 0, 1, 0, vertices(20)
    g_dx.CreateD3DVertex -1, -1, -1, -1, 0, 0, 1, 1, vertices(21)
    g_dx.CreateD3DVertex -1, 1, 1, -1, 0, 0, 0, 0, vertices(22)
    g_dx.CreateD3DVertex -1, -1, 1, -1, 0, 0, 0, 1, vertices(23)
End SubPublic Function CreateTextureSurface(sFile As String) As DirectDrawSurface7
    Dim ddsTexture As DirectDrawSurface7
    Dim i As Long
    Dim bIsFound As Boolean
    
    Dim ddsd As DDSURFACEDESC2
    
    '定义纹理平面的属性
    ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_PIXELFORMAT _
            Or DDSD_TEXTURESTAGE
    
    Dim TextureEnum As Direct3DEnumPixelFormats
    
    '获得当前Direct3DDevice支持的所有纹理类型
    Set TextureEnum = Direct3DDevice.GetTextureFormatsEnum()
    
    '便历所有纹理类型，找到符合需要的类型
    For i = 1 To TextureEnum.GetCount()
        bIsFound = True
        Call TextureEnum.GetItem(i, ddsd.ddpfPixelFormat)
        
        With ddsd.ddpfPixelFormat
            '跳过不常使用的格式
            If .lFlags And (DDPF_LUMINANCE Or DDPF_BUMPLUMINANCE Or DDPF_BUMPDUDV) Then
                bIsFound = False
            End If
            
            '跳过FourCC格式
            If .lFourCC <> 0 Then bIsFound = False
            
            '跳过Alpha模式纹理
            If .lFlags And DDPF_ALPHAPIXELS Then bIsFound = False
            
            '只使用16位颜色三维纹理，跳过其它的颜色设定
            If .lRGBBitCount <> 16 Then bIsFound = False
        End With
        If bIsFound Then Exit For
    Next i
    
    If Not bIsFound Then
        MsgBox "你的图形卡不支持16位颜色绘图平面"
        End
    End If
        
    ddsd.ddsCaps.lCaps = DDSCAPS_TEXTURE
    ddsd.ddsCaps.lCaps2 = DDSCAPS2_TEXTUREMANAGE
    ddsd.lTextureStage = 0
    
    sFile = App.Path + "\" + sFile
    '建立一个新的纹理绘图平面
    Set ddsTexture = g_dd.CreateSurfaceFromFile(sFile, ddsd)
    
    '返回建立的纹理绘图平面
    Set CreateTextureSurface = ddsTexture
End Function

Answer 6

用directX编程还太陌生，不知哪里有相关资料？