VB6编程：DirectX 2D图形学习日志24高级动画
教程下载地址：https://download.csdn.net/download/gosub60/13696651
作用：使用多幅BMP图合成一个卡通动画
总结：在后边
源码如下：需要几个连贯的卡通图片配合。
'---------------------------------
'标题：DirectX教程
'
'描述：本教程是动画纹理的更高级版本。
'
'作者：Jacob Roman 翻译：[email protected] QQ:127644712
'
'日期：12/04/2005
'
'联系人：[email protected]
'---------------------------------
Option Explicit
Private Type RECT_SINGLE
Left As Single
Top As Single
Right As Single
Bottom As Single
End Type
Private Type Animation_Type
Frame_Size() As RECT
Number_Of_Frames As Long
Number_Of_Textures As Long
Current_Frame As Single
Frame_Counter As Long
Speed As Single
Mode As Long '单发，循环等
Offset() As D3DVECTOR2
Texture_Number() As Long
End Type
Private Type Sprite_Type
X As Single
Y As Single
Animation_State As Animation_Type
Texture_Path() As String
Texture_List() As Direct3DTexture8
Total_Number_Of_Textures As Long
End Type
''2D（已转换和已点燃）顶点格式类型。
Private Type TLVERTEX
X As Single
Y As Single
Z As Single
RHW As Single
Color As Long
Specular As Long
TU As Single
TV As Single
End Type
Private Const ANIMATION_MODE_SINGLE_SHOT As Long = 0
Private Const ANIMATION_MODE_LOOP As Long = 1
'一些颜色深度常数有助于使DX常数更具可读性。
Private Const COLOR_DEPTH_16_BIT As Long = D3DFMT_R5G6B5
Private Const COLOR_DEPTH_24_BIT As Long = D3DFMT_A8R8G8B8
Private Const COLOR_DEPTH_32_BIT As Long = D3DFMT_X8R8G8B8
'2D（转换和点亮）顶点格式。
Private Const FVF_TLVERTEX As Long = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR
Private DirectX8 As DirectX8 '主DirectX对象。
Private Direct3D As Direct3D8 '控制3D一切。
Private Direct3D_Device As Direct3DDevice8 '表示硬件渲染
Private Direct3DX As D3DX8
Private Window_Width As Long
Private Window_Height As Long
Private Fullscreen_Width As Long
Private Fullscreen_Height As Long
Private Color_Depth As Long
Private Fullscreen_Enabled As Boolean '帮助确定它是否为全屏模式。
Private Running As Boolean '帮助确定主游戏循环是否正在运行。
Private Vertex_List(3) As TLVERTEX '4个顶点将构成一个正方形
Private Sprite As Sprite_Type
Private Frame As RECT_SINGLE
Private Scalar As D3DVECTOR2
Private Sub Window_Setup(Window As Form, Optional ByVal X As Long = -1, Optional ByVal Y As Long = -1, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional Caption As String = " ", Optional Auto_Redraw As Boolean = False, Optional ByVal Back_Color As Long = -1)
'使用-1作为默认值，并使用“”作为默认字符串。
With Window
If Caption <> " " Then .Caption = Caption '否则使用当前设置。 注意：一些
'人们可能希望以“”作为标题。
.AutoRedraw = Auto_Redraw
.ScaleMode = 3
If X <> -1 Then .Left = X '否则使用当前设置
If Y <> -1 Then .Top = Y '否则使用当前设置
If Width <> -1 Then .Width = Width * Screen.TwipsPerPixelX '否则使用当前设置
If Height <> -1 Then .Height = Height * Screen.TwipsPerPixelY '否则使用当前设置
If Back_Color <> -1 Then .BackColor = Back_Color '否则使用当前设置
.Show
.Refresh
.SetFocus
End With
End Sub
'使用此功能可以更轻松地设置具有所需信息的顶点。
Private Function Create_TLVertex(X As Single, Y As Single, Z As Single, RHW As Single, Color As Long, Specular As Long, TU As Single, TV As Single) As TLVERTEX
Create_TLVertex.X = X
Create_TLVertex.Y = Y
Create_TLVertex.Z = Z
Create_TLVertex.RHW = RHW
Create_TLVertex.Color = Color
Create_TLVertex.Specular = Specular
Create_TLVertex.TU = TU
Create_TLVertex.TV = TV
End Function
Private Function DirectX_Initialize() As Boolean
On Error GoTo Error_Handler
Dim Display_Mode As D3DDISPLAYMODE '显示模式说明。
Dim Direct3D_Window As D3DPRESENT_PARAMETERS 'Backbuffer和视口说明。
Set DirectX8 = New DirectX8 '创建DirectX对象。
Set Direct3D = DirectX8.Direct3DCreate() '使用DirectX对象创建Direct3D对象
Set Direct3DX = New D3DX8
If Fullscreen_Enabled = True Then
'“现在我们正在全屏模式下工作，我们必须设置
'屏幕分辨率切换为，而不是使用默认屏幕
'解析度。
Display_Mode.Width = Fullscreen_Width
Display_Mode.Height = Fullscreen_Height
Display_Mode.Format = Color_Depth
Direct3D_Window.Windowed = False '该应用程序将处于全屏模式。
Direct3D_Window.BackBufferCount = 1 '仅1个后缓冲
Direct3D_Window.BackBufferWidth = Display_Mode.Width '使后缓冲宽度与显示宽度匹配
Direct3D_Window.BackBufferHeight = Display_Mode.Height '使后缓冲高度与显示高度匹配
Direct3D_Window.hDeviceWindow = frmMain.hWnd '使用frmMain作为设备窗口
Else
Direct3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Display_Mode '使用您当前使用的显示模式
'已经在。 如果您感到困惑，我是
'在谈论您当前的屏幕分辨率。 ;）
Direct3D_Window.Windowed = True '该应用程序将处于窗口模式
End If
Direct3D_Window.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC '监视器运行时刷新。
Direct3D_Window.BackBufferFormat = Display_Mode.Format '设置检索到后缓冲区中的格式。
'使用一些有用的信息以及信息创建渲染设备
'我们已经设置了Direct3D_Window。
Set Direct3D_Device = Direct3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, frmMain.hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, Direct3D_Window)
Direct3D_Device.SetVertexShader FVF_TLVERTEX '设置顶点着色的类型。 （需要）
Direct3D_Device.SetRenderState D3DRS_SRCBLEND, D3DBLEND_ONE
Direct3D_Device.SetRenderState D3DRS_DESTBLEND, D3DBLEND_SRCALPHA
Direct3D_Device.SetRenderState D3DRS_ALPHAREF, 255
Direct3D_Device.SetRenderState D3DRS_ALPHAFUNC, D3DCMP_GREATEREQUAL
' 不需要这些行，但能够过滤掉
'使它们看起来更好的纹理。
Direct3D_Device.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_POINT
Direct3D_Device.SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTEXF_POINT
Exit Function
Error_Handler:
MsgBox "An error occured while initializing DirectX", vbCritical
DirectX_Initialize = False
End Function
Private Sub Load_Textures()
Dim Width As Long
Dim Height As Long
Dim Transparency_Color As Long
Dim Current_Texture As Long
With Sprite
.Total_Number_Of_Textures = 4
ReDim .Texture_Path(.Total_Number_Of_Textures) As String
ReDim .Texture_List(.Total_Number_Of_Textures) As Direct3DTexture8
.Texture_Path(0) = App.Path & "\Graphics\Ken1.bmp"
.Texture_Path(1) = App.Path & "\Graphics\Ken2.bmp"
.Texture_Path(2) = App.Path & "\Graphics\Ken3.bmp"
.Texture_Path(3) = App.Path & "\Graphics\Ken4.bmp"
Width = 1024
Height = 1024
Transparency_Color = D3DColorRGBA(0, 0, 0, 255)
For Current_Texture = 0 To .Total_Number_Of_Textures - 1
Set .Texture_List(Current_Texture) = Direct3DX.CreateTextureFromFileEx(Direct3D_Device, _
.Texture_Path(Current_Texture), _
Width, Height, _
0, _
0, _
D3DFMT_A8R8G8B8, _
D3DPOOL_MANAGED, _
D3DX_FILTER_POINT, _
D3DX_FILTER_POINT, _
Transparency_Color, _
ByVal 0, _
ByVal 0)
Next Current_Texture
End With
End Sub
Private Sub Setup_Sprite()
If Fullscreen_Enabled = False Then
Scalar.X = 1
Scalar.Y = 1
Else
Scalar.X = Fullscreen_Width / Window_Width
Scalar.Y = Fullscreen_Height / Window_Height
End If
With Sprite
.X = 50
.Y = 100
With .Animation_State
.Number_Of_Frames = 6
.Number_Of_Textures = 4
.Speed = 0.25
.Mode = ANIMATION_MODE_LOOP
ReDim .Frame_Size(.Number_Of_Textures) As RECT
ReDim .Offset(.Number_Of_Textures) As D3DVECTOR2
ReDim .Texture_Number(.Number_Of_Frames) As Long
.Frame_Size(0).Left = 0: .Frame_Size(0).Top = 0: .Frame_Size(0).Right = 60: .Frame_Size(0).Bottom = 92
.Frame_Size(1).Left = 0: .Frame_Size(1).Top = 0: .Frame_Size(1).Right = 61: .Frame_Size(1).Bottom = 91
.Frame_Size(2).Left = 0: .Frame_Size(2).Top = 0: .Frame_Size(2).Right = 59: .Frame_Size(2).Bottom = 94
.Frame_Size(3).Left = 0: .Frame_Size(3).Top = 0: .Frame_Size(3).Right = 56: .Frame_Size(3).Bottom = 95
.Offset(0).X = 0: .Offset(0).Y = 3
.Offset(1).X = -1: .Offset(1).Y = 4
.Offset(2).X = 1: .Offset(2).Y = 1
.Offset(3).X = 2: .Offset(3).Y = 0
.Texture_Number(0) = 0
.Texture_Number(1) = 1
.Texture_Number(2) = 0
.Texture_Number(3) = 2
.Texture_Number(4) = 3
.Texture_Number(5) = 2
End With
End With
End Sub
Private Sub Animate_Sprite()
Dim X As Single, Y As Single
Dim Current_Texture As Long
Dim Transparency_Color As Long
'就在这里将alphablend多边形
Direct3D_Device.SetRenderState D3DRS_ALPHABLENDENABLE, False
'就在这里将赋予多边形透明度
Direct3D_Device.SetRenderState D3DRS_ALPHATESTENABLE, True
With Sprite
X = .X
Y = .Y
With .Animation_State
If .Number_Of_Frames <> 0 Then
Select Case .Mode
Case ANIMATION_MODE_SINGLE_SHOT
If Int(.Current_Frame) > (.Number_Of_Frames - 1) Then
.Current_Frame = (.Number_Of_Frames - 1)
End If
Case ANIMATION_MODE_LOOP
If Int(.Current_Frame) > (.Number_Of_Frames - 1) Then
.Current_Frame = 0
End If
End Select
End If
Current_Texture = .Texture_Number(Int(.Current_Frame))
Transparency_Color = D3DColorRGBA(255, 255, 255, 255)
Frame.Left = (X + .Frame_Size(Current_Texture).Left + .Offset(Current_Texture).X) * Scalar.X
Frame.Top = (Y + .Frame_Size(Current_Texture).Top + .Offset(Current_Texture).Y) * Scalar.Y
Frame.Right = (X + .Frame_Size(Current_Texture).Right + .Offset(Current_Texture).X) * Scalar.X
Frame.Bottom = (Y + .Frame_Size(Current_Texture).Bottom + .Offset(Current_Texture).Y) * Scalar.Y
'创建多边形
'---------------------------------------------------------------
With Frame
Vertex_List(0) = Create_TLVertex(.Left, .Top, 0, 1, Transparency_Color, 0, 0, 0)
Vertex_List(1) = Create_TLVertex(.Right, .Top, 0, 1, Transparency_Color, 0, 1, 0)
Vertex_List(2) = Create_TLVertex(.Left, .Bottom, 0, 1, Transparency_Color, 0, 0, 1)
Vertex_List(3) = Create_TLVertex(.Right, .Bottom, 0, 1, Transparency_Color, 0, 1, 1)
End With
'---------------------------------------------------------------
'设置纹理
Direct3D_Device.SetTexture 0, Sprite.Texture_List(Current_Texture)
.Current_Frame = .Current_Frame + .Speed
End With
End With
End Sub
Private Sub Game_Loop()
Do While Running = True
DoEvents '允许事件发生，以便程序不会锁定。
'----------------------------------------------------
'DirectX会自动为您处理帧速率
'这使其运行（最多）与监视器一样快
' 刷新率高，因此您无需在其中添加额外的代码
' 降低循环速度并以一定数量的帧运行
'每秒。
'----------------------------------------------------
'清除后缓冲。
Direct3D_Device.Clear 0, ByVal 0, D3DCLEAR_TARGET, D3DColorRGBA(0, 0, 0, 0), 1#, 0
Direct3D_Device.BeginScene
Animate_Sprite
''绘制多边形
Direct3D_Device.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, Vertex_List(0), Len(Vertex_List(0))
Direct3D_Device.EndScene
'将后缓冲区翻转到窗体窗口中。
Direct3D_Device.Present ByVal 0, ByVal 0, 0, ByVal 0
Loop
End Sub
Private Sub Close_Program()
Dim Current_Texture As Long
Running = False '这有助于程序摆脱游戏循环。
'卸载所有DirectX对象。
For Current_Texture = 0 To Sprite.Total_Number_Of_Textures - 1
Set Sprite.Texture_List(Current_Texture) = Nothing
Next Current_Texture
Set Direct3D_Device = Nothing
Set Direct3DX = Nothing
Set Direct3D = Nothing
Set DirectX8 = Nothing
Unload Me '卸载窗体
End ''结束程序
'尽管上方的Unload语句退出了程序，但是您
'这样做后将导致自动化错误?
'END 命令 将有助于防止这种情况，并彻底结束该应用程序
End Sub
Private Sub Form_Activate()
Window_Width = 392
Window_Height = 251
Fullscreen_Width = 800
Fullscreen_Height = 600
Color_Depth = COLOR_DEPTH_16_BIT
Window_Setup frmMain, -1, -1, Window_Width, Window_Height, "DirectX Tutorial", , RGB(0, 0, 0)
DirectX_Initialize '初始化DirectX和Direct3D。
Load_Textures '从文件加载纹理。
Setup_Sprite
Running = True '全部初始化。 现在可以激活游戏循环了
Game_Loop
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then '如果用户按Esc键则退出程序
Close_Program
End If
End Sub
Private Sub Form_Load()
'窗口完全加载之前将触发此事件。
If MsgBox("单击“是”进入全屏（推荐）", vbQuestion Or vbYesNo, "选项") = vbYes Then Fullscreen_Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Close_Program
End Sub
程序分析
一、初始化过程：
1、 使用了一个函数Window_Setup（此函数前文讲过）来设置窗口， 同前边一样调用子程序：DirectX_Initialize '初始化DirectX和Direct3D。
2、加载纹理图片。同前边一样调用子程序：Load_Texture '从文件加载纹理。
将4张卡通图片写入顶点缓冲区
相关定义如：
Sprite_Type：卡通类型
Private Type Sprite_Type
X As Single '卡通X坐标
Y As Single '卡通Y坐标
Animation_State As Animation_Type '卡通动画状态，类型是 Animation_Type
Texture_Path() As String '卡通图片存储的路径
Texture_List() As Direct3DTexture8 '当前卡通纹理编号
Total_Number_Of_Textures As Long '纹理总数
End Type
Animation_Type ：动画_类型
Private Type Animation_Type '动画_类型
Frame_Size() As RECT '框架_大小
Number_Of_Frames As Long '帧数
Number_Of_Textures As Long '纹理的数量
Current_Frame As Single '当前帧
Frame_Counter As Long '帧_计数器
Speed As Single '速度
Mode As Long '单发，循环等
Offset() As D3DVECTOR2 'D3DVECTOR2的成员有2个，X、Y
Texture_Number() As Long '纹理_编号
End Type
③调用Setup_Sprite子程序设置卡通，这里做了n多优化写法
二、 完成以上初始化后，进入Game_Loop子程序’游戏循环
其他跟前边分析差不多。