VB6编程：DirectX 2D图形学习日志26游戏图形引擎
教程下载地址：https://download.csdn.net/download/gosub60/13696651
作用：使用多幅BMP图合成一个基于时间的卡通动画
源码如下：需要一些图片配合。
'---------------------------------
'标题：DirectX教程
'
'描述：
'
'作者：Jacob Roman 翻译：[email protected] QQ:127644712
'
'日期：2005年12月2日
'
'联系人：[email protected]
'---------------------------------
Option Explicit
'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 Type Map_Type
Map() As String
Tile() As Long
New_Tile() As Long
Width As Long
Height As Long
New_Width As Long
New_Height As Long
Number_Of_Vertices_Per_Tile_Set() As Long
Number_Of_Polygons_Per_Tile_Set() As Long
Number_Of_Textures As Long
Texture_List() As Direct3DTexture8
Number_Of_Vertices As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (lpPerformanceCount As Currency) As Long
'一些颜色深度常数有助于使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 Const TILE_WIDTH As Single = 31.2
Private Const TILE_HEIGHT As Single = 26.4
Private Const Number_Of_Vertices_Per_Quad As Long = 6
Private Const Number_Of_Triangles_Per_Quad As Long = 2
Private DirectX8 As DirectX8 '主DirectX对象。
Private Direct3D As Direct3D8 '控制3D一切。
Private Direct3D_Device As Direct3DDevice8 '表示硬件渲染
Private Direct3DX As D3DX8
Private Fullscreen_Width As Long
Private Fullscreen_Height As Long
Private Fullscreen_Enabled As Boolean '帮助确定它是否为全屏模式。
Private Running As Boolean '帮助确定主游戏循环是否正在运行。
Private Master_Vertex_List() As TLVERTEX
Private Vertex_List() As TLVERTEX
Private Sorted_Vertex_List() As TLVERTEX
Private Vertex_Buffer As Direct3DVertexBuffer8
Private Current_Texture As Long
Private GlobalX As Single, GlobalY As Single
Private Initial_Global As D3DVECTOR2
Private Map As Map_Type
Private Scalar As D3DVECTOR2
Private Time(3) As Single
Private Milliseconds(3) As Single
Private Ticks_Per_Second As Currency
Private Start_Time As Currency
Private Direct_Input As DirectInput8
Private Keyboard_Device As DirectInputDevice8
Private Keyboard_State As DIKEYBOARDSTATE
Private Function Hi_Res_Timer_Initialize() As Boolean
If QueryPerformanceFrequency(Ticks_Per_Second) = 0 Then
Hi_Res_Timer_Initialize = False
Else
QueryPerformanceCounter Start_Time
Hi_Res_Timer_Initialize = True
End If
End Function
Private Function Get_Elapsed_Time() As Single
Dim Last_Time As Currency
Dim Current_Time As Currency
QueryPerformanceCounter Current_Time
Get_Elapsed_Time = (Current_Time - Last_Time) / Ticks_Per_Second
QueryPerformanceCounter Last_Time
End Function
'使用此功能可以更轻松地设置具有所需信息的顶点
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_32_BIT
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作为设备窗口
Scalar.X = Fullscreen_Width / frmMain.ScaleWidth
Scalar.Y = Fullscreen_Height / frmMain.ScaleHeight
Else
Direct3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Display_Mode '使用您当前使用的显示模式
'已经在。 如果您感到困惑，我是
'在谈论您当前的屏幕分辨率。 ;）
Direct3D_Window.Windowed = True '该应用程序将处于窗口模式
Scalar.X = 1
Scalar.Y = 1
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_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 "初始化DirectX时发生错误", vbCritical
Close_Program
DirectX_Initialize = False
End Function
Private Sub Setup_Map()
Dim X As Long, Y As Long
Dim Temp As Variant
Map.Width = (20) - 1
Map.Height = (16) - 1
ReDim Map.Map(Map.Height) As String
Map.Map(0) = "2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2"
Map.Map(1) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(2) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(3) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(4) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(5) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(6) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(7) = "0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0"
Map.Map(8) = "0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0"
Map.Map(9) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(10) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(11) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(12) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(13) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(14) = "0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0"
Map.Map(15) = "2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2"
ReDim Map.Tile(Map.Width, Map.Height) As Long
ReDim Map.New_Tile(Map.Width, Map.Height) As Long
For Y = 0 To Map.Height
Temp = Split(Map.Map(Y), ", ", -1)
For X = 0 To Map.Width
Map.Tile(X, Y) = CLng(Temp(X))
Next X
Next Y
End Sub
Private Sub Load_Textures()
Dim File_Path() As String
Dim Width As Long
Dim Height As Long
Dim Transparency_Color As Long
Map.Number_Of_Textures = (7) - 1
ReDim File_Path(Map.Number_Of_Textures) As String
ReDim Map.Texture_List(Map.Number_Of_Textures) As Direct3DTexture8
ReDim Map.Number_Of_Vertices_Per_Tile_Set(Map.Number_Of_Textures) As Long
ReDim Map.Number_Of_Polygons_Per_Tile_Set(Map.Number_Of_Textures) As Long
File_Path(0) = App.Path & "\Graphics\Grass.bmp"
File_Path(1) = App.Path & "\Graphics\Plant.bmp"
File_Path(2) = App.Path & "\Graphics\Sign.bmp"
File_Path(3) = App.Path & "\Graphics\Pond1.bmp"
File_Path(4) = App.Path & "\Graphics\Pond2.bmp"
File_Path(5) = App.Path & "\Graphics\Pond3.bmp"
File_Path(6) = App.Path & "\Graphics\Pond4.bmp"
Width = 256
Height = 256
Transparency_Color = D3DColorRGBA(0, 0, 0, 255)
For Current_Texture = 0 To Map.Number_Of_Textures
Set Map.Texture_List(Current_Texture) = Direct3DX.CreateTextureFromFileEx(Direct3D_Device, _
File_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 Sub
Private Sub Map_To_Vertex_List_And_Clip(Map As Map_Type, Old_Vertex_List() As TLVERTEX, New_Vertex_List() As TLVERTEX)
Dim X As Long, Y As Long
Dim X2 As Long, Y2 As Long
Dim I As Long, J As Long
Dim Temp As Long
Temp = -1
For Y = 0 To Map.Height
For X = 0 To Map.Width
Old_Vertex_List(I + 0) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + 0) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + 0) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 0, 0)
Old_Vertex_List(I + 1) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + TILE_WIDTH) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + 0) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 1, 0)
Old_Vertex_List(I + 2) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + 0) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + TILE_HEIGHT) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 0, 1)
Old_Vertex_List(I + 3) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + TILE_WIDTH) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + 0) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 1, 0)
Old_Vertex_List(I + 4) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + TILE_WIDTH) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + TILE_HEIGHT) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 1, 1)
Old_Vertex_List(I + 5) = Create_TLVertex(GlobalX + ((TILE_WIDTH * X) + 0) * Scalar.X, GlobalY + ((TILE_HEIGHT * Y) + TILE_HEIGHT) * Scalar.Y, 0, 1, D3DColorRGBA(255, 255, 255, 0), 0, 0, 1)
If Clip_Polygon(Old_Vertex_List(I + 0), Old_Vertex_List(I + 4)) = False Then
New_Vertex_List(J + 0) = Old_Vertex_List(I + 0)
New_Vertex_List(J + 1) = Old_Vertex_List(I + 1)
New_Vertex_List(J + 2) = Old_Vertex_List(I + 2)
New_Vertex_List(J + 3) = Old_Vertex_List(I + 3)
New_Vertex_List(J + 4) = Old_Vertex_List(I + 4)
New_Vertex_List(J + 5) = Old_Vertex_List(I + 5)
X2 = X2 + 1
If Temp <> Y Then
Temp = Y
X2 = 1
Y2 = Y2 + 1
End If
Map.New_Tile(X2 - 1, Y2 - 1) = Map.Tile(X, Y)
J = J + Number_Of_Vertices_Per_Quad
End If
I = I + Number_Of_Vertices_Per_Quad
Next X
Next Y
Map.New_Width = X2
Map.New_Height = Y2
End Sub
Private Sub Sort_Polygons_By_Texture(Map As Map_Type, Old_Vertex_List() As TLVERTEX, New_Vertex_List() As TLVERTEX)
Dim X As Long, Y As Long
Dim I As Long, J As Long, K As Long
For Current_Texture = 0 To Map.Number_Of_Textures
I = 0
For Y = 0 To Map.New_Height - 1
For X = 0 To Map.New_Width - 1
If Map.New_Tile(X, Y) = Current_Texture Then
New_Vertex_List(J + 0) = Old_Vertex_List(I + 0)
New_Vertex_List(J + 1) = Old_Vertex_List(I + 1)
New_Vertex_List(J + 2) = Old_Vertex_List(I + 2)
New_Vertex_List(J + 3) = Old_Vertex_List(I + 3)
New_Vertex_List(J + 4) = Old_Vertex_List(I + 4)
New_Vertex_List(J + 5) = Old_Vertex_List(I + 5)
'对所有顶点求和，请勿重置此变量。
J = J + Number_Of_Vertices_Per_Quad
'每个纹理的顶点总数。
K = K + Number_Of_Vertices_Per_Quad
End If
I = I + Number_Of_Vertices_Per_Quad
Next X
Next Y
Map.Number_Of_Polygons_Per_Tile_Set(Current_Texture) = K / 3
Map.Number_Of_Vertices_Per_Tile_Set(Current_Texture) = K
K = 0 '重置此纹理，另一个纹理即将到来
Next Current_Texture
End Sub
Private Function Clip_Polygon(Polygon_A As TLVERTEX, Polygon_B As TLVERTEX) As Boolean
Dim R As RECT
Dim Border_Size As Long
Border_Size = 0
If Fullscreen_Enabled = False Then
R.Left = Border_Size * Scalar.X
R.Top = Border_Size * Scalar.Y
R.Right = Me.ScaleWidth - Border_Size * Scalar.X
R.bottom = Me.ScaleHeight - Border_Size * Scalar.Y
Else
R.Left = Border_Size * Scalar.X
R.Top = Border_Size * Scalar.Y
R.Right = Fullscreen_Width - Border_Size * Scalar.X
R.bottom = Fullscreen_Height - Border_Size * Scalar.Y
End If
If (Polygon_A.X < R.Left And Polygon_B.X < R.Left) Or (Polygon_A.X > R.Right And Polygon_B.X > R.Right) Or _
(Polygon_A.Y < R.Top And Polygon_B.Y < R.Top) Or (Polygon_A.Y > R.bottom And Polygon_B.Y > R.bottom) Then Clip_Polygon = True
End Function
Private Sub Create_Polygons()
Map.Number_Of_Vertices = ((Map.Width + 1) * (Map.Height + 1) * Number_Of_Vertices_Per_Quad)
ReDim Master_Vertex_List(Map.Number_Of_Vertices - 1) As TLVERTEX
ReDim Vertex_List(Map.Number_Of_Vertices - 1) As TLVERTEX
ReDim Sorted_Vertex_List(Map.Number_Of_Vertices - 1) As TLVERTEX
Map_To_Vertex_List_And_Clip Map, Master_Vertex_List(), Vertex_List()
Sort_Polygons_By_Texture Map, Vertex_List(), Sorted_Vertex_List()
'创建顶点缓冲区。
Set Vertex_Buffer = Direct3D_Device.CreateVertexBuffer(Len(Sorted_Vertex_List(0)) * Map.Number_Of_Vertices, 0, FVF_TLVERTEX, D3DPOOL_MANAGED)
D3DVertexBuffer8SetData Vertex_Buffer, 0, Len(Sorted_Vertex_List(0)) * Map.Number_Of_Vertices, 0, Sorted_Vertex_List(0)
Direct3D_Device.SetStreamSource 0, Vertex_Buffer, Len(Sorted_Vertex_List(0))
End Sub
Private Sub DirectInput_Initialize_Keyboard(Window As Form)
Set Direct_Input = DirectX8.DirectInputCreate
Set Keyboard_Device = Direct_Input.CreateDevice("GUID_SysKeyboard")
Keyboard_Device.SetCommonDataFormat DIFORMAT_KEYBOARD
Keyboard_Device.SetCooperativeLevel Window.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
Keyboard_Device.Acquire
Keyboard_Device.GetDeviceStateKeyboard Keyboard_State
End Sub
Private Function DirectInput_Key_State(Key_Code As Long) As Long
Keyboard_Device.GetDeviceStateKeyboard Keyboard_State
DirectInput_Key_State = Keyboard_State.Key(Key_Code)
End Function
Private Sub Control()
Const Speed As Single = 75
Dim Elapsed_Time As Single
Elapsed_Time = Get_Elapsed_Time
If DirectInput_Key_State(DIK_ESCAPE) <> 0 Then Close_Program
'---------------------------------------------
'左右
'---------------------------------------------
If DirectInput_Key_State(DIK_LEFT) <> 0 And DirectInput_Key_State(DIK_RIGHT) = 0 Then
GlobalX = Initial_Global.X + Speed * Time(0) * Scalar.X
ElseIf DirectInput_Key_State(DIK_LEFT) = 0 And DirectInput_Key_State(DIK_RIGHT) <> 0 Then
GlobalX = Initial_Global.X - Speed * Time(1) * Scalar.X
ElseIf (DirectInput_Key_State(DIK_LEFT) <> 0 And DirectInput_Key_State(DIK_RIGHT) <> 0) Or _
(DirectInput_Key_State(DIK_LEFT) = 0 And DirectInput_Key_State(DIK_RIGHT) = 0) Then
Milliseconds(0) = Elapsed_Time
Milliseconds(1) = Elapsed_Time
Initial_Global.X = GlobalX
End If
'---------------------------------------------
'---------------------------------------------
'上/下
'---------------------------------------------
If DirectInput_Key_State(DIK_UP) <> 0 And DirectInput_Key_State(DIK_DOWN) = 0 Then
GlobalY = Initial_Global.Y + Speed * Time(2) * Scalar.Y
ElseIf DirectInput_Key_State(DIK_UP) = 0 And DirectInput_Key_State(DIK_DOWN) <> 0 Then
GlobalY = Initial_Global.Y - Speed * Time(3) * Scalar.Y
ElseIf (DirectInput_Key_State(DIK_UP) <> 0 And DirectInput_Key_State(DIK_DOWN) <> 0) Or _
(DirectInput_Key_State(DIK_UP) = 0 And DirectInput_Key_State(DIK_DOWN) = 0) Then
Milliseconds(2) = Elapsed_Time
Milliseconds(3) = Elapsed_Time
Initial_Global.Y = GlobalY
End If
'---------------------------------------------
End Sub
Private Sub Collision_Detection()
Dim R As RECT
R.Left = (-(Map.Width * TILE_WIDTH / 2) - TILE_WIDTH / 2) * Scalar.X
R.Top = (-(Map.Height * TILE_HEIGHT / 2) - TILE_HEIGHT / 2) * Scalar.Y
R.Right = 0
R.bottom = 0
If GlobalX <= R.Left Then GlobalX = R.Left
If GlobalY <= R.Top Then GlobalY = R.Top
If GlobalX >= R.Right Then GlobalX = R.Right
If GlobalY >= R.bottom Then GlobalY = R.bottom
End Sub
Private Sub Game_Loop()
Dim Number_Of_Polygons As Long
Dim Total_Number_Of_Vertices As Long
Dim I As Long
Number_Of_Polygons = (Map.Width + 1) * (Map.Height + 1) * Number_Of_Triangles_Per_Quad
Do While Running = True
DoEvents '允许事件发生，以便程序不会锁定。
'------------------------------------------------- ---
'DirectX会自动为您处理帧速率
'这使其运行（最多）与监视器一样快
'刷新率高，因此您无需在其中添加额外的代码
'降低循环速度并以一定数量的帧运行
'每秒。
'------------------------------------------------- ---
For I = 0 To 3
Time(I) = Get_Elapsed_Time - Milliseconds(I)
Next I
Control
Collision_Detection
Create_Polygons
'清除后缓冲区。
Direct3D_Device.Clear 0, ByVal 0, D3DCLEAR_TARGET, D3DColorRGBA(0, 0, 0, 0), 1#, 0
Direct3D_Device.BeginScene
'Direct3D_Device.SetRenderState D3DRS_FILLMODE, 2
Direct3D_Device.SetRenderState D3DRS_ALPHATESTENABLE, False
Total_Number_Of_Vertices = 0
For Current_Texture = 0 To Map.Number_Of_Textures
Direct3D_Device.SetTexture 0, Map.Texture_List(Current_Texture)
Direct3D_Device.DrawPrimitive D3DPT_TRIANGLELIST, Total_Number_Of_Vertices, Map.Number_Of_Polygons_Per_Tile_Set(Current_Texture)
Total_Number_Of_Vertices = Total_Number_Of_Vertices + Map.Number_Of_Vertices_Per_Tile_Set(Current_Texture)
Next Current_Texture
Direct3D_Device.EndScene
'将后缓冲区翻转到窗体窗口中。
Direct3D_Device.Present ByVal 0, ByVal 0, 0, ByVal 0
QueryPerformanceCounter Start_Time
Loop
End Sub
Private Sub Close_Program()
Running = False ''这有助于程序摆脱游戏循环。
'卸载所有DirectX对象。
For Current_Texture = 0 To Map.Number_Of_Textures
Set Map.Texture_List(Current_Texture) = Nothing
Next Current_Texture
Set Direct3DX = Nothing
Set Direct3D_Device = Nothing
Set Direct3D = Nothing
Set DirectX8 = Nothing
Unload Me '卸载窗体
End ''结束程序
'尽管上方的Unload语句退出了程序，但是您
'这样做后将导致自动化错误?
'END 命令 将有助于防止这种情况，并彻底结束该应用程序
End Sub
Private Sub Form_Activate()
Dim I As Long
Fullscreen_Width = 800
Fullscreen_Height = 600
With frmMain
.Caption = "DirectX教程19:2d游戏图形引擎"
.ScaleMode = 3
.Width = (640 / 2) * Screen.TwipsPerPixelX
.Height = (480 / 2) * Screen.TwipsPerPixelY
End With
DirectX_Initialize '初始化DirectX和Direct3D
Setup_Map
Load_Textures '从文件加载纹理
Create_Polygons '创建多边形。
DirectInput_Initialize_Keyboard frmMain
Hi_Res_Timer_Initialize
For I = 0 To 3
Milliseconds(I) = Get_Elapsed_Time
Next I
Running = True '全部初始化。 现在可以激活游戏循环了
Game_Loop
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
Private Function Split(ByVal sIn As String, Optional sDelim As String, Optional nLimit As Long = -1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As Variant
'对于那些拥有VB5的人
Dim sRead As String, sOut() As String, nC As Integer
If sDelim = "" Then
Split = sIn
End If
sRead = ReadUntil(sIn, sDelim, bCompare)
Do
ReDim Preserve sOut(nC)
sOut(nC) = sRead
nC = nC + 1
If nLimit <> -1 And nC >= nLimit Then Exit Do
sRead = ReadUntil(sIn, sDelim)
Loop While sRead <> ""
ReDim Preserve sOut(nC)
sOut(nC) = sIn
Split = sOut
End Function
Private Function ReadUntil(ByRef sIn As String, sDelim As String, Optional bCompare As VbCompareMethod = vbBinaryCompare) As String
'对于那些拥有VB5的人
Dim nPos As String
nPos = InStr(1, sIn, sDelim, bCompare)
If nPos > 0 Then
ReadUntil = Left(sIn, nPos - 1)
sIn = Mid(sIn, nPos + Len(sDelim))
End If
End Function