VB编写DirectX简明教程随这计算机软硬件的发展,计算机不在只是一个简单的计算工具而成为了一个可以玩游戏、进行多媒体操作的多功能平台。为了编写高性能的游戏和应用程序,我们需要绕过操作系统提供的API直接操作硬件以充分利用硬件的加速效果,但是由于现在的计算机配件数以万计,那么我们在编写程序时需要为每一类编写代码。这样就大大的浪费了资源。现在有了DirectX,这个问题就解决了,硬件厂家只要根据DirectX要求编写驱动程序,而程序员只要同单一的DirectX库打交道而基本不用顾及具体的硬件,这样不但大大的简化了编程而且也提高了程序性能。 一、 DirectDraw DirectDraw类是DirectX中绘图的基础,它包含以下的对象: · DirectDraw7 · DirectDrawClipper · DirectDrawEnumModes · DirectDrawPalette · DirectDrawSurface7 DirectDraw7是基本的DirectDraw类对象,它是建立其它对象的基础,DirectDraw7对象要通过DirectX7对象的DirectDrawCreate方法来建立。例如下面的语句就可以建立一个DirectDraw对象: Set objDx = New DirectX7 下面我们将通过建立一个简单的DirectDraw程序并通过充实程序来学习DirectDraw的基本原理和应用。首先来建立一个简单的DirectDraw程序,建立一个新的工程,将Direct7说明库加入到工程中,然后在Form1中加入两个CommandButton和一个ListBox控件,在Form1中加入以下代码: Dim objDx As New DirectX7 Dim objDraw As DirectDraw7 Dim objEnumModes As DirectDrawEnumModes Sub Cleanup() 'Cleanup函数回复屏幕并且清除DirectX对象 Call objDraw.RestoreDisplayMode Call objDraw.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL) Set objDraw = Nothing Set objDx = Nothing End End Sub Private Sub Command1_Click() CleanUp End Sub Private Sub Form_Load() Command1.Caption = "结束" Command2.Caption = "设置显示模式" On Error GoTo ErrHandler: Dim ddsd As DDSURFACEDESC2 Dim I As Long, lgCount As Long Set objDx = New DirectX7 '建立 DirectDraw 对象 Set objDraw = objDx.DirectDrawCreate("") '将DirectDraw对象支持的显示模式设置到DirectDrawEnumModes对象中 Set objEnumModes = objDraw.GetDisplayModesEnum(DDEDM_DEFAULT, ddsd) '将数据设置到ListBox中 lgCount = objEnumModes.GetCount() For I = 1 To lgCount objEnumModes.GetItem I, ddsd List1.AddItem CStr(ddsd.lWidth) & "x" & CStr(ddsd.lHeight) & "x" _ & CStr(ddsd.ddpfPixelFormat.lRGBBitCount) Next I ErrHandler: Select Case Err.Number Case 0 ''没有错误 Case Else Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, _ Err.HelpContext Call Cleanup End Select End Sub Private Sub Form_Unload(Cancel As Integer) Cleanup End Sub 程序的运行结果如下图: 上面的范例首先演示了如何建立一个简单的DirectDraw对象并获得该对象支持的显示模式。下面我们要将在原来程序的基础上添加一些模块以实现更多的功能。 On Error GoTo ErrHandler Dim ddsd As DDSURFACEDESC2 Dim i As Long i = List1.ListIndex If i = -1 Then MsgBox "请在列表中选择一种显示模式", vbOKOnly, "错误" Exit Function End If objEnumModes.GetItem (i + 1), ddsd ''设置协作模式 objDraw.SetCooperativeLevel Me.hWnd, DDSCL_FULLSCREEN Or _ DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE ''设置显示模式 objDraw.SetDisplayMode ddsd.lWidth,ddsd.lHeight, _ ddsd.ddpfPixelFormat.lRGBBitCount, _ 0, DDSDM_DEFAULT Me.Refresh ErrHandler: Select Case Err.Number Case 0 ''No Errors Case Else Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, _ Err.HelpContext Call Cleanup End Select End Function 在Command2的Click事件中加入以下代码: Dim i For i = 0 To Form1.Controls.Count - 1 Form1.Controls(i).Visible = False Next i SetNewDisplayMode 再次运行程序,点击列表中的任意一个显示模式,然后点击"设置显示模式"按钮,可以看到屏幕的显示模式被设置成了你在列表中选择的模式。 Dim objDx As New DirectX7 Dim objDraw As DirectDraw7 Dim objEnumModes As DirectDrawEnumModes Dim MainSurf As DirectDrawSurface7 Dim BackSurf As DirectDrawSurface7 Dim BmpSurf As DirectDrawSurface7 Dim SpriteSurf As DirectDrawSurface7 Dim ddsd As DDSURFACEDESC2 Dim ddsd1 As DDSURFACEDESC2 Dim ddsd2 As DDSURFACEDESC2 Dim ddsd3 As DDSURFACEDESC2 Dim ddsd4 As DDSURFACEDESC2 Dim ddsd5 As DDSURFACEDESC2 Dim bRun As Boolean Dim lastTime As Long Dim fps As Long Dim lfps As Long Dim FrameCount As Long Dim Clipper As DirectDrawClipper Dim x As DDPIXELFORMAT Dim sx, sy As Integer Dim Pict() As Byte Sub InitSurf() On Error GoTo ErrHandler '设置主绘图平面的属性 ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT ddsd1.lBackBufferCount = 1 ddsd1.ddsCaps.lCaps = DDSCAPS_COMPLEX Or DDSCAPS_FLIP Or DDSCAPS_PRIMARYSURFACE '设置缓冲绘图平面的属性 ddsd2.ddsCaps.lCaps = DDSCAPS_BACKBUFFER '根据ddsd1建立主绘图平面 Set MainSurf = objDraw.CreateSurface(ddsd1) '将BackSurf设置为MainSurf的附加平面 Set BackSurf = MainSurf.GetAttachedSurface(ddsd2.ddsCaps) '设置背景绘图平面的字体和颜色 BackSurf.SetForeColor RGB(255, 255, 255) Form1.Font.Name = "宋体" BackSurf.SetFont Form1.Font '获得缓冲绘图平面的属性并设置到ddsd4中 BackSurf.GetSurfaceDesc ddsd4 '设置图形绘图平面的属性 ddsd3.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH ddsd3.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN ddsd3.lWidth = ddsd4.lWidth ddsd3.lHeight = ddsd4.lHeight '建立图形绘图平面 Set BmpSurf = objDraw.CreateSurfaceFromFile(App.Path + "/demo.bmp", ddsd3) '设定角色位图平面的属性 ddsd5.lFlags = DDSD_CAPS ddsd5.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN '建立角色位图平面 Set SpriteSurf = objDraw.CreateSurfaceFromFile(App.Path + "/sprite.bmp", ddsd5) Dim key As DDCOLORKEY '设定透明色(在这里设定为0,黑色) key.low = 0 key.high = 0 SpriteSurf.SetColorKey DDCKEY_SRCBLT, key sx = 20: sy = 20 lastTime = objDx.TickCount While True DoEvents Blt Wend ErrHandler: Select Case Err.Number Case 0 ''No Errors Case Else '错误退出 Call Cleanup End Select End Sub Sub Blt() Dim mrectScreen As RECT Dim sTimePass As Single Dim sFramePerS As Single '以黑色清除并填充后台绘图平面 BackSurf.BltColorFill mrectScreen, 0 '获得背景位图平面的矩形区域的尺寸 mrectScreen.Right = ddsd2.lWidth mrectScreen.Bottom = ddsd2.lHeight '将图形绘图平面中的内容复制到后台绘图平面上 Call BackSurf.BltFast(0, 0, BmpSurf, mrectScreen, DDBLTFAST_WAIT) '获得前景角色位图平面的矩形区域 mrectScreen.Right = ddsd5.lWidth mrectScreen.Bottom = ddsd5.lHeight '将前景角色位图复制到后台绘图平面上。 Call BackSurf.BltFast(sx, sy, SpriteSurf, mrectScreen, DDBLTFAST_SRCCOLORKEY) sx = sx + 2: sy = sy + 2 If sx > 400 Then sx = 20 If sy > 400 Then sy = 20 '在后台绘图平面上输出文本 BackSurf.DrawText 30, 30, "This is my first DirectX program", False BackSurf.DrawText 30, 60, "点击屏幕退出程序", False '获得每秒的播放帧数。 FrameCount = FrameCount + 1 sTimePass = (objDx.TickCount - lastTime) / 1000 If sTimePass > 0.5 Then sFramePerS = FrameCount / sTimePass End If BackSurf.DrawText 30, 90, "每秒帧数:" + Format$(sFramePerS, "##00.0"), False '将后台绘图平面上的内容翻转到前台来 MainSurf.Flip Nothing, DDFLIP_WAIT End Sub Private Function SetNewDisplayMode() On Error GoTo ErrHandler Dim i As Long i = List1.ListIndex If i = -1 Then MsgBox "请在列表中选择一种显示模式", vbOKOnly, "错误" Exit Function End If '获得用户选择的显示模式 objEnumModes.GetItem (i + 1), ddsd ''设置协作模式 objDraw.SetCooperativeLevel Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX _ Or DDSCL_EXCLUSIVE ''设置显示模式 objDraw.SetDisplayMode ddsd.lWidth, ddsd.lHeight, ddsd.ddpfPixelFormat.lRGBBitCount, _ 0, DDSDM_DEFAULT Me.Refresh ErrHandler: Select Case Err.Number Case 0 ''No Errors Case Else Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, _ Err.HelpContext Call Cleanup End Select End Function Sub Cleanup() 'Cleanup函数回复屏幕并且清除DirectX对象 Call objDraw.RestoreDisplayMode Call objDraw.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL) Set objDraw = Nothing Set objDx = Nothing End End Sub Private Sub Command1_Click() End End Sub Private Sub Command2_Click() Dim i For i = 0 To Form1.Controls.Count - 1 Form1.Controls(i).Visible = False Next i SetNewDisplayMode InitSurf End Sub Private Sub Form_Click() Cleanup End Sub Private Sub Form_Load() Command1.Caption = "结束" Command2.Caption = "设置显示模式" On Error GoTo ErrHandler: Dim ddsd As DDSURFACEDESC2 Dim i As Long, lgCount As Long Set objDx = New DirectX7 '建立 DirectDraw 对象 Set objDraw = objDx.DirectDrawCreate("") '将DirectDraw对象支持的显示模式设置到DirectDrawEnumModes对象中 Set objEnumModes = objDraw.GetDisplayModesEnum(DDEDM_DEFAULT, ddsd) '将数据设置到ListBox中 lgCount = objEnumModes.GetCount() For i = 1 To lgCount objEnumModes.GetItem i, ddsd List1.AddItem CStr(ddsd.lWidth) & "x" & CStr(ddsd.lHeight) & "x" _ & CStr(ddsd.ddpfPixelFormat.lRGBBitCount) Next i ErrHandler: Select Case Err.Number Case 0 ''没有错误 Case Else Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, _ Err.HelpContext Call Cleanup End Select End Sub 现在程序全部完成了,运行程序,点击列表中的任意显示模式,然后点击"设置显示模式"按钮,可以看到位图被显示在屏幕上并且在屏幕上显示出程序中的文本。 二、 Direct3D 由上面的图可以看到。Direct3D的立即模式同图形加速硬件之间的结合比较紧密,性能比较高,适合于开发三维游戏。而Direct3D的保留模式具有层次性,可移植性比较的好,可以用于开发商业的三维应用程序(例如设备展示等)。 Const pi As Single = 3.141592 Const 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 DirectDrawSurface7 Dim 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 Integer Private 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 Sub Private 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 Sub Private 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 Sub Private 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) '将后台绘图平面的尺寸保存到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 Sub Public 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 运行程序,在窗口中会出现一个带贴图的立方体,按动上下左右方向键就可以向不同的方向滚动立方体,按动+、-键可以缩放立方体。
其中x'、y'、z'为新坐标。FrameMove函数中的SetTransform方法就是根据D3DMATRIX对象定义的4*4的矩阵进行坐标系变换的函数。另外作者还编写了一个平移对象的FrameMove函数,函数如下: Dim matView As D3DMATRIX Dim matWorld As D3DMATRIX '建立线形矩阵 g_dx.IdentityMatrix matView 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 If bType Then g_dx.RotateXMatrix matView, stepVal Else g_dx.RotateYMatrix matView, stepVal End If Direct3DDevice.SetTransform D3DTRANSFORMSTATE_VIEW, matView g_dx.IdentityMatrix matWorld matWorld.rc11 = 1 matWorld.rc22 = Cos(-0.5) matWorld.rc23 = Sin(-0.5) matWorld.rc32 = -Sin(-0.5) matWorld.rc33 = Cos(-0.5) matWorld.rc43 = iViewSize Direct3DDevice.SetTransform D3DTRANSFORMSTATE_WORLD, matWorld End Sub 你可以将这个函数代入上面的程序运行,程序运行时首先按-键将立方体缩小,然后按动上下左右键看立方体是如何平移的。 接下来介绍Direct3D保留模式对象编程,由于Direct3D保留模式对象比较多而且相对立即模式使用起来比较简单,我们就来直接切入程序。 Dim g_dx As New DirectX7 Dim g_dd As DirectDraw4 Dim pcClipper As DirectDrawClipper Dim g_ddsd As DDSURFACEDESC2 Dim MainBuffer As DirectDrawSurface4 Dim BackBuffer As DirectDrawSurface4 'Direct3DRM对象 Dim D3DRM As Direct3DRM3 '三维设备对象 Dim RMDevice As Direct3DRMDevice3 '三维视区对象 Dim RMViewPort As Direct3DRMViewport2 '三维场景对象 Dim RMFrameScene As Direct3DRMFrame3 Dim RMFrameCamera As Direct3DRMFrame3 Dim RMFrameDirLight As Direct3DRMFrame3 Dim RMFrameAmbientLight As Direct3DRMFrame3 '光源对象 Dim RMDirLight As Direct3DRMLight Dim RMAmbientLight As Direct3DRMLight 'Direct3DRMMeshBuilder3对象是提供与mesh对象象交互作用的对象 '一个mesh对象是一个由多个多边形组成德多面体 Dim meshbox As Direct3DRMMeshBuilder3 Dim framebox As Direct3DRMFrame3 Dim g_rcDest As RECT, g_rcSrc As RECT Sub CleanUp() Err.Clear On Local Error Resume Next Set RMFrameCamera = Nothing Set RMFrameScene = Nothing Set RMFrameDirLight = Nothing Set RMFrameAmbientLight = Nothing Set RMDirLight = Nothing Set RMAmbientLight = Nothing g_dd.RestoreDisplayMode g_dd.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL Set BackBuffer = Nothing Set MainBuffer = Nothing Set g_dd = Nothing Set RMViewPort = Nothing Set RMDevice = Nothing End Sub Private Sub InitDDraw() Set RMViewPort = Nothing Set RMDevice = Nothing '建立DirectDraw对象 Set g_dd = g_dx.DirectDraw4Create("") '设定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) Set pcClipper = g_dd.CreateClipper(0) pcClipper.SetHWnd Me.hWnd MainBuffer.SetClipper pcClipper g_dx.GetWindowRect Me.hWnd, g_rcDest 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) End Sub 'InitS函数设定三维场景 Sub InitS() Set D3DRM = g_dx.Direct3DRMCreate '建立三维场景 Set RMFrameScene = D3DRM.CreateFrame(Nothing) '建立相机 Set RMFrameCamera = D3DRM.CreateFrame(RMFrameScene) '设置相机位置 RMFrameCamera.SetPosition Nothing, 0, 0, -10 '建立方向光源以及设置亮度 Set RMFrameDirLight = D3DRM.CreateFrame(RMFrameScene) Set RMDirLight = D3DRM.CreateLightRGB(D3DRMLIGHT_DIRECTIONAL, 1, 1, 1) '建立环境光源,环境光源的亮度只有方向光源的1/5 Set RMAmbientLight = D3DRM.CreateLightRGB(D3DRMLIGHT_AMBIENT, 0.2, 0.2, 0.2) '将光源添加到三维场景中 RMFrameDirLight.AddLight RMDirLight RMFrameScene.AddLight RMAmbientLight '设置光源位置 RMFrameDirLight.SetPosition Nothing, 5, 5, -5 RMFrameDirLight.LookAt RMFrameScene, Nothing, 0 End Sub 'InitD3DRM函数设定三维设备和视区 Sub InitD3dRM() Dim f As Direct3DRMFace2 Dim ddsd As DDSURFACEDESC2 Dim r As RECT Dim D3DTexture As Direct3DRMTexture3 '获得窗口矩形区域 Call g_dx.GetWindowRect(Me.hWnd, r) ddsd.lWidth = r.Right - r.Left ddsd.lHeight = r.Bottom - r.Top ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_3DDEVICE Or _ DDSCAPS_SYSTEMMEMORY '在后台绘图平面的基础上建立D3dRMDevice Set RMDevice = D3DRM.CreateDeviceFromSurface("IID_IDirect3DRGBDevice", _ g_dd, BackBuffer, 0) '三维设备接管窗口的绘制 RMDevice.HandleActivate 0 RMDevice.HandlePaint Me.hWnd '建立视区,视区的范围为窗口的范围 Set RMViewPort = D3DRM.CreateViewport(RMDevice, RMFrameCamera, 0, 0, _ ddsd.lWidth, ddsd.lHeight) '建立高路德渲染 RMDevice.SetQuality D3DRMRENDER_GOURAUD '建立子场景 Set framebox = D3DRM.CreateFrame(RMFrameScene) Set meshbox = D3DRM.CreateMeshBuilder Set D3DTexture = D3DRM.LoadTexture(App.Path + "/glass.bmp") '为meshbox建立六个平面并设置纹理 Set f = D3DRM.CreateFace() f.AddVertex 2, 2, -2 f.AddVertex 2, -2, -2 f.AddVertex -2, -2, -2 f.AddVertex -2, 2, -2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing Set f = D3DRM.CreateFace() f.AddVertex -2, 2, 2 f.AddVertex -2, -2, 2 f.AddVertex 2, -2, 2 f.AddVertex 2, 2, 2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing Set f = D3DRM.CreateFace() f.AddVertex 2, 2, 2 f.AddVertex 2, -2, 2 f.AddVertex 2, -2, -2 f.AddVertex 2, 2, -2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing Set f = D3DRM.CreateFace() f.AddVertex -2, -2, 2 f.AddVertex -2, 2, 2 f.AddVertex -2, 2, -2 f.AddVertex -2, -2, -2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing Set f = D3DRM.CreateFace() f.AddVertex 2, 2, -2 f.AddVertex -2, 2, -2 f.AddVertex -2, 2, 2 f.AddVertex 2, 2, 2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing Set f = D3DRM.CreateFace() f.AddVertex 2, -2, 2 f.AddVertex -2, -2, 2 f.AddVertex -2, -2, -2 f.AddVertex 2, -2, -2 f.SetTextureCoordinates 0, 0, 0 f.SetTextureCoordinates 1, 0, 4 f.SetTextureCoordinates 2, 4, 4 f.SetTextureCoordinates 3, 4, 0 f.SetTexture D3DTexture meshbox.AddFace f Set f = Nothing meshbox.SetName "Box" Set f = D3DRM.CreateFace meshbox.SetName "Color Box" framebox.SetPosition Nothing, -5, 0, 10 framebox.SetRotation Nothing, 1, 1, 1, 0.05 '分别设置六个平面德颜色 meshbox.GetFace(0).SetColor g_dx.CreateColorRGB(1, 1, 0) meshbox.GetFace(1).SetColor g_dx.CreateColorRGB(0, 1, 0) meshbox.GetFace(2).SetColor g_dx.CreateColorRGB(0, 0, 1) meshbox.GetFace(3).SetColor g_dx.CreateColorRGB(1, 1, 0) meshbox.GetFace(4).SetColor g_dx.CreateColorRGB(0, 1, 1) meshbox.GetFace(5).SetColor g_dx.CreateColorRGB(1, 1, 1) '将立方体对象添加到场景中 framebox.AddVisual meshbox End Sub Private Sub Form_Load() Dim rectMe As RECT Dim rectEmpty As RECT Me.Show Me.ScaleMode = 3 InitS InitDDraw InitD3dRM g_dx.GetWindowRect Me.hWnd, rectMe While True DoEvents '清除视区内德内容 RMViewPort.Clear D3DRMCLEAR_ZBUFFER Or D3DRMCLEAR_TARGET '重新渲染视区内的场景 RMViewPort.Render RMFrameScene '更新三维设备 RMDevice.Update '将后台绘图平面的内容翻转到前台来 Call MainBuffer.Blt(rectMe, BackBuffer, rectEmpty, DDBLT_WAIT) Wend End Sub Private Sub Form_Unload(Cancel As Integer) CleanUp End End Sub 运行程序,在窗口中就会出现一个立方体,可以看到,相对于使用立即模式,上面的保留模式就简单的多了。首先调用InitS函数建立场景、设置灯光以及相机,然后调用InitDDraw函数建立DirectDraw对象,最后调用InitD3dRM函数建立Direct3D对象以及设备并绘制三维立方体,设置立方体每面的颜色并添加到场景中(演员登场)。如果想让三维对象动起来,可以通过设置三维对象的位置、场景的角度以及相机的角度来分别实现。 Dim dx As New DirectX7 Dim di As DirectInput Dim diDEV As DirectInputDevice Dim diMouse As DirectInputDevice Dim diState As DIKEYBOARDSTATE Dim diSMouse As DIMOUSESTATE Dim iKeyCounter As Integer Dim ix, iy, iz Private Sub Form_Load() Set di = dx.DirectInputCreate() If Err.Number <> 0 Then MsgBox "Direct Input设置错误,请确认再你的系统中是否安装了DirectX", _ vbApplicationModal End End If '建立一个键盘DirectInput对象 Set diDEV = di.CreateDevice("GUID_SysKeyboard") Set diMouse = di.CreateDevice("GUID_SysMouse") diDEV.SetCommonDataFormat DIFORMAT_KEYBOARD diDEV.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE diMouse.SetCommonDataFormat DIFORMAT_MOUSE diMouse.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE Me.Show diDEV.Acquire diMouse.Acquire ix = diSMouse.x iy = diSMouse.y iz = diSMouse.z Timer1.Interval = 10 '设置敲击键盘的灵敏度 Timer1.Enabled = True End Sub Private Sub Form_Unload(Cancel As Integer) '程序结束后释放DirectInput对象 diDEV.Unacquire diMouse.Unacquire End Sub Private Sub Timer1_Timer() '获得当前的击键值 diDEV.GetDeviceStateKeyboard diState For iKeyCounter = 0 To 255 '判断是否敲击了某键 If diState.Key(iKeyCounter) <> 0 Then Label1.Caption = iKeyCounter & " - 击键时间为: (" & Time & ")" End If Next diMouse.GetDeviceStateMouse diSMouse If diSMouse.x <> 0 Then ix = diSMouse.x End If If diSMouse.y <> 0 Then iy = diSMouse.y End If If diSMouse.z <> 0 Then iz = diSMouse.z End If Form1.Caption = "X:" & ix & " Y:" & iy & " Z:" & iz DoEvents End Sub 运行程序,敲击键盘的任意键,可以看到键值显示在了Label1上,而移动鼠标,当前鼠标坐标会显示在Form1的标题条上(光标的坐标原点是程序运行时光标所在的位置,而如果你的鼠标有滚轮的话,则Z坐标由你的滚轮的滚动所决定)。而不论窗口处于前台或者后台,击键和鼠标动作都会倍记录下来,你可以利用上面的程序稍加修改建立自己的鼠标键盘Hook程序。 Dim m_ds As DirectSound Dim m_dsBuffer As DirectSoundBuffer Dim m_ds3dBuffer As DirectSound3DBuffer Dim m_dsPrimaryBuffer As DirectSoundBuffer Dim m_dsListener As DirectSound3DListener Dim m_pos As D3DVECTOR Sub DrawPositions() Dim X As Integer Dim z As Integer Picture1.Cls '以黑色圈标出收听者所在的位置 Picture1.Circle (Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2), 4 '以红色圈标出声音所在的位置 X = CInt(m_pos.X) + Picture1.ScaleWidth / 2 z = CInt(m_pos.z) + Picture1.ScaleHeight / 2 Picture1.Circle (X, z), 4, RGB(255, 0, 0) End Sub Sub Load(sFile As String) Dim bufferDesc1 As DSBUFFERDESC Dim waveFormat1 As WAVEFORMATEX '设置将建立的DirectSoundBuffer对象的属性 bufferDesc1.lFlags = (DSBCAPS_CTRL3D Or DSBCAPS_CTRLFREQUENCY Or _ DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME) Or DSBCAPS_STATIC '建立DirectSoundBuffer对象 Set m_dsBuffer = m_ds.CreateSoundBufferFromFile(sFile, bufferDesc1, _ waveFormat1) '设置DirectSoundBuffer对象的声音(0为最大) m_dsBuffer.SetVolume 0 '设置DirectSoundBuffer对象 Set m_ds3dBuffer = m_dsBuffer.GetDirectSound3DBuffer '设置DirectSoundBuffer对象的播放方向属性 m_ds3dBuffer.SetConeOrientation 1, 1, 1, DS3D_IMMEDIATE m_ds3dBuffer.SetConeAngles DS3D_MINCONEANGLE, 100, DS3D_IMMEDIATE m_ds3dBuffer.SetConeOutsideVolume -100, DS3D_IMMEDIATE '设置DirectSoundBuffer对象的播放位置属性 m_ds3dBuffer.SetPosition m_pos.X / 50, 0, m_pos.z / 50, DS3D_IMMEDIATE End Sub Sub UpdatePosition(X As Single, z As Single) m_pos.X = X - Picture1.ScaleWidth / 2 m_pos.z = z - Picture1.ScaleHeight / 2 DrawPositions If m_ds3dBuffer Is Nothing Then Exit Sub '重新设置DirectSoundBuffer对象的播放位置属性 m_ds3dBuffer.SetPosition m_pos.X / 50, 0, m_pos.z / 50, DS3D_IMMEDIATE End Sub Private Sub Command1_Click() If m_dsBuffer Is Nothing Then Call Load(App.Path + "/demo.wav") End If '循环播放声音文件 m_dsBuffer.Play 1 End Sub Private Sub Command2_Click() If m_dsBuffer Is Nothing Then Exit Sub m_dsBuffer.Stop m_dsBuffer.SetCurrentPosition 0 End Sub Private Sub Form_Load() Dim i As Integer Command1.Caption = "播放" Command2.Caption = "停止" Me.Show DoEvents On Local Error Resume Next '建立DirectSound对象 Set m_ds = m_dx.DirectSoundCreate(vbNullString) If Err.Number <> 0 Then MsgBox "无法佳丽DirectSound对象,请查看声卡或驱动程序是否安装正确" End End If '设置DirectSound对象的协作模式 m_ds.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY Dim primDesc As DSBUFFERDESC, format As WAVEFORMATEX primDesc.lFlags = DSBCAPS_CTRL3D Or DSBCAPS_PRIMARYBUFFER '建立主声音缓冲对象 Set m_dsPrimaryBuffer = m_ds.CreateSoundBuffer(primDesc, format) '建立DirectSound3DListener对象 Set m_dsListener = m_dsPrimaryBuffer.GetDirectSound3DListener() m_pos.X = 10: m_pos.z = 50 UpdatePosition m_pos.X, m_pos.z End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then UpdatePosition X, Y End If End Sub Private Sub Picture1_Paint() DrawPositions End Sub 运行程序,在PictureBox中回出现一个黑色和一个红色的小圆圈。黑色的代表虚拟的收听者的位置,红色的代表音源的位置。点击"播放"按钮即可以播放Demo.wav文件,你可以点击PictureBox中的不同位置来设置音源的位置,然后再听一下声音发生的改变,在本人的爱机上安装的只是普通双声道声卡,所以效果不是很明显,有高档多声道声卡的朋友可以使用上面的程序感受一下你的声卡的三维效果。 DirectMusicLoader对象负责装载音乐数据文件,利用DirectX7对象的 Private Declare Sub Sleep Lib "kernel32" (ByVal lMilliseconds As Long) Dim objDX As New DirectX7 Dim objDMLoader As DirectMusicLoader Dim objDMPerf As DirectMusicPerformance Dim objDMSeg As DirectMusicSegment Dim objDMSegSt As DirectMusicSegmentState Dim DTimesig As DMUS_TIMESIGNATURE Dim portcaps As DMUS_PORTCAPS Dim lTimePassed As Long Dim lMTime As Long Dim lTempo, GetStartTime, Offset As Long Dim ElapsedTime2 As Long Dim ElapsedTime, sAllTime As String Dim fIsPaused As Boolean Sub GetTimePassed() Dim min As Integer Dim a As Single '首先确定objDMSegSt以及objDMPerf是否有效 If objDMSegSt Is Nothing Or objDMPerf Is Nothing Then Exit Sub End If '处于播放状态 If objDMPerf.IsPlaying(Nothing, objDMSegSt) = True Then '获得以秒计算的播放时间 ElapsedTime2 = ((((objDMPerf.GetMusicTime() - (objDMSegSt.GetStartTime() _ - Offset)) / 768) * 60) / lTempo) '获得分钟 min = 0 a = ElapsedTime2 - 60 Do While a >= 0 min = min + 1 a = a - 60 Loop ElapsedTime = Format(min, "00") & ":" & Format(Abs((ElapsedTime2 - (min * 60))), "00.0") Else If fIsPaused Then Else ElapsedTime = "00:00.0" End If End If End Sub Private Sub Command1_Click() Set objDMLoader = Nothing Set objDMLoader = objDX.DirectMusicLoaderCreate CommonDialog1.Filter = "MIDI Files (*.mid)|*.mid" ' Set filters CommonDialog1.InitDir = App.Path CommonDialog1.ShowOpen If Dir$(CommonDialog1.FileName) <> "" Then Me.Caption = CommonDialog1.FileName '读入MIDI文件 Set objDMSeg = objDMLoader.LoadSegment(CommonDialog1.FileName) '获得MIDI文件的播放时间 lMTime = objDMPerf.GetMusicTime() '播放一定程度的MIDI文件以获取文件信息 Call objDMPerf.PlaySegment(objDMSeg, 0, lMTime + 2000) '获取MIDI播放速度 lTempo = objDMPerf.GetTempo(lMTime + 2000, 0) Label2.Caption = "MIDI速度" + Format(lTempo, "00.00") '获得MIDI节拍信息 Call objDMPerf.GetTimeSig(lMTime + 2000, 0, DTimesig) Label3.Caption = "MIDI节拍" & DTimesig.beatsPerMeasure & "/" & DTimesig.beat Dim a, Minutes, mtlength As Long '获得MIDI播放长度 mtlength = (((objDMSeg.GetLength() / 768) * 60) / lTempo) Minutes = 0 a = mtlength - 60 Do While a > 0 Minutes = Minutes + 1 a = a - 60 Loop Label1.Caption = "MIDI播放时间" + Format(Minutes, "00") & ":" & _ Format((mtlength - (Minutes * 60)), "00.0") sAllTime = Format(Minutes, "00") & ":" & Format((mtlength - (Minutes * 60)), "00.0") '已经获得足够长度的MIDI文件信息,停止播放 Call objDMPerf.Stop(objDMSeg, Nothing, 0, 0) objDMSeg.SetStandardMidiFile Command2.Enabled = True Else Command2.Enabled = False Command3.Enabled = False Command4.Enabled = False End If End Sub Private Sub Command2_Click() Timer1.Enabled = True If objDMSeg Is Nothing Then MsgBox ("没有可以播放的MIDI文件,请先打开一个MIDI文件") Exit Sub End If If fIsPaused Then '当前处于暂停状态 '获得暂停位置 Offset = lMTime - GetStartTime + Offset + 1 '设置开始播放点为暂停位置 Call objDMSeg.SetStartPoint(Offset) '播放MIDI Set objDMSegSt = objDMPerf.PlaySegment(objDMSeg, 0, 0) fIsPaused = False Sleep (90) Else Offset = 0 If objDMPerf.IsPlaying(objDMSeg, objDMSegSt) = True Then '停止播放 Call objDMPerf.Stop(objDMSeg, objDMSegSt, 0, 0) End If objDMSeg.SetStartPoint (0) Set objDMSegSt = objDMPerf.PlaySegment(objDMSeg, 0, 0) Sleep (90) End If Command2.Enabled = False Command3.Enabled = True Command4.Enabled = True End Sub Private Sub Command3_Click() On Error GoTo LocalErrors If objDMSeg Is Nothing Then Exit Sub If objDMPerf.IsPlaying(objDMSeg, objDMSegSt) = True Then fIsPaused = True '获得已经播放的长度 lMTime = objDMPerf.GetMusicTime() GetStartTime = objDMSegSt.GetStartTime() Call objDMPerf.Stop(objDMSeg, Nothing, 0, 0) End If Command2.Enabled = True Command3.Enabled = False Command4.Enabled = False Exit Sub LocalErrors: Call Err.Raise(Err.Number, Err.Source, Err.Description) End Sub Private Sub Command4_Click() If objDMSeg Is Nothing Then Exit Sub End If fIsPaused = False '停止播放MIDI文件 Call objDMPerf.Stop(objDMSeg, objDMSegSt, 0, 0) End Sub Private Sub Form_Load() Me.Show '建立DirectMusicLoader对象 Set objDMLoader = objDX.DirectMusicLoaderCreate '建立DirectMusicPerformance对象 Set objDMPerf = objDX.DirectMusicPerformanceCreate '初始化DirectMusicPerformance对象 objDMPerf.Init Nothing, 0 objDMPerf.SetPort -1, 80 objDMPerf.SetMasterAutoDownload (True) objDMPerf.SetMasterVolume (-700) Command1.Caption = "打开MIDI文件" Command2.Caption = "播放" Command3.Caption = "暂停" Command4.Caption = "停止" Command2.Enabled = False Command3.Enabled = False Command4.Enabled = False Label1.Caption = "" Label2.Caption = "" Label3.Caption = "" Timer1.Interval = 100 Timer1.Enabled = False End Sub Private Sub Form_Unload(Cancel As Integer) Set objDMSegSt = Nothing Set objDMSeg = Nothing Set objDMPerf = Nothing Set objDMLoader = Nothing End End Sub Private Sub Timer1_Timer() GetTimePassed Label1.Caption = "MIDI播放时间:" + ElapsedTime + " 总时间:" + sAllTime End Sub 运行程序,点击"打开MIDI文件"文件按钮打开一个MIDI文件,点击"播放"按钮播放文件,点击"暂停"按钮暂停播放,点击"停止"按钮停止播放。 |
© 2000 AppleVB.com版权所有。更新日期 2001年1月24日
© 2000 www.AppleVB.com版权所有。
© 2000 AppleVB.com°戨˹Ӑ¡£
¸Նڼ/b> 2001Ī1Ԃ24ȕ