魔塔之拯救白娘子 完整工程下载地址：
前边学习了DX8的相关知识后，想做一个游戏试试看。这里我选取了魔塔这个比较大众化的小游戏。主要是魔塔的游戏画面比较固定，也很简单，似乎很容易做。下边就开始做吧。
一：游戏引擎
做游戏，最好的就是开发一个自己的游戏引擎，但是现在要做的仅仅是一个小游戏，没必要自己去大动干戈的去整游戏引擎，并且要做商业性的游戏，市面有大量现成的商业引擎，没必要自己耗费心力去搞游戏引擎。特别是，一个完整的商业化的游戏，至少有个团队来创作，要程序员、美工、策划等通力合作。所以，我作为一个VB6编程的初学者，主要还是用来学习以下编程思想，编程技巧，编程步骤，不去搞那些比较耗神的东西，能够完成自己的学习目的就可以了，所以，我在网上选了一个VB6可以使用的游戏引擎，方便使用即可。
xGraphPool.cls :这个是DX调用声明等，代码如下：
'impactX Game Engine
'本类模块用于存储图像的各种数据和图像的操作,必须与xGraph配合使用
'使用本类模块必须遵守:
'你可以免费使用本引擎及代码
'使用本引擎后的责任由使用者承担
'你可以任意拷贝本引擎代码，但必须保证其完整性
'希望我能得到你使用本引擎制作出的程序
'Davy.xu [email protected] qq:20998333
Option Explicit
Private Type impactGraph
Texture As Direct3DTexture8
Width As Integer
Height As Integer
SourceRect As RECT '图像显示范围
Translation As D3DVECTOR2 '图像显示坐标
Scale As D3DVECTOR2 '缩放
Center As D3DVECTOR2 '图像中心
Rotation As Single '旋转角度
Color As Long '颜色(半透明,滤色镜)
Hnum As Integer '水平分割数(精灵动画)
Vnum As Integer '垂直分割数
CellIndex As Single '显示精灵分块索引号
MirrorType As ENUM_XG_MIRROR
D3DDevice As Direct3DDevice8
D3Dobj As D3DX8
FrmSpd As Long
End Type
Private Type ImageSize
Width As Long
Height As Long '圖形的高度
End Type
Enum ENUM_XG_MIRROR
xgNONE = 0
xgH_MIRROR = 1
xgV_MIRROR = 2
End Enum
Dim Sprite As D3DXSprite
Dim gfx As impactGraph '图形的各种信息
Dim MirrorMatrix As D3DMATRIX
Dim pxArr() As Byte
Dim isMirrorOpen As Boolean
'功能: 载入图片
'参数:图片索引号,路径(不带盘符时默认为工作目录),透明色
Public Function LoadGraph(ByVal Pathname As String, ByVal ColorKey As ENUM_XG_COLOR, Optional Hnum As Integer = 1, Optional Vnum As Integer = 1) As Boolean
'On Error GoTo ErrH
If Len(Pathname) = 0 Then
' Debug.Print "Err: [LoadGraph] 路径不能为空"
' End
GoTo ErrH
Else
'将默认文件名变为工作目录
If Mid(Pathname, 2, 1) <> ":" Then Pathname = App.Path & "\" & Pathname
If Len(Dir(Pathname)) = 0 Then
' Debug.Print "Err: [LoadGraph] 文件不存在"
' Debug.Print " Pathname:" & Pathname
' End
MsgBox "加载图形资源错误: [LoadGraph] 文件不存在! " & vbCrLf & "出错文件名: " & Pathname
GoTo ErrH
End If
End If
Pathname = Trim(Pathname) '去空格
Dim GfxInfo As D3DXIMAGE_INFO
With gfx
Set .Texture = gfx.D3Dobj.CreateTextureFromFileEx( _
.D3DDevice, _
Pathname, _
D3DX_DEFAULT, _
D3DX_DEFAULT, _
1, _
0, D3DFMT_UNKNOWN, _
D3DPOOL_MANAGED, _
D3DX_FILTER_NONE, _
D3DX_FILTER_NONE, _
ColorKey, ByVal 0, ByVal 0)
'获取宽度和长度
Dim Ld As ImageSize
Ld = GetImageSize(Pathname)
.SourceRect.Right = Ld.Width
.SourceRect.Bottom = Ld.Height
.Translation.x = 0
.Translation.y = 0
.Scale.x = 1
.Scale.y = 1
.Center.x = Int(Ld.Width / 2)
.Center.y = Int(Ld.Height / 2)
.Rotation = 0
.Color = &HFFFFFFFF
.Hnum = Hnum
.Vnum = Vnum
.Width = Ld.Width
.Height = Ld.Height
.MirrorType = xgNONE
.FrmSpd = 100
.CellIndex = 0
' If .Hnum > 1 Or .Vnum > 1 Then
' .CellIndex = 1
' Else
' .CellIndex = 0
' End If
End With
Exit Function
ErrH:
Debug.Print "Err [LoadGraph] 载入图片错误"
' MsgBox "Err [LoadGraph] 载入图片错误!"
End Function
'绘图
Public Sub DrawGraph(ByVal x As Integer, ByVal y As Integer)
Dim ReturnValue As Long
On Error GoTo ErrH:
If gfx.D3DDevice Is Nothing Then End
If gfx.D3DDevice.TestCooperativeLevel = D3DERR_DEVICELOST Then Exit Sub
Sprite.Begin
With gfx
.Translation.x = CSng(x) + (1 - .Scale.x) * gfx.Width / .Hnum / 2 '使缩放中心不变
.Translation.y = CSng(y) + (1 - .Scale.y) * gfx.Height / .Vnum / 2
If Not isMirrorOpen Then
' If MsgBox("draw", vbYesNo) = vbNo Then End
Sprite.Draw .Texture, .SourceRect, .Scale, .Center, .Rotation, .Translation, .Color
Else
Dim matMirror As D3DMATRIX '做镜像用矩阵
Dim matTrans As D3DMATRIX '做平移矩阵
Dim matRotate As D3DMATRIX '做旋转矩阵
Dim matCenter As D3DMATRIX '将图形平移到原点
Dim matScale As D3DMATRIX
D3DXMatrixIdentity matMirror '单位矩阵
D3DXMatrixRotationZ matRotate, gfx.Rotation '旋转矩阵
D3DXMatrixScaling matScale, gfx.Scale.x, gfx.Scale.y, 1
Select Case gfx.MirrorType
Case xgNONE
isMirrorOpen = False
D3DXMatrixIdentity MirrorMatrix
Case xgH_MIRROR
If .CellIndex <> 0 Then '精灵图情况
D3DXMatrixTranslation matCenter, 0.5 * .Width \ .Hnum, -0.5 * .Height \ .Vnum, 0
D3DXMatrixTranslation matTrans, x + 0.5 * .Width \ .Hnum, y + 0.5 * .Height \ .Vnum, 0
Else '正常图情况
D3DXMatrixTranslation matCenter, gfx.Width \ 2, -gfx.Height \ 2, 0
D3DXMatrixTranslation matTrans, x + gfx.Width \ 2, y + gfx.Height \ 2, 0
End If
matMirror.m11 = -1
isMirrorOpen = True
Case xgV_MIRROR
If .CellIndex <> 0 Then '精灵图情况
D3DXMatrixTranslation matCenter, -0.5 * gfx.Width \ .Hnum, 0.5 * gfx.Height \ .Vnum, 0
D3DXMatrixTranslation matTrans, x + 0.5 * .Width \ .Hnum, y + 0.5 * .Height \ .Vnum, 0
Else '正常图情况
D3DXMatrixTranslation matCenter, -gfx.Width \ 2, gfx.Height \ 2, 0
D3DXMatrixTranslation matTrans, x + gfx.Width \ 2, y + gfx.Height \ 2, 0
End If
matMirror.m22 = -1
isMirrorOpen = True
End Select
D3DXMatrixMultiply MirrorMatrix, matMirror, matCenter '输出一个已经平移到屏幕左上角镜像了的图像
D3DXMatrixMultiply MirrorMatrix, MirrorMatrix, matScale '移回到原始坐标
D3DXMatrixMultiply MirrorMatrix, MirrorMatrix, matRotate '在左上角旋转
D3DXMatrixMultiply MirrorMatrix, MirrorMatrix, matTrans '移回到原始坐标
If MsgBox("draw2", vbYesNo) = vbNo Then End
Sprite.DrawTransform .Texture, .SourceRect, MirrorMatrix, .Color '绘制图形
End If
End With
Sprite.End
Exit Sub
ErrH:
If gfx.Hnum = 1 And gfx.Vnum = 1 And gfx.CellIndex > 0 Then
MsgBox "整图操作时禁止更改Cell值，这样是无意义的", vbCritical
End
Else
Select Case Err.Number
Case -2005530516
MsgBox "[DrawGraph]错误的输入参数", vbCritical
Debug.Print "[DrawGraph]错误的输入参数"
Debug.Print "[DrawGraph]Cell= " & gfx.CellIndex
Case 6 '溢出
If gfx.Texture Is Nothing Then
MsgBox "[DrawGraph]没有可以显示的已载入图片", vbCritical
ElseIf gfx.Hnum = 0 Or gfx.Vnum = 0 Then
MsgBox "[DrawGraph]载入图片时切分参数错误", vbCritical
Else
MsgBox "[DrawGraph]参数错误,请检查输入参数"
End If
Case Else
MsgBox "绘图时错误!" & vbCr & "DX err:" & Err.Number, vbCritical
End Select
End
End If
End Sub
'设置图像缩放比例
Public Sub SetScale(ByVal XScale As Single, ByVal YScale As Single)
With gfx
.Scale.x = XScale
.Scale.y = YScale
If .CellIndex = 0 Then
.Center.x = XScale * gfx.SourceRect.Right / 2
.Center.y = YScale * gfx.SourceRect.Bottom / 2
Else
.Center.x = .Width / .Hnum / 2 * XScale
.Center.y = .Height / .Vnum / 2 * YScale
End If
End With
End Sub
Public Sub SetRotate(ByVal Angle As Single)
'设置图像旋转角度
gfx.Rotation = Angle / 180 * 3.14
End Sub
'设置图像显示蒙板颜色
Public Sub SetColor(ByVal Color As ENUM_XG_COLOR)
gfx.Color = Color
End Sub
'设置图像透明度
Public Sub SetAlpha(ByVal Degree As Integer)
gfx.Color = D3DColorARGB(Degree, 255, 255, 255)
End Sub
'设置原图显示范围
Public Sub SetDisplayRect(ByVal Left As Single, ByVal Top As Single, ByVal Right As Single, ByVal Bottom As Single)
With gfx.SourceRect
.Left = Left
.Top = Top
.Right = Right
.Bottom = Bottom
End With
End Sub
'设置图形的镜像方式
Public Sub SetMirror(MirrorType As ENUM_XG_MIRROR)
If MirrorType = xgH_MIRROR Or MirrorType = xgV_MIRROR Then
isMirrorOpen = True
Else
isMirrorOpen = False
End If
gfx.MirrorType = MirrorType
End Sub
'获得图像宽度
Public Function Width() As Integer
If gfx.CellIndex = 0 Then
Width = gfx.Width
Else
Width = gfx.Width \ gfx.Hnum
End If
End Function
'获得图像高度
Public Function Height() As Integer
If gfx.CellIndex = 0 Then
Height = gfx.Height
Else
Height = gfx.Height \ gfx.Vnum
End If
End Function
'将D3D对象和设备载入到类中
Private Sub Class_Initialize()
If D3DDevice Is Nothing Or D3DX Is Nothing Then
Debug.Print "载入图片时没有初始化D3D设备和对象"
Exit Sub
End If
Set gfx.D3DDevice = D3DDevice
Set gfx.D3Dobj = D3DX
Set Sprite = gfx.D3Dobj.CreateSprite(gfx.D3DDevice)
isMirrorOpen = False
End Sub
Public Property Get Cell() As Single
Cell = Int(gfx.CellIndex)
End Property
Public Property Let Cell(ByVal Index As Single)
On Error GoTo ErrH
Dim eW As Integer
Dim eH As Integer
Static lstIndex As Long
If lstIndex = Int(Index) Then Exit Property
lstIndex = Int(Index)
If lstIndex < 0 Or lstIndex > gfx.Hnum * gfx.Vnum Then
'Debug.Print "[Cell]图片分割错误"
End If
With gfx
eW = .Width \ .Hnum '单张图片的尺寸
eH = .Height \ .Vnum
If lstIndex = 0 Then '正常图
.CellIndex = 0
.SourceRect.Left = 0
.SourceRect.Top = 0
.SourceRect.Right = .Width
.SourceRect.Bottom = .Height
.Center.x = Int(.Width / 2)
.Center.y = Int(.Height / 2)
Else '精灵图
.CellIndex = lstIndex
.SourceRect.Left = eW * ((.CellIndex - 1) Mod .Hnum)
.SourceRect.Top = eH * Int((.CellIndex - 1) / .Hnum)
.SourceRect.Right = .SourceRect.Left + eW
.SourceRect.Bottom = .SourceRect.Top + eH
.Center.x = eW / 2
.Center.y = eH / 2
End If
End With
Exit Property
ErrH:
Debug.Print "[Cell] 图片切换分块错误，请确认读取时的切分正确"
End
End Property
'读入文件的比例
Private Function GetImageSize(sFileName As String) As ImageSize
On Error Resume Next
Dim iFN As Integer
Dim bTemp(3) As Byte
Dim lFlen As Long
Dim lPos As Long
Dim bHmsb As Byte
Dim bHlsb As Byte
Dim bWmsb As Byte
Dim bWlsb As Byte
Dim bBuf(7) As Byte
Dim bDone As Byte
Dim iCount As Integer
lFlen = FileLen(sFileName)
iFN = FreeFile
Open sFileName For Binary As iFN
Get #iFN, 1, bTemp()
'PNG 文件
If bTemp(0) = &H89 And bTemp(1) = &H50 And bTemp(2) = &H4E _
And bTemp(3) = &H47 Then
Get #iFN, 19, bWmsb
Get #iFN, 20, bWlsb
Get #iFN, 23, bHmsb
Get #iFN, 24, bHlsb
GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
End If
'GIF 文件
If bTemp(0) = &H47 And bTemp(1) = &H49 And bTemp(2) = &H46 _
And bTemp(3) = &H38 Then
Get #iFN, 7, bWlsb
Get #iFN, 8, bWmsb
Get #iFN, 9, bHlsb
Get #iFN, 10, bHmsb
GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
End If
'JPEG 文件
If bTemp(0) = &HFF And bTemp(1) = &HD8 And bTemp(2) = &HFF Then
lPos = 3
Do
Do
Get #iFN, lPos, bBuf(1)
Get #iFN, lPos + 1, bBuf(2)
lPos = lPos + 1
Loop Until (bBuf(1) = &HFF And bBuf(2) <> &HFF) Or lPos > lFlen
For iCount = 0 To 7
Get #iFN, lPos + iCount, bBuf(iCount)
Next iCount
If bBuf(0) >= &HC0 And bBuf(0) <= &HC3 Then
bHmsb = bBuf(4)
bHlsb = bBuf(5)
bWmsb = bBuf(6)
bWlsb = bBuf(7)
bDone = 1
Else
lPos = lPos + (CombineBytes(bBuf(2), bBuf(1))) + 1
End If
Loop While lPos < lFlen And bDone = 0
GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
End If
'BMP 文件
If bTemp(0) = &H42 And bTemp(1) = &H4D Then
Get #iFN, 19, bWlsb
Get #iFN, 20, bWmsb
Get #iFN, 23, bHlsb
Get #iFN, 24, bHmsb
GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
End If
'TGA 文件
If bTemp(2) = &H2 And LCase(Right(sFileName, 4)) = ".tga" Then
Get #iFN, 13, bWlsb
Get #iFN, 14, bWmsb
Get #iFN, 15, bHlsb
Get #iFN, 16, bHmsb
GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
End If
Close iFN
End Function
'getImageSize要用到的把十六进制数换成十进制
Public Function CombineBytes(lsb As Byte, msb As Byte) As Long
CombineBytes = CLng(lsb + CLng(msb * 256))
End Function
'释放内存
Public Sub Release()
With gfx
Set .Texture = Nothing
Set .D3DDevice = Nothing
Set .D3Dobj = Nothing
Set Sprite = Nothing
End With
End Sub
'重新连接设备
Public Sub ReConnect()
Set gfx.D3DDevice = D3DDevice
Set gfx.D3Dobj = D3DX
Set Sprite = gfx.D3Dobj.CreateSprite(gfx.D3DDevice)
End Sub
Public Property Get MaxFrame() As Integer
MaxFrame = gfx.Hnum * gfx.Vnum
End Property
Public Property Get FrameSpeed() As Long
FrameSpeed = gfx.FrmSpd
End Property
Public Property Let FrameSpeed(ByVal FrmSpd As Long)
gfx.FrmSpd = FrmSpd
End Property
Public Sub GetColor(Alpha As Integer, Red As Integer, Green As Integer, Blue As Integer)
Dim strColor As String
strColor = Hex(gfx.Color)
If Len(strColor) = 7 Then strColor = "0" & strColor
Alpha = Hex2Dec(Left(strColor, 1)) * 16 + Hex2Dec(Mid(strColor, 2, 1))
Red = Hex2Dec(Mid(strColor, 3, 1)) * 16 + Hex2Dec(Mid(strColor, 4, 1))
Green = Hex2Dec(Mid(strColor, 5, 1)) * 16 + Hex2Dec(Mid(strColor, 6, 1))
Blue = Hex2Dec(Mid(strColor, 7, 1)) * 16 + Hex2Dec(Mid(strColor, 8, 1))
End Sub
'将16进制字符转换为10进制数
Private Function Hex2Dec(HexStr As String) As Integer
HexStr = LCase(HexStr)
Select Case HexStr
Case "a"
Hex2Dec = 10
Case "b"
Hex2Dec = 11
Case "c"
Hex2Dec = 12
Case "d"
Hex2Dec = 13
Case "e"
Hex2Dec = 14
Case "f"
Hex2Dec = 15
Case Else
Hex2Dec = Val(HexStr)
End Select
End Function
Public Function GetRotate() As Single '旋转
GetRotate = gfx.Rotation
End Function
Public Sub GetScale(XScale As Single, YScale As Single) '获得坐标
XScale = gfx.Scale.x
YScale = gfx.Scale.y
End Sub
Public Function GetMirror() As ENUM_XG_MIRROR '获取镜像
GetMirror = gfx.MirrorType
End Function
Public Function GetAlpha() As Integer '获取Alpha
Dim strColor As String
strColor = Hex(gfx.Color)
If Len(strColor) = 7 Then strColor = "0" & strColor
GetAlpha = Hex2Dec(Left(strColor, 1)) * 16 + Hex2Dec(Mid(strColor, 2, 1))
End Function
'从资源文件里读取图片
Public Function LoadGraphFromRes(ByVal ResPathName As String, ByVal FileName As String, ByVal ColorKey As ENUM_XG_COLOR, Optional Hnum As Integer = 1, Optional Vnum As Integer = 1) As Boolean
On Error GoTo ErrH
Dim Buf() As Byte
Dim GfxInfo As D3DXIMAGE_INFO
If Len(ResPathName) = 0 Then
Debug.Print "Err: [LoadGraphFromRes] 路径不能为空"
End
Else
'将默认文件名变为工作目录
If Mid(ResPathName, 2, 1) <> ":" Then ResPathName = App.Path & "\" & ResPathName
If Len(Dir(ResPathName)) = 0 Then
Debug.Print "Err: [LoadGraphFromRes] 文件不存在"
Debug.Print " ResPathname:" & ResPathName
End
End If
End If
ResPathName = Trim(ResPathName) '去空格
LoadGrf2Mem ResPathName, FileName, Buf()
With gfx
Set .Texture = gfx.D3Dobj.CreateTextureFromFileInMemoryEx( _
.D3DDevice, _
Buf(0), _
UBound(Buf()), _
D3DX_DEFAULT, _
D3DX_DEFAULT, _
1, _
0, D3DFMT_UNKNOWN, _
D3DPOOL_MANAGED, _
D3DX_FILTER_NONE, _
D3DX_FILTER_NONE, _
ColorKey, ByVal 0, ByVal 0)
Dim Ld As ImageSize
Ld = GetImageSizeInMem(Buf())
'获取宽度和长度
.SourceRect.Right = Ld.Width
.SourceRect.Bottom = Ld.Height
.Translation.x = 0
.Translation.y = 0
.Scale.x = 1
.Scale.y = 1
.Center.x = Int(Ld.Width / 2)
.Center.y = Int(Ld.Height / 2)
.Rotation = 0
.Color = &HFFFFFFFF
.Hnum = Hnum
.Vnum = Vnum
.Width = Ld.Width
.Height = Ld.Height
.MirrorType = xgNONE
.FrmSpd = 100
If .Hnum > 1 Or .Vnum > 1 Then
.CellIndex = 1
Else
.CellIndex = 0
End If
End With
Exit Function
ErrH:
Debug.Print "Err [LoadGraph] 载入图片错误"
End Function
'读取资源列表(和GetResFileInfo配合使用).返回文件头的长度
Private Sub LoadGrf2Mem(ByVal ResFilePath As String, ByVal FileName As String, FileBuf() As Byte)
Dim FileTag(2) As Byte
Dim tag As Byte
Dim TotalFileNum As Integer
Dim tFileName As String
Dim tFileSize As Long
Dim tFileOffset As Long
Dim ResBeginOffset As Long
Dim ConvArr(1) As Byte
Dim i As Integer
Dim ResFileVer As Byte
Dim ObjOffset As Long
Dim ObjSize As Long
tFileOffset = -1
Open ResFilePath For Binary As 1
'grf文件头确认
Get 1, , FileTag(0)
Get 1, , FileTag(1)
Get 1, , FileTag(2)
If Chr(FileTag(0)) <> "G" Or Chr(FileTag(1)) <> "R" Or Chr(FileTag(2)) <> "F" Then
Debug.Print "This is not grf File"
Close 1
Exit Sub
End If
Get 1, , ResFileVer '版本号
Get 1, , TotalFileNum '文件数
For i = 1 To TotalFileNum
Do
DoEvents
Get 1, , tag '文件名称
If tag <> &HFF Then '若还没读完本文件记录
'连接中文字符
If Asc(Chr(tag)) = 0 Then '若是中文第一字符
ConvArr(0) = tag
Get 1, , tag
ConvArr(1) = tag
tFileName = tFileName & StrConv(ConvArr, vbUnicode)
Else
tFileName = tFileName & Chr(tag)
End If
Else
Exit Do
End If
Loop
Get 1, , tag
Get 1, , tFileSize '文件大小
Get 1, , tFileOffset '文件偏移
If UCase(FileName) = UCase(tFileName) Then
ObjOffset = tFileOffset
ObjSize = tFileSize
Else
tFileName = ""
End If
Next i
If tFileOffset = -1 Then
MsgBox "File not in Res"
End
End If
Get 1, , tag 'FF标志
If tag <> &HFF Then MsgBox "File Broke": End
'寻址到指定文件位置
Seek 1, Seek(1) + ObjOffset + 1
ReDim FileBuf(ObjSize) As Byte
'解开文件
Get 1, , FileBuf()
FileHeadMist FileBuf()
' Open App.Path & "\1" & Filename For Binary As 2
' Put 2, , FileBuf()
' Close 2
Close 1
End Sub
'每个文件内部头几百个字节的加密
Public Sub FileHeadMist(objBuf() As Byte)
Dim i As Long
Dim ThisMistLen As Long
Const HeadMistLength As Integer = 250
If UBound(objBuf()) < HeadMistLength Then
ThisMistLen = UBound(objBuf())
Else
ThisMistLen = HeadMistLength
End If
For i = 0 To ThisMistLen
objBuf(i) = objBuf(i) Xor 82
objBuf(i) = objBuf(i) Xor 2
objBuf(i) = objBuf(i) Xor 251
Next i
End Sub
'从内存中的图片读取图片大小
Private Function GetImageSizeInMem(bTemp() As Byte) As ImageSize
On Error Resume Next
Dim iFN As Integer
Dim lFlen As Long
Dim lPos As Long
Dim bHmsb As Byte
Dim bHlsb As Byte
Dim bWmsb As Byte
Dim bWlsb As Byte
Dim bBuf(7) As Byte
Dim bDone As Byte
Dim iCount As Integer
'PNG 文件
If bTemp(0) = &H89 And bTemp(1) = &H50 And bTemp(2) = &H4E _
And bTemp(3) = &H47 Then
bWmsb = bTemp(18)
bWlsb = bTemp(19)
bHmsb = bTemp(22)
bHlsb = bTemp(23)
GetImageSizeInMem.Width = CombineBytes(bWlsb, bWmsb)
GetImageSizeInMem.Height = CombineBytes(bHlsb, bHmsb)
End If
'GIF 文件
If bTemp(0) = &H47 And bTemp(1) = &H49 And bTemp(2) = &H46 _
And bTemp(3) = &H38 Then
bWlsb = bTemp(7)
bWmsb = bTemp(8)
bHlsb = bTemp(9)
bHmsb = bTemp(10)
GetImageSizeInMem.Width = CombineBytes(bWlsb, bWmsb)
GetImageSizeInMem.Height = CombineBytes(bHlsb, bHmsb)
End If
'JPEG 文件
If bTemp(0) = &HFF And bTemp(1) = &HD8 And bTemp(2) = &HFF Then
lPos = 3
Do
Do
bBuf(1) = bTemp(lPos)
bBuf(2) = bTemp(lPos + 1)
lPos = lPos + 1
Loop Until (bBuf(1) = &HFF And bBuf(2) <> &HFF) Or lPos > UBound(bTemp())
For iCount = 0 To 7
bBuf(iCount) = bTemp(lPos + iCount)
Next iCount
If bBuf(0) >= &HC0 And bBuf(0) <= &HC3 Then
bHmsb = bBuf(4)
bHlsb = bBuf(5)
bWmsb = bBuf(6)
bWlsb = bBuf(7)
bDone = 1
Else
lPos = lPos + (CombineBytes(bBuf(2), bBuf(1))) + 1
End If
Loop While lPos < UBound(bTemp()) And bDone = 0
GetImageSizeInMem.Width = CombineBytes(bWlsb, bWmsb)
GetImageSizeInMem.Height = CombineBytes(bHlsb, bHmsb)
End If
'BMP 文件
If bTemp(0) = &H42 And bTemp(1) = &H4D Then
bWlsb = bTemp(18)
bWmsb = bTemp(19)
bHlsb = bTemp(22)
bHmsb = bTemp(23)
GetImageSizeInMem.Width = CombineBytes(bWlsb, bWmsb)
GetImageSizeInMem.Height = CombineBytes(bHlsb, bHmsb)
End If
'TGA 文件
If bTemp(2) = &H2 Then
bWlsb = bTemp(12)
bWmsb = bTemp(13)
bHlsb = bTemp(14)
bHmsb = bTemp(15)
GetImageSizeInMem.Width = CombineBytes(bWlsb, bWmsb)
GetImageSizeInMem.Height = CombineBytes(bHlsb, bHmsb)
End If
End Function
下边是调用上述模块的代码：xGraph.bas
'impactX Game Engine
'本类模块用于处理DX设备和几何绘图
'使用本类模块必须遵守:
'你可以免费使用本引擎及代码
'使用本引擎后的责任由使用者承担
'你可以任意拷贝本引擎代码，但必须保证其完整性
'希望我能得到你使用本引擎制作出的程序
'Davy.xu [email protected] qq:20998333
Option Explicit
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare Function timeBeginPeriod Lib "winmm.dll" ( _
ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" ( _
ByVal uPeriod As Long) As Long
Dim DX As DirectX8
Dim D3D As Direct3D8
Public D3DDevice As Direct3DDevice8
Public D3DX As D3DX8
Dim D3DWindow As D3DPRESENT_PARAMETERS '显示模式的各种参数
Const TLFVF = D3DFVF_XYZRHW Or D3DFVF_DIFFUSE Or D3DFVF_TEX1
'Transforme and Lit结构
Private Type TLVERTEX
x As Single
y As Single
Z As Single '2D渲染时不使用,设为0
rhw As Single '不使用,设为1
Color As Long '顶点颜色,AlphaBlend的基础颜色
Specular As Long '光照,不使用
tu As Single '贴图坐标(0~1) x轴
tv As Single '贴图坐标(0~1) y轴
End Type
'图形处理方式
Enum ENUM_XG_PROCESS
xgSOFTWARE = D3DCREATE_SOFTWARE_VERTEXPROCESSING '软件模拟
xgHARDWARE = D3DCREATE_HARDWARE_VERTEXPROCESSING '硬件模拟
xgPUREDEVICE = D3DCREATE_PUREDEVICE '纯硬件模拟
xgAUTO = 0 '自动识别(缺省)
End Enum
'不带透明的颜色
Enum ENUM_XG_COLOR
xgBLACK = &HFF000000 '黑
xgWHITE = &HFFFFFFFF '白
xgRED = &HFFFF0000 '红
xgGREEN = &HFF00FF00 '绿
xgBLUE = &HFF0000FF '蓝
xgYELLOW = &HFFFFFF00 '黄
xgMAGENTA = &HFFFF00FF '洋红
xgCYAN = &HFFFF00FF '青色
End Enum
Enum ENUM_DISPLAYMODE
xgWindow = 1
xgFullScreen = 0
End Enum
Enum ENUM_DEVICESTATE
xgDeviceOK = 0
xgDeviceLost = D3DERR_DEVICELOST
xgDeviceNotReset = D3DERR_DEVICENOTRESET
End Enum
'字体
Dim xgMainFont As D3DXFont
'Fps 显示
Private fpsTimer As Long
Private cCount As Integer
Private cFPS As Integer
'时间速度控制(LimitFPS)
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private m_LastTime As Long
'功能:初始化DirectGraph
'参数:全屏模式下的水平和垂直分辨率,显示窗口的句柄,D3D处理方式
'注意:初始化后,屏幕的颜色数被强制调节为16位色
Public Function InitDXGraph(ByVal ResWidth As Integer, ByVal ResHeight As Integer, ByVal hWnd As Long, Optional DisplayMode As ENUM_DISPLAYMODE = xgWindow, Optional Process As ENUM_XG_PROCESS) As Boolean
Dim BehaviorFlag As Long
Dim caps As D3DCAPS8
On Error GoTo ErrH
' On Error Resume Next
InitDXGraph = False
Call timeBeginPeriod(5)
Set DX = New DirectX8
'呼叫设定D3D
Set D3D = DX.Direct3DCreate()
Set D3DX = New D3DX8
Dim DMode As D3DDISPLAYMODE
D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DMode
If DisplayMode = xgWindow Then
D3DWindow.Windowed = 1
D3DWindow.SwapEffect = D3DSWAPEFFECT_DISCARD 'D3DSWAPEFFECT_COPY_VSYNC '
D3DWindow.BackBufferFormat = DMode.Format
Else
'页交换(Frontbuffer及Backbuffer)功能的选择,我们要使用全屏幕模式=D3DSWAPEFFECT_FLIP.
D3DWindow.SwapEffect = D3DSWAPEFFECT_FLIP
'背景頁(Backbuffer)的数量
D3DWindow.BackBufferCount = 1
'背景頁的單位圖素格式,D3DFMT_R5G6B5=16bits,65536色,高彩,
'當然您也可以把它設定為全彩(D3DFMT_R8G8B8).而我們再設定背景頁時其實就是在決定我們的顯示模式
'D3DFMT_R8G8B8：表示一个24位像素，从左开始，8位分配给红色，8位分配给绿色，8位分配给蓝色。
'D3DFMT_X8R8G8B8：表示一个32位像素，从左开始，8位不用，8位分配给红色，8位分配给绿色，8位分配给蓝色。
'D3DFMT_A8R8G8B8：表示一个32位像素，从左开始，8位为ALPHA通道，8位分配给红色，8位分配给绿色，8位分配给蓝色。
D3DWindow.BackBufferFormat = D3DFMT_A8R8G8B8
D3DWindow.EnableAutoDepthStencil = 1
'深度缓存
'D3DFMT_D32 //指定32位深度缓存
'D3DFMT_D24S8 //24位S，其中8位保留供模板缓存使用
'D3DFMT_D24X8 //24位X8
'D3DFMT_X4S4 //指定24位S，其中4位保留模板缓存使用
'D3DFMT_D16 //16位S
D3DWindow.AutoDepthStencilFormat = D3DFMT_D16
'水平垂直分辨率
D3DWindow.BackBufferWidth = ResWidth
D3DWindow.BackBufferHeight = ResHeight
End If
' MsgBox "11"
'作用window的hWnd
D3DWindow.hDeviceWindow = hWnd
If Process = xgAUTO Then
D3D.GetDeviceCaps D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, caps
'自动选择合适的硬件显示设备
If caps.DevCaps And D3DDEVCAPS_PUREDEVICE Then
BehaviorFlag = D3DCREATE_PUREDEVICE Or D3DCREATE_HARDWARE_VERTEXPROCESSING
Else
If caps.DevCaps And D3DDEVCAPS_HWTRANSFORMANDLIGHT Then
BehaviorFlag = D3DCREATE_HARDWARE_VERTEXPROCESSING
Else
BehaviorFlag = D3DCREATE_SOFTWARE_VERTEXPROCESSING
End If
End If
Else
BehaviorFlag = Process
End If
' MsgBox "22"
Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, BehaviorFlag, D3DWindow)
If Err.Number Then
Err.Clear
'Try to create a reference device
Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, _
D3DDEVTYPE_REF, hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, _
D3DWindow)
'If that too fails, return error and quit
If D3DDevice Is Nothing Then GoTo ErrH
End If
' MsgBox "33"
D3DDevice.SetVertexShader TLFVF '告訴D3D描繪方式使用我們設定的方式
D3DDevice.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE '贴图时开启ALPHA通道(AlphaBlend使用)
D3DDevice.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA '渲染时开启透明色
D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA '同上
D3DDevice.SetRenderState D3DRS_ALPHABLENDENABLE, True
SetTextType "SYSTEM", 11
InitDXGraph = True
Exit Function
ErrH:
Debug.Print "Err [InitDXGraph] 初始化DX错误"
Debug.Print "错误可能原因:显卡驱动不正确,显卡不支持Direct3D,禁用Direct3D,显存不够"
MsgBox "错误可能原因:显卡驱动不正确,显卡不支持Direct3D,禁用Direct3D,显存不够" & vbNewLine & "DirectX错误:" & Hex(Err.Number), vbCritical, "初始化DX错误"
End
End Function
'功能:给屏幕上底色
'参数:用以涂抹屏幕的颜色
Public Sub PaintScreen(ByVal BackColor As ENUM_XG_COLOR)
On Error GoTo ErrH
If D3DDevice Is Nothing Then End
D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET, BackColor, 1#, 0
Exit Sub
ErrH:
Debug.Print "Err: [PaintScreen] 函数调用错误"
Exit Sub
End Sub
'功能:清除缓冲,准备设备
Public Sub RenderBegin()
On Error GoTo ErrH
If D3DDevice Is Nothing Then End
D3DDevice.BeginScene
Exit Sub
ErrH:
Debug.Print "Err: [RenderBegin] 函数调用错误,RenderBegin和RenderEnd必须配对使用"
Exit Sub
End Sub
'功能:结束渲染,计算FPS,缓冲区图形翻转到主页面
Public Sub RenderEnd(Optional FrmInteval As Long = 1000)
On Error Resume Next
If D3DDevice Is Nothing Then Exit Sub
D3DDevice.EndScene '结束渲染
'计算FPS
If timeGetTime - fpsTimer > FrmInteval Then
cFPS = cCount
cCount = 0
fpsTimer = timeGetTime
Else
cCount = cCount + 1
End If
D3DDevice.Present ByVal 0, ByVal 0, ByVal 0, ByVal 0
Exit Sub
ErrH:
Debug.Print "Err: [RenderEnd] 函数调用错误,RenderBegin和RenderEnd必须配对使用"
Exit Sub
End Sub
Public Sub LimitFPS(ByVal Frame As Integer)
'功能:限制FPS
'参数:需要的FPS值
'帧每秒
'
Frame = Frame + 3
Do Until timeGetTime - m_LastTime > 1000 / Frame
Sleep 1
Loop
m_LastTime = timeGetTime
End Sub
Public Sub BeginText()
'功能:开始文字渲染
'注意:请尽量将输出的文字放在BeginText和EndText之间
xgMainFont.Begin
End Sub
Public Sub EndText()
'功能:结束文字渲染
'
xgMainFont.End
End Sub
Public Sub DrawText(ByVal sText As String, x As Integer, y As Integer, Optional Color As ENUM_XG_COLOR = xgWHITE)
'功能:在屏幕上绘制文字
'参数:文字,坐标,显示颜色
On Error GoTo ErrH
Dim rcText As RECT
xgMainFont.Begin
With rcText
.Left = x
.Top = y
End With
xgMainFont.DrawTextW sText, -1, rcText, 0, Color
xgMainFont.End
Exit Sub
ErrH:
Debug.Print "Err [DrawText] 绘制字体时错误"
Exit Sub
End Sub
Public Sub SetTextType(Name As String, Optional Size As Integer = 11)
'功能:设置显示文字
'参数:字体名字(在Word等软件里可以找到),字体大小
On Error GoTo ErrH
Dim xgFontDesc As IFont
Dim xgFont As New StdFont
Set xgMainFont = Nothing
xgFont.Name = Name ' "Times New Roman"
xgFont.Size = Size '8
xgFont.Bold = True
Set xgFontDesc = xgFont
Set xgMainFont = D3DX.CreateFont(D3DDevice, xgFontDesc.hFont)
Exit Sub
ErrH:
Debug.Print "Err [SetTextType] 创建字体时错误"
Exit Sub
End Sub
Private Function CreateTLVertex(x As Single, y As Single, ByVal Color As Long, tu As Single, tv As Single) As TLVERTEX
'D3D内部使用,构建一个TLV顶点结构
CreateTLVertex.x = x
CreateTLVertex.y = y
CreateTLVertex.Z = 0
CreateTLVertex.rhw = 1
CreateTLVertex.Color = Color
CreateTLVertex.Specular = 0
CreateTLVertex.tu = tu
CreateTLVertex.tv = tv
End Function
Public Sub DrawLine(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, Color As ENUM_XG_COLOR)
'功能:画一条线
'参数:线条的两个点坐标,颜色
On Error GoTo ErrH
Dim tVer(0 To 1) As TLVERTEX
Dim BlankTexture As Direct3DTexture8
tVer(0) = CreateTLVertex(CSng(X1), CSng(Y1), Color, 0, 0)
tVer(1) = CreateTLVertex(CSng(X2), CSng(Y2), Color, 0, 0)
D3DDevice.SetTexture 0, BlankTexture
D3DDevice.DrawPrimitiveUP D3DPT_LINELIST, 2, tVer(0), Len(tVer(0))
Exit Sub
ErrH:
Debug.Print "Err [DrawLine] 绘图时错误"
Exit Sub
End Sub
'画点
Public Sub DrawPoint(x As Integer, y As Integer, Color As ENUM_XG_COLOR)
On Error GoTo ErrH
Dim tVer As TLVERTEX
Dim BlankTexture As Direct3DTexture8
tVer = CreateTLVertex(CSng(x), CSng(y), Color, 0, 0)
D3DDevice.SetTexture 0, BlankTexture
D3DDevice.DrawPrimitiveUP D3DPT_POINTLIST, 2, tVer, Len(tVer)
Exit Sub
ErrH:
Debug.Print "Err [DrawPoint] 绘图时错误"
Exit Sub
End Sub
'画圆
Public Sub DrawCircle(x As Integer, y As Integer, Radius As Integer, Color As ENUM_XG_COLOR)
Dim iX As Integer, iY As Integer
Static LastX As Integer, LastY As Integer
Dim Angle As Single
Dim tVer(0 To 1) As TLVERTEX
For Angle = 0 To 2 * 3.14 Step 3.14 / 30 '决定圆的圆度，step值越大，越不圆
iX = x + (Radius * Cos(Angle))
iY = y + (Radius * Sin(Angle))
If Not (LastX = 0 And LastY = 0) Then
tVer(0) = CreateTLVertex(CSng(iX), CSng(iY), Color, 0, 0)
tVer(1) = CreateTLVertex(CSng(LastX), CSng(LastY), Color, 0, 0)
D3DDevice.DrawPrimitiveUP D3DPT_LINELIST, 2, tVer(0), Len(tVer(0))
End If
LastX = iX
LastY = iY
Next Angle
End Sub
'功能:画一个矩形
'参数:矩形的四个角,颜色
Public Sub DrawRect(ByVal Left As Integer, ByVal Top As Integer, ByVal Right As Integer, ByVal Bottom As Integer, Color As ENUM_XG_COLOR)
DrawLine Left, Top, Right, Top, Color
DrawLine Right, Top, Right, Bottom, Color
DrawLine Left, Bottom, Right, Bottom, Color
DrawLine Left, Top, Left, Bottom, Color
End Sub
'功能:画一个矩形并填充
'参数:矩形的四个角,颜色
Public Sub DrawRectFill(ByVal Left As Integer, ByVal Top As Integer, ByVal Right As Integer, ByVal Bottom As Integer, Color As ENUM_XG_COLOR)
On Error GoTo ErrH
Dim tVer(0 To 3) As TLVERTEX
Dim BlankTexture As Direct3DTexture8
Dim t As Integer
'颠倒处理
If Bottom < Top Then t = Bottom: Bottom = Top: Top = t
If Right < Left Then t = Right: Right = Left: Left = t
tVer(0) = CreateTLVertex(CSng(Left), CSng(Top), Color, 0, 0)
tVer(1) = CreateTLVertex(CSng(Right), CSng(Top), Color, 0, 0)
tVer(2) = CreateTLVertex(CSng(Left), CSng(Bottom), Color, 0, 0)
tVer(3) = CreateTLVertex(CSng(Right), CSng(Bottom), Color, 0, 0)
D3DDevice.SetTexture 0, BlankTexture
D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, tVer(0), Len(tVer(0))
Exit Sub
ErrH:
Debug.Print "Err [DrawRectFill] 绘图时错误"
Exit Sub
End Sub
'功能:画一个4色渐变矩形并填充
'参数:矩形的四个角,四个角颜色
Public Sub DrawRectGradual(ByVal Left As Integer, ByVal Top As Integer, ByVal Right As Integer, ByVal Bottom As Integer, _
Color_LeftTop As ENUM_XG_COLOR, Color_LeftRight As ENUM_XG_COLOR, Color_BottomLeft As ENUM_XG_COLOR, Color_BottomRight As ENUM_XG_COLOR)
On Error GoTo ErrH
Dim tVer(0 To 3) As TLVERTEX
Dim BlankTexture As Direct3DTexture8
Dim t As Integer
'颠倒处理
If Bottom < Top Then t = Bottom: Bottom = Top: Top = t
If Right < Left Then t = Right: Right = Left: Left = t
tVer(0) = CreateTLVertex(CSng(Left), CSng(Top), Color_LeftTop, 0, 0)
tVer(1) = CreateTLVertex(CSng(Right), CSng(Top), Color_LeftRight, 0, 0)
tVer(2) = CreateTLVertex(CSng(Left), CSng(Bottom), Color_BottomLeft, 0, 0)
tVer(3) = CreateTLVertex(CSng(Right), CSng(Bottom), Color_BottomRight, 0, 0)
D3DDevice.SetTexture 0, BlankTexture
D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, tVer(0), Len(tVer(0))
Exit Sub
ErrH:
Debug.Print "Err [DrawRectFill] 绘图时错误"
Exit Sub
End Sub
'功能:卸载DirectGraph
Public Sub UnloadDXGraph()
Set D3DX = Nothing
Set D3DDevice = Nothing
Set D3D = Nothing
Set DX = Nothing
Call timeEndPeriod(5)
End Sub
Public Function GetDeviceState() As ENUM_DEVICESTATE
GetDeviceState = D3DDevice.TestCooperativeLevel
End Function
Public Sub DeviceReset()
D3DDevice.Reset D3DWindow
D3DDevice.SetVertexShader TLFVF '告訴D3D描繪方式使用我們設定的方式
D3DDevice.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE '贴图时开启ALPHA通道(AlphaBlend使用)
D3DDevice.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA '渲染时开启透明色
D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA '同上
End Sub
'获得FPS
Public Property Get GetFPS() As Integer
GetFPS = cFPS
End Property