VB人自己的引擎 (for API) .(源码和工具)

zodane

    大家一起来整理,收集吧 . 将自己看到的或是自己原创的代码发上来 .当然也可以是小工具 .
这个贴用来存放并整理各类基于API的代码 .

    代码最好是类模块  . 另外最好附上整洁的注释.以及操作实例 .  另外小工具也很好 .   

    为了方便代码的不断优化和增进可读性.  
    我贴一个例子出来 .

''''''''''''''''''''''''''''''''''''''''''''''游戏用户物品集合类''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'功能描述:管理所有的用户物品信息,保存,维护.
'版本号:1.07(07/2/5)
'作者:铁血(QQ:44378791)
'日期:2006年11月22日.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''升级报告'
'1.02(06/12/12):增加在集合中按名称和索引得到集合中元素的方法.
'1.03(06/12/21):增加所有物品数据的录入.包括后期新增物品的数据预备. 见private Type Gp(物品数据类).
'1.04(06/12/25):利用友元属性进行type的移植,此类主要用于存储所有系统默认的物品数据资料.
'1.05(06/12/27):存储用户物品资料数据,加强有戏中的预保存功能. 见type UGp ,并利用友元属性导出
'1.06(07/1/18):存储用户物品容器框资料数据.见type PBox ,并利用友元属性导出.
'1.07(07/2/5):增加药品效果持续时间的功能.(效果期结束后,效果解除的过程),见type KP  以及相关子程序

就是希望如果有人改进了代码,  可以在后面代码文件里面做个记录 ,标上日期 .以便不断的更新.
能够经受住大家考验的代码才是好的代码.   

代码文件里面的每一个功能区域最好用注释些分割开来 , 这样方便代码的阅读 .  比如 . 大型的模块程序可能一趟功夫完成不了 , 那么有必要把功能区域分隔一下.  这样也方便自己日后的查询 .

zodane

   本程序  附上  2个类
   一个是操作INI文件的.  另外一个是操作系统音量的.  同时附上应用这俩个类而开发的用户环境设置程序 .  
   因为这个栏目刚刚开始举办,  许多情况我还不清楚 . 我想论坛肯定有高人做了功能比这强大得多的引擎吧 .  但是暂时还不熟悉你们的引擎 .
所以我先发自己的拙品上来了.  .

    往后代码会不断更新的.  如果您有更好的代码 ,期待大家早日能用更好的代码来推翻现在的.   

zodane

    这个程序是我从  mndsoft 站上找到的.  觉得非常时候做到有戏中的信息提示框.
它可以在里面绑上小图标 ,可以半透明, 可以选择特殊字体.  可以调整字体颜色.水平渐变色, 圆角矩形框等 .可以调制出非常花哨的界面效果来 .
只可惜 ,这个程序有个巨大的局限 , 在生成提示框的时候 ,必须要绑定某个控件的hwnd .这样麻烦就大多了.  像label  ,image 这样的控件都是无法使用的, 另外 ,目前也在努力走程序中不使用控件这样的路线  那就更没有辙了.  程序我没有读懂 .
现在发过来 . 等高手解开它的迷 .

zodane

图片切换和动画时间控制
我们平时做图片，一般都是用图片框使用loadpicture方法做单张的切换。
但这个速度太慢。如果图片比较大的话，肯定影响读取速度。
因为图片框在不停的装载，转换图片。

为此，我们可以使用bitblt函数来做动画图片显示。
在这 ，我们使用封装了许多API函数的FX.DLL来控制动画

代码也放到附件里面 ,有兴趣的朋友请看看.
首先新建一个模块
输入以下代码用于定义引用所要用到的API函数.
Option Explicit

Public Const MERGEPAINT = &HBB0226
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
    ByVal X As Long, ByVal Y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long

Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Declare Function fxRotate Lib "VB6.DLL" (ByVal DestDC As Long, ByVal CenterX As Long, ByVal CenterY As Long,

ByVal SrcDC As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal

Angle As Double, ByVal TransparentColor As Long, Optional ByVal Flags As Long = 0) As Long


然后新建一个窗体文件
Option Explicit

Dim ITIMER As Long, JTIMER As Long
Dim X1 As Single, Y1 As Single
Dim P As Long, FPS As Long, BPS As Long


Dim aTIMER As Long, bTIMER As Long


Private Sub Form_Load()

Randomize Timer
Form1.Height = 480 * 15: Form1.Width = 640 * 15

X1 = 200: Y1 = 200     '坐标
BPS = 0: FPS = 120
Me.Show

aTIMER = GetTickCount()   '控制动画的总时间

ITIMER = GetTickCount()   '控制动画每张的时间


End Sub

Private Sub Timer1_Timer()



bTIMER = GetTickCount()
'1000等于1秒,翻2秒
If bTIMER - aTIMER > 1000 Then FPS = 2401


BitBlt Me.hDC, 0, 0, 640, 480, Picture1.hDC, 0, 0, vbSrcCopy   '刷新背景


'////////////////////////////////////////////////////////////////////////
JTIMER = GetTickCount()
'1000等于1秒，现在用的100=1/10秒翻一页
If JTIMER - ITIMER > 20 Then FPS = FPS + 120: BPS = BPS + 120: ITIMER = GetTickCount()
If FPS >= 2400 Then FPS = 1   '8张图

'BitBlt Me.hDC, X1, Y1, 120, 120, PIC.hDC, FPS, 0, vbSrcCopy
fxRotate Me.hDC, X1, Y1, PIC.hDC, FPS, 0, 120, 120, 0, vbWhite

Me.Refresh
End Sub

bitblt 有一个非常大的优势在于 ,它可以截取一副图片的指定区域进入要求的场景中 , 加上FX的强大功能, 可以去除图片的边框背

景色. 只要我们就可以制作出精美无瑕疵的动画来 .

我们可以使用timer  来控制截取图片的区域  .  达到动画切换的目的 .

现在着重解释一下bitblt 这个函数
'BitBlt Me.hDC, X1, Y1, 120, 120, PIC.hDC, FPS, 0, vbSrcCopy

第一个参数  .某控件的句柄(.hdc) ,一般是显示图片的窗体页面对象.
X1,Y1. 指显示图片的左上角(横坐标,和纵座标) .
120,120 是截取图片的高度和宽度.
pic.hdc .规定显示图片的容器为picture  .因为image控件,没有.hdc .
FPS,0 ,是指被截取图片的起点的(左上角) 的横座标  ,纵座标.  最后一个vbStrCopy 是个固定的参数.



下面再重点介绍一下动画中的时间控制.
首先 ,我讲一下动画中图片切换的频率控制.
    就是指令隔多长的时间就切换一次图片 .
    我们可以用now 函数来获取系统当前的时间 ,但是这个函数只能精确到秒 . 于是我们使用API函数 gettickcount  来获取系统当

前的时钟 . gettickcount 其实也是now 函数一样的功能, 不过他将时钟精确到了毫秒.
这样 ,我们就可以通过比较俩次时钟之间的差 . 我们指定一个时间长度() 来达到切换动画. 首先在初始化程序的时候取一次时钟,

然后在timer里面写一个时钟进行比较. timer的interval 可以设置成1. 也就是每毫秒做一次检测.这里需要指出的是使用这种方法

做时钟判断的好处.因为我们将时钟判断分离出来了, 我们不用再去考虑timer的判断周期.还有,如果有俩个频率不相同的检测就必

须使用俩个timer 而使用这种方法,以毫秒为时钟开始检测,就可以执行所有的检测了.

  其次,讲一下如何控制动画的播放时间 .原理,和判断时钟频率是一样的.见以下这句
If bTIMER - aTIMER > 1000 Then FPS = 2401
我们通过比较俩个时钟标记.来判断动画执行多长的时间
以上的意思是执行1000毫秒 ,(1秒中)  .当时钟超过1秒时 FPS=2401 .
2401是一个虚拟的值 , 在本代码中表示的应该是原图片的横座标 .因为图片的最大宽度是2400, 超过这个, 则自然就播放不出动画

了.  

代码也放到附件里面 ,有兴趣的朋友请看看.

zodane

''''''''''''''''''''''''''''''''''''''''''''数据管理类''''''''''''''''''''''''''''''''''''''''''''''''''''''
'描述: 进行数据库各项操作的集成.功能比常规的操作强大 支持多数据库连接.图片存取,(需要数据库的SQL语法基础).(支持数据库实时操作与后台conn.excute 语句操作 .)
'作者:铁血(QQ:44378791)
'版本号:1.01(07/2/28)
'日期:2007年2月28日.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private mConn() As ADODB.Connection
Private mRs() As ADODB.Recordset
Private j() As String
Private Count As Integer
Private cs() As String
Private Ds() As String

Public Property Get Conn(Index As Integer) As ADODB.Connection  '外界引用的连接变量
    Set Conn = mConn(Index)
End Property


Public Property Get rs(Index As Integer) As ADODB.Recordset  '外界引用的RS .
    Set rs = mRs(Index)
End Property
Public Property Set rs(Index As Integer, ByVal vData As ADODB.Recordset)
    Set mRs(Index) = vData
End Property

'可在外部用CONN.execute 执行.
Public Function AddNew(conna As ADODB.Connection, Rsa As ADODB.Recordset,
fname As String, w As Long) As String  '得到字符型的数据库操作语句.(新建)
  Rsa.Open "select * from " & "fname", conna, 3, 1
  Dim Begine As String
  Begine = Rsa.Fields(0).Name
  AddNew = "Insert Into " & fname & "( " & Begine & " )" & " values"
  AddNew = AddNew & "( " & w & " )"
  Rsa.Close
End Function
Public Function DelCut(fname As String, Rcdname As String, value As Variant) As String
  DelCut = "Delete From " & fname & " Where " & Rcdname & " = " & value
End Function

Public Sub AddTrue(conna As ADODB.Connection, Rsa As ADODB.Recordset, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & "fname", conna, 3, 3
  Rsa.AddNew
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).value = w(i)
  Next
  Rsa.Update
  Rsa.Close
End Sub
'''删除单条记录'''''''''''(运行时直接删除).
Public Function DelRcd(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal FormName As String, ByVal RecName As String, ByVal Recvalue As Variant) As Boolean
On Error GoTo Finish
Rsa.Open "delete * from " + FormName + " where " + RecName + " = '" + Recvalue + "'", conna, 3, 1
DelRcd = True
Exit Function
Finish:
DelRcd = False
End Function

Public Sub ChangeA(Rsa As ADODB.Recordset, ParamArray w() As Variant)
  Dim i As Integer
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).value = w(i)
  Next
End Sub

'以下俩个函数适用于实时操作的数据库
Public Sub ChangeB(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal RecName As String, ByVal Recvalue As Variant, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & fname & " where " + RecName + " = " + Recvalue, conna, 3, 3
  Rsa.AddNew
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).value = w(i)
  Next
  Rsa.Update
  Rsa.Close
End Sub

Public Sub ChangeB(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal RecName As String, ByVal Recvalue As Variant, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & fname & " where " + RecName + " = '" + Recvalue + "'", conna, 3, 3
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).value = w(i - 1)
  Next
  Rsa.Update
  Rsa.Close
End Sub

Public Sub LoadData(Rsa As ADODB.Recordset, ParamArray w() As Variant) '读数据库
  Dim i As Integer
  For i = 1 To Rsa.Fields.Count
    w(i - 1) = Rsa.Fields(i).value
  Next i
End Sub

Public Sub AddBase(Dname As String) '建立一个新数据库的连接.
  Dim i As Integer, j As Integer
  Count = Count + 1
  For i = 1 To Count
    ReDim Preserve Conn(1 To Count)
    Set Conn(Count) = New ADODB.Connection
    ConnOpen Dname
    ReDim Preserve rs(1 To Count)
    Set rs(Count) = New ADODB.Recordset
  Next i
End Sub

Private Sub ConnOpen(DataName As String)  ' 打开数据连接
    Dim strConn As String '数据库连接字符串
    Dim dbpath As String
    ' On Error GoTo err
        dbpath = App.Path
        If Right(dbpath, 1) <> "\" Then dbpath = dbpath + "\"
        dbpath = dbpath & DataName
        strConn = &quotrovider=Microsoft.Jet.OLEDB.4.0;Data Source= " & dbpath & ";Persist Security Info=False"
        Conn(Count).Open strConn
        Conn(Count).CursorLocation = adUseClient
    Exit Sub
    'err:
     ' MsgBox "数据库连接失败！"
End Sub
Private Sub ConnClose()  '关闭连接并释放内存
   On Error Resume Next
   Dim i As Integer
   For i = 1 To Count
     If Conn(i).State = adStateOpen Then Conn.Close
     Set Conn(i) = Nothing
     Set rs(i) = Nothing
   Next i
End Sub

''''以下三个函数为数据库中的图片操作.
Public Sub GetPic(rs As ADODB.Recordset, Pic As PictureBox, i As Integer)   '读取图片
    On Error Resume Next
    Set StmPic = New ADODB.Stream
    StrPIctemp = "c:\temp.tmp"    '临时文件,用来保存读出的图片
    With StmPic
        .Type = adTypeBinary
        .Open
        .Write rs.Fields(i)       '写入数据库中的数据至Stream中
        .SaveToFile StrPIctemp, adSaveCreateOverWrite  '将Stream中数据写入临时文件中
        .Close
    End With
    Pic.Picture = LoadPicture(StrPIctemp)  '用Picture控件显示图像
End Sub
'在数据库中取得图片的二进制数据流.(这个函数中的图片数据可以在多种场合中灵活的出现).
Public Function GetPicData(rs As ADODB.Recordset, T As Integer) As String
    Dim StrPIctemp As String
    Set StmPic = New ADODB.Stream
    StrPIctemp = "c:\temp.tmp"    '临时文件,用来保存读出的图片
    With StmPic
        .Type = adTypeBinary
        .Open
        .Write rs.Fields(T)     '写入数据库中的数据至Stream中
        .SaveToFile StrPIctemp, adSaveCreateOverWrite  '将Stream中数据写入临时文件中
        .Close
    End With
    GetPicData = StrPIctemp
   ' Set StrPIctemp = Nothing
    Set StmPic = Nothing
End Function
Public Sub SavePic(rs As ADODB.Recordset, i As Integer)  '保存图片
    Dim StrPIctemp As Variant
    Set StmPic = New ADODB.Stream
    StmPic.Type = adTypeBinary    '指定流是二进制类型
    StmPic.Open                     '将数据获取到Stream对象中
    StmPic.LoadFromFile (dlgopen.FileName) '将选择的图像加载到打开的StmPic中
    rs.Fields(i).value = StmPic.Read   '从StmPic对象中读取数据
    StmPic.Close
End Sub
'星河程序群(19597340)+ 论坛千分以上会员和业余爱好者.

boywhp

ｖｂ６下面的超强Alpha引擎，用过的请留个言，boywhp
我们一直在使用的，呵呵，不光是用在游戏中，所有的２Ｄ图形处理都可以
最新alpha引擎源码＋ＳＤＫ下载
http://whp.1school.net/LeaveWord.aspx

zero_yp

''''''''''''''''''''''''''''''''''''''''''''''wav/avi/mid媒体类''''''''''''''''''''''''''''''''''''''''''''
'功能描述:播放wav/avi/mid媒体文件
'版本号:-
'作者eter Wright
'日期:-
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

gpra8764

6楼的，网站不存在了哦，有没有以前下过这个alpha引擎的，急需啊

xxnn

很好很强大

使命招唤

VB支持XNA和X360游戏机的引擎：http://www.reactor3d.com/site/content/view/56/72/
友情帮忙宣传一下。




下载地址：http://www.reactor3d.com/site/content/view/55/70/