DX7 for VB6 游戏引擎加强版

DX7 for VB6 游戏引擎加强版

Option Explicit
'**************************************************************
'
'                        《梦想之翼》
'
'VB+DirectX7编写，包括图像、键盘、鼠标、声音处理。
'
'经过多次改进和完善，是一个比较易用的引擎。
'
'                                    ----作者：袁进峰
'                                      2004年9月13日
'                                    ----加强：liuhan
'                                      2010年7月30日
'
'**************************************************************
'======================《加装JPG作准备》=======================
Private 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
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'========================《鼠标指针位置》======================
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long                       '屏幕绝对坐标
Private Declare Function showCursor Lib "user32" Alias "ShowCursor" (ByVal bShow As Long) As Long      '显示或隐藏鼠标
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long '转换屏幕绝对座标为对象相对坐标
Public Type POINTAPI
    x As Long
    y As Long
End Type
'=======================《显示或隐藏鼠标》=====================
'Public Declare Function showCursor Lib "user32" Alias "ShowCursor" (ByVal bShow As Long) As Long
'==================《用于显示、控制速度的函数》================
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim FPS_Count As Long
'显示速度所用变量
Dim mTimer As Long
Dim AddFPS As Integer
Public FPS As Integer
'==============================================================
Public Type POS
    x As Integer
    y As Integer
End Type
'======================Sleep函数控制速度=======================
'Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long) '-----Sleep函数
'======================《窗口标题的高度,边宽度》======================
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     Const SM_CYCAPTION = 4       ' Height of caption or title
     Const SM_CXFRAME = 32        ' Width of window frame
     Const SM_CYFRAME = 33        ' Height of window frame
'======================《窗口标题的高度,边宽度》======================
'设置窗体结构信息函数
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'获取窗体结构信息函数
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)               '窗口样式
Private Const WS_BORDER = &H800000            '创建一个有边框的窗体。
Private Const WS_MAXIMIZE = &H1000000         '窗口最大化
Private Const WS_CAPTION = &HC00000           '带标题栏的窗口
Private Const WS_SYSMENU = &H80000
Private Const WS_SIZEBOX = &H40000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Private Declare Function ShowWindow Lib "user32.dll " (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_MAXIMIZE As Long = 3
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
'liuhan
Public goFull As Boolean
Private Obj_STYLE As Long
Private Obj_RECT As RECT
Private Src_RECT As RECT
'==============================================================
Dim ObjhWnd As Long
Dim BlthWnd As Long
Dim Dx As New DirectX7
Dim DDraw As DirectDraw7
Public MainSurf As DirectDrawSurface7
Public BackSurf As DirectDrawSurface7
Dim Clipper As DirectDrawClipper
Dim Gamea As DirectDrawGammaControl
Public destRect As RECT
Public srcRect As RECT
Dim DI As DirectInput
Public KeyDevice As DirectInputDevice
Public KeyState As DIKEYBOARDSTATE
Public dimouse As DirectInputDevice
Public MouseState As DIMOUSESTATE
Dim DSound As DirectSound
Dim objdmloader As DirectMusicLoader
Dim objdmperf As DirectMusicPerformance
Public objdmseg As DirectMusicSegment
Public objdmsegst As DirectMusicSegmentState
Dim g_MapW As Integer
Dim g_MapH As Integer
Dim StdFont As New StdFont
Dim Font As IFont
Public Type DSurface
    Image As DirectDrawSurface7
    W As Integer
    H As Integer
End Type
Public Sub Window_Full()
    Dim iHwnd As Long
    iHwnd = GetWindowLong(ObjhWnd, GWL_STYLE)            '获取原风格
    iHwnd = iHwnd And Not (WS_BORDER)                   '去除不用的风格
    iHwnd = iHwnd And WS_MAXIMIZE
    iHwnd = SetWindowLong(ObjhWnd, GWL_STYLE, iHwnd)     '设置新的风格
End Sub
Public Sub Window_Mode()
    Dim iHwnd As Long
    'iHwnd = GetWindowLong(ObjhWnd, GWL_STYLE)            '获取原风格
    'iHwnd = iHwnd Or WS_BORDER                         '加上自定义风格
    iHwnd = SetWindowLong(ObjhWnd, GWL_STYLE, Obj_STYLE)     '设置新的风格
    'iHwnd = SetWindowPos(ObjhWnd, HWND_NOTOPMOST, Obj_RECT.Left, Obj_RECT.Top, Obj_RECT.Right - Obj_RECT.Left, Obj_RECT.Bottom - Obj_RECT.Top, SWP_SHOWWINDOW Or SWP_NOACTIVATE)
    iHwnd = MoveWindow(ObjhWnd, Obj_RECT.Left, Obj_RECT.Top, Obj_RECT.Right - Obj_RECT.Left, Obj_RECT.Bottom - Obj_RECT.Top, 1)
End Sub
'初始化DDraw
Public Sub InitEngine(FormhWnd As Long, _
Optional Width As Long, Optional Height As Long, _
Optional FullScreen As Boolean = False, _
Optional FWidth As Integer = 640, Optional FHeight As Integer = 480, _
Optional Color As Byte = 16, Optional Switch As Boolean = False)
    g_MapW = Width
    g_MapH = Height
    ObjhWnd = FormhWnd
    'If FullScreen = True Then
    '    Window_Full
        'SetWindowLong ObjhWnd, GWL_STYLE, STYLE_NONE
        'Dim iHwnd As Long
        'iHwnd = SetWindowPos(ObjhWnd, HWND_TOPMOST, 0, 0, Screen.Width, Screen.Height, SWP_SHOWWINDOW)
        'ShowWindow ObjhWnd, SW_MAXIMIZE
    'Else
    '    Window_Mode
    'End If
    goFull = FullScreen
    Set DDraw = Dx.DirectDrawCreate("")
    '========================《设置显示模式》==============================
    If FullScreen = True Then
        Call DDraw.SetCooperativeLevel(FormhWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE)
        Call DDraw.SetDisplayMode(FWidth, FHeight, Color, 0, DDSDM_DEFAULT)
    Else
        Call DDraw.SetCooperativeLevel(FormhWnd, DDSCL_NORMAL)
        GetWindowRect ObjhWnd, Obj_RECT                        '获取位置高宽
        Obj_STYLE = GetWindowLong(ObjhWnd, GWL_STYLE)          '获取样式风格
    End If
    '======================================================================
    '定义变量
    Dim ddsd As DDSURFACEDESC2
    '========================《设置主表面》================================
    ddsd.lFlags = DDSD_CAPS 'Or DDSD_BACKBUFFERCOUNT
    ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
    Set MainSurf = DDraw.CreateSurface(ddsd)
    '========================《设置缓冲表面》==============================
    ddsd.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
    ddsd.lWidth = Width
    ddsd.lHeight = Height
    ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
    Set BackSurf = DDraw.CreateSurface(ddsd)
    '==========================《初始化字体》==============================
    Set Font = StdFont
    Font.Name = "宋体"
    '************************************************************
    Call InitDI(FormhWnd)
    Call InitWav(FormhWnd)
    Call InitMid
    If FullScreen = True Then Call initGamma                   '初始化Gamma
End Sub
'=======================《剪切》=======================================
'窗体调用成功后，调用，必写
Public Sub ClipperhWnd(hwnd As Long)
    BlthWnd = hwnd
    Set Clipper = DDraw.CreateClipper(0)
    Clipper.SetHWnd hwnd
    MainSurf.SetClipper Clipper
    Call Dx.GetWindowRect(hwnd, destRect)
End Sub
'LoadImge(DirectDrawSurface7变量,图像路径,透明色)
Public Function LoadImage(FileName As String, Optional Color As Long = &HF81F) As DSurface
    On Error GoTo LoadImageErr
   
    Dim ddsd As DDSURFACEDESC2
    ddsd.lFlags = DDSD_CAPS
    ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
   
    '装载图像
    Set LoadImage.Image = DDraw.CreateSurfaceFromFile(FileName, ddsd)
    'Set image = DDraw.CreateSurfaceFromResource(, "PIC1", ddsd)
    LoadImage.W = ddsd.lWidth
    LoadImage.H = ddsd.lHeight
    '设置透明色(liuhan2010-05-20自动取左上角为透明色)
    Dim Tcolor As Long, key As DDCOLORKEY
    LoadImage.Image.Lock srcRect, ddsd, DDLOCK_WAIT, BlthWnd    '锁住页面
    Tcolor = LoadImage.Image.GetLockedPixel(0, 0) '获得 0,0 点的颜色
    LoadImage.Image.Unlock srcRect '解锁页面
    key.low = Tcolor
    key.high = Tcolor
    Call LoadImage.Image.SetColorKey(DDCKEY_SRCBLT, key)
    '设置透明色
    'Dim key As DDCOLORKEY
    'key.low = Color
    'key.high = Color
    'Call LoadImage.Image.SetColorKey(DDCKEY_SRCBLT, key)
    Exit Function
LoadImageErr:
    MsgBox "没有找到" + FileName + "图像文件。"
End Function
'2010-06-12加入袁进峰的直接读出gif、jpg图像过程
'LoadImgeTDC(DirectDrawSurface7变量,图像路径,透明色)
Public Function LoadImageTDC(FileName As String, Optional Color As Long = &HF81F) As DSurface
    On Error GoTo LoadImageErr
   
    Dim SDesc As DDSURFACEDESC2
    Dim TPict As StdPicture
    Set TPict = LoadPicture(FileName)
   
    SDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    SDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY '加上DDSCAPS_SYSTEMMEMORY加快速度？
    SDesc.lHeight = CLng((TPict.Height * 0.001) * 567 / Screen.TwipsPerPixelY)
    SDesc.lWidth = CLng((TPict.Width * 0.001) * 567 / Screen.TwipsPerPixelX)
   
    Set LoadImageTDC.Image = DDraw.CreateSurface(SDesc)
    LoadImageTDC.W = SDesc.lWidth
    LoadImageTDC.H = SDesc.lHeight
   
    Dim SDC As Long, TDC As Long
    SDC = LoadImageTDC.Image.GetDC
    TDC = CreateCompatibleDC(0)
    SelectObject TDC, TPict.Handle
    BitBlt SDC, 0, 0, SDesc.lWidth, SDesc.lHeight, TDC, 0, 0, vbSrcCopy
   
    LoadImageTDC.Image.ReleaseDC SDC
    DeleteDC TDC
    '设置透明色(liuhan2010-05-20自动取左上角为透明色)
    Dim Tcolor As Long, key As DDCOLORKEY
    LoadImageTDC.Image.Lock srcRect, SDesc, DDLOCK_WAIT, BlthWnd    '锁住页面
    Tcolor = LoadImageTDC.Image.GetLockedPixel(0, 0) '获得 0,0 点的颜色
    LoadImageTDC.Image.Unlock srcRect '解锁页面
    key.low = Tcolor
    key.high = Tcolor
    Call LoadImageTDC.Image.SetColorKey(DDCKEY_SRCBLT, key)
    '设置透明色
    'Dim key As DDCOLORKEY
    'key.low = Color
    'key.high = Color
    'Call LoadImageTDC.Image.SetColorKey(DDCKEY_SRCBLT, key)
   
    Set TPict = Nothing
    Exit Function
LoadImageErr:
    MsgBox "没有找到" + FileName + "图像文件。"
End Function
'*********************************************************************
'BltFxImage(DirectDrawSurface7变量,输出目标位置X、Y,W、H,择取源图X、Y,W、H,透明色作用开关)2010-06-28
Public Sub BltFxRDImage(Image As DSurface, xSrc As Integer, ySrc As Integer, Width As Integer, Height As Integer, _
                    xImage As Integer, yImage As Integer, wImage As Integer, hImage As Integer, _
                    Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    Dim wZoom As Single, hZoom As Single   '目标、输出图像比例
    wZoom = wImage / Width
    hZoom = hImage / Height
    '-----------------源图像的大小------------------
    ImageRECT.Left = xImage
    ImageRECT.Top = yImage
    ImageRECT.Right = wImage
    ImageRECT.Bottom = hImage
    '-----------------目标图像的大小------------------
    destRect.Left = xSrc
    destRect.Top = ySrc
    destRect.Right = xSrc + Width
    destRect.Bottom = ySrc + Height
   
    'DDBLTFX图方向结构
    Dim FX As DDBLTFX
    'FX.lDDFX = DDBLTFX_MIRRORLEFTRIGHT
    'FX.lDDFX = DDBLTFX_MIRRORUPDOWN
    FX.lDDFX = DDBLTFX_MIRRORLEFTRIGHT Or DDBLTFX_MIRRORUPDOWN
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        destRect.Left = 0
        ImageRECT.Right = (xSrc + Width) * wZoom
    End If
   
    If ySrc < 0 Then
        destRect.Top = 0
        ImageRECT.Bottom = destRect.Bottom * hZoom
    End If
 
    If Width + xSrc > g_MapW Then
        destRect.Right = g_MapW
        ImageRECT.Left = (Width + xSrc - g_MapW) * wZoom
        If ImageRECT.Left >= wImage Then Exit Sub
    End If
   
    If Height + ySrc > g_MapH Then
        destRect.Bottom = g_MapH
        ImageRECT.Top = (ySrc + Height - g_MapH) * hZoom
        If ImageRECT.Top >= hImage Then Exit Sub
    End If
   
    'If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    'If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan (2010-05-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_KEYSRC Or DDBLT_DDFX, FX)   'DDBLT_KEYSRC Or DDBLT_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_WAIT Or DDBLT_DDFX, FX) 'DDBLT_KEYSRC Or DDBLT_WAIT
    End If
End Sub
'*********************************************************************
'BltFxImage(DirectDrawSurface7变量,输出目标位置X、Y,W、H,择取源图X、Y,W、H,透明色作用开关)2010-06-28
Public Sub BltFxDImage(Image As DSurface, xSrc As Integer, ySrc As Integer, Width As Integer, Height As Integer, _
                    xImage As Integer, yImage As Integer, wImage As Integer, hImage As Integer, _
                    Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    Dim wZoom As Single, hZoom As Single   '目标、输出图像比例
    wZoom = wImage / Width
    hZoom = hImage / Height
    '-----------------源图像的大小------------------
    ImageRECT.Left = xImage
    ImageRECT.Top = yImage
    ImageRECT.Right = wImage
    ImageRECT.Bottom = hImage
    '-----------------目标图像的大小------------------
    destRect.Left = xSrc
    destRect.Top = ySrc
    destRect.Right = xSrc + Width
    destRect.Bottom = ySrc + Height
   
    'DDBLTFX图方向结构
    Dim FX As DDBLTFX
    'FX.lDDFX = DDBLTFX_MIRRORLEFTRIGHT
    FX.lDDFX = DDBLTFX_MIRRORUPDOWN
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        destRect.Left = 0
        ImageRECT.Left = (Abs(xSrc) + xImage) * wZoom
        If ImageRECT.Left >= wImage Then Exit Sub
    End If
   
    If ySrc < 0 Then
        destRect.Top = 0
        ImageRECT.Bottom = destRect.Bottom * hZoom
    End If
 
    If Width + xSrc > g_MapW Then
        destRect.Right = g_MapW
        ImageRECT.Right = (g_MapW - xSrc) * wZoom
    End If
   
    If Height + ySrc > g_MapH Then
        destRect.Bottom = g_MapH
        ImageRECT.Top = (ySrc + Height - g_MapH) * hZoom
        If ImageRECT.Top >= hImage Then Exit Sub
    End If
   
    'If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    'If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan (2010-05-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_KEYSRC Or DDBLT_DDFX, FX)   'DDBLT_KEYSRC Or DDBLT_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_WAIT Or DDBLT_DDFX, FX) 'DDBLT_KEYSRC Or DDBLT_WAIT
    End If
End Sub
'*********************************************************************
'BltFxImage(DirectDrawSurface7变量,输出目标位置X、Y,W、H,择取源图X、Y,W、H,透明色作用开关)2010-06-28
Public Sub BltFxRImage(Image As DSurface, xSrc As Integer, ySrc As Integer, Width As Integer, Height As Integer, _
                    xImage As Integer, yImage As Integer, wImage As Integer, hImage As Integer, _
                    Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    Dim wZoom As Single, hZoom As Single   '目标、输出图像比例
    wZoom = wImage / Width
    hZoom = hImage / Height
    '-----------------源图像的大小------------------
    ImageRECT.Left = xImage
    ImageRECT.Top = yImage
    ImageRECT.Right = wImage
    ImageRECT.Bottom = hImage
    '-----------------目标图像的大小------------------
    destRect.Left = xSrc
    destRect.Top = ySrc
    destRect.Right = xSrc + Width
    destRect.Bottom = ySrc + Height
   
    'DDBLTFX图方向结构
    Dim FX As DDBLTFX
    FX.lDDFX = DDBLTFX_MIRRORLEFTRIGHT
    'FX.lDDFX = DDBLTFX_MIRRORUPDOWN
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        destRect.Left = 0
        ImageRECT.Right = (xSrc + Width) * wZoom
    End If
   
    If ySrc < 0 Then
        destRect.Top = 0
        ImageRECT.Top = (Abs(ySrc) + yImage) * hZoom
        If ImageRECT.Top >= hImage Then Exit Sub
    End If
 
    If Width + xSrc > g_MapW Then
        destRect.Right = g_MapW
        ImageRECT.Left = (Width + xSrc - g_MapW) * wZoom
        If ImageRECT.Left >= wImage Then Exit Sub
    End If
   
    If Height + ySrc > g_MapH Then
        destRect.Bottom = g_MapH
        ImageRECT.Bottom = (g_MapH - ySrc) * hZoom
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan (2010-05-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_KEYSRC Or DDBLT_DDFX, FX)   'DDBLT_KEYSRC Or DDBLT_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.BltFx(destRect, Image.Image, ImageRECT, DDBLT_WAIT Or DDBLT_DDFX, FX) 'DDBLT_KEYSRC Or DDBLT_WAIT
    End If
End Sub
'*********************************************************************
'BltImage(DirectDrawSurface7变量,输出目标位置X、Y,W、H,择取源图X、Y,W、H,透明色作用开关)2010-06-26
Public Sub BltImage(Image As DSurface, xSrc As Integer, ySrc As Integer, Width As Integer, Height As Integer, _
                    xImage As Integer, yImage As Integer, wImage As Integer, hImage As Integer, _
                    Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    Dim wZoom As Single, hZoom As Single   '目标、输出图像比例
    wZoom = wImage / Width
    hZoom = hImage / Height
    '-----------------源图像的大小------------------
    ImageRECT.Left = xImage
    ImageRECT.Top = yImage
    ImageRECT.Right = wImage
    ImageRECT.Bottom = hImage
    '-----------------目标图像的大小------------------
    destRect.Left = xSrc
    destRect.Top = ySrc
    destRect.Right = xSrc + Width
    destRect.Bottom = ySrc + Height
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        destRect.Left = 0
        ImageRECT.Left = (Abs(xSrc) + xImage) * wZoom
        If ImageRECT.Left >= wImage Then Exit Sub
    End If
   
    If ySrc < 0 Then
        destRect.Top = 0
        ImageRECT.Top = (Abs(ySrc) + yImage) * hZoom
        If ImageRECT.Top >= hImage Then Exit Sub
    End If
 
    If Width + xSrc > g_MapW Then
        destRect.Right = g_MapW
        ImageRECT.Right = (g_MapW - xSrc) * wZoom
    End If
   
    If Height + ySrc > g_MapH Then
        destRect.Bottom = g_MapH
        ImageRECT.Bottom = (g_MapH - ySrc) * hZoom
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan (2010-05-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.Blt(destRect, Image.Image, ImageRECT, DDBLT_KEYSRC)   'DDBLT_KEYSRC Or DDBLT_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.Blt(destRect, Image.Image, ImageRECT, DDBLT_WAIT) 'DDBLT_KEYSRC Or DDBLT_WAIT
    End If
End Sub
'*********************************************************************
'BltImage(DirectDrawSurface7变量,输出目标位置X、Y,择取源图X、Y,W、H,透明色作用开关)2010-06-26
Public Sub BltFastImage(Image As DSurface, xSrc As Integer, ySrc As Integer, _
                    xImage As Integer, yImage As Integer, Width As Integer, Height As Integer, _
                    Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    '-----------------输出图像的大小------------------
    ImageRECT.Left = xImage
    ImageRECT.Top = yImage
    ImageRECT.Right = xImage + Width
    ImageRECT.Bottom = yImage + Height
   
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        BX = 0
        ImageRECT.Left = Abs(xSrc) + xImage
        If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    End If
   
    If ySrc < 0 Then
        BY = 0
        ImageRECT.Top = Abs(ySrc) + yImage
        If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    End If
 
    If Width + xSrc > g_MapW Then
        ImageRECT.Right = xImage - xSrc + g_MapW
    End If
   
    If Height + ySrc > g_MapH Then
        ImageRECT.Bottom = yImage - ySrc + g_MapH
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan(2010-5-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_SRCCOLORKEY)  'DDBLTFAST_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_WAIT)  'DDBLTFAST_SRCCOLORKEY
    End If
End Sub
'************************画出所有**************************************
'BltImageAll(图像,X,Y,透明色作用开关)
Public Sub BltImageAll(Image As DSurface, xSrc As Integer, ySrc As Integer, Optional UseColorkey As Boolean = False)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = xSrc
    BY = ySrc
    '-----------------输出图像的大小------------------
    ImageRECT.Left = 0
    ImageRECT.Top = 0
    ImageRECT.Right = Image.W
    ImageRECT.Bottom = Image.H
   
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If xSrc < 0 Then
        BX = 0
        ImageRECT.Left = Abs(xSrc)
        If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    End If
   
    If ySrc < 0 Then
        BY = 0
        ImageRECT.Top = Abs(ySrc)
        If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    End If
 
    If Image.W + xSrc > g_MapW Then
        ImageRECT.Right = g_MapW - xSrc
    End If
   
    If Image.H + ySrc > g_MapH Then
        ImageRECT.Bottom = g_MapH - ySrc
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    'liuhan(2010-5-21)
    If UseColorkey = True Then
        '透明绘图(yes)
        Call BackSurf.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_SRCCOLORKEY)  'DDBLTFAST_WAIT
    Else
        '透明绘图(no)
        Call BackSurf.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_WAIT)  'DDBLTFAST_SRCCOLORKEY
    End If
End Sub
'1━━━━━━━━《字体输出》━━━━━━━
Public Sub PrintText(Text As String, x As Integer, y As Integer, _
Optional FontSize As Integer = 10, Optional Color As Long = 0)
    Font.Size = FontSize
    BackSurf.SetFont Font
    BackSurf.SetForeColor Color
    BackSurf.DrawText x, y, Text, False
End Sub
'1━━━━━━━━《初始化Gamea色彩控制(只适用于全屏独占模式)》━━━━━━━
Private Sub initGamma()
    Dim mmap As DDGAMMARAMP
    Set Gamea = MainSurf.GetDirectDrawGammaControl
    Call Gamea.GetGammaRamp(DDSGR_DEFAULT, mmap)
End Sub
'2.1━━━━━━━━━━━━━━━━全屏下淡入━━━━━━━━━━━━━━━━
Public Sub FadeIn()
    Dim NewGammamp As DDGAMMARAMP, i As Integer, j As Integer, K As Long
   
    For i = 256 To 0 Step -8
        For j = 0 To 255
            K = CLng(j) * CLng(i)
            If K > 32767 Then K = K - 65536
            NewGammamp.red(j) = K
            NewGammamp.green(j) = K
            NewGammamp.blue(j) = K
        Next j
        Call Gamea.SetGammaRamp(DDSGR_DEFAULT, NewGammamp)
    Next i
End Sub
'2.2━━━━━━━━━━━━━━━━全屏下淡出━━━━━━━━━━━━━━━━
Public Sub FadeOut()
    Dim NewGammamp As DDGAMMARAMP, i As Integer, j As Integer, K As Long
   
    For i = 0 To 256 Step 8
        For j = 0 To 255
            K = CLng(j) * CLng(i)
            If K > 32767 Then K = K - 65536
            NewGammamp.red(j) = K
            NewGammamp.green(j) = K
            NewGammamp.blue(j) = K
        Next j
        Call Gamea.SetGammaRamp(DDSGR_DEFAULT, NewGammamp)
    Next i
End Sub
'end━━━━━━━━━━━━━━绘制画面显示到屏幕━━━━━━━━━━━━━━
Public Sub BltScreen()
    Call Dx.GetWindowRect(BlthWnd, destRect)
    If goFull = False And BlthWnd = ObjhWnd Then
        destRect.Top = destRect.Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME)
        'destRect.Bottom = destRect.Bottom + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME)
        destRect.Left = destRect.Left + GetSystemMetrics(SM_CXFRAME)
        destRect.Right = destRect.Right + GetSystemMetrics(SM_CXFRAME)
    End If
   
    Call MainSurf.Blt(destRect, BackSurf, srcRect, DDBLT_WAIT)
    Call BackSurf.BltColorFill(srcRect, 0)
End Sub
'1━━━━━━━回恢丢失页面(用于全屏模式，必须写在循环中)━━━━━━━━
Private Function ExclusiveMode() As Boolean
    Dim lngTestExMode As Long
   
    'This function tests if we're still in exclusive mode
    lngTestExMode = DDraw.TestCooperativeLevel
   
    If (lngTestExMode = DD_OK) Then
        ExclusiveMode = True
    Else
        ExclusiveMode = False
    End If
   
End Function
'2━━━━━━━回恢丢失页面(用于全屏模式，必须写在循环中)━━━━━━━━
Public Function LostSurfaces() As Boolean
    'This function will tell if we should reload our bitMapAZ or not
    LostSurfaces = False
    Do Until ExclusiveMode
        DoEvents
        LostSurfaces = True
    Loop
   
    'If we did lose our bitMapAZ, restore the surfaces and return 'true'
    DoEvents
    If LostSurfaces Then
        DDraw.RestoreAllSurfaces
    End If
   
End Function
'=========================初始化键盘和鼠标处理=======================
Private Sub InitDI(hwnd As Long)
    Set DI = Dx.DirectInputCreate() ' Create the DirectInput Device
    Set KeyDevice = DI.CreateDevice("GUID_SysKeyboard") ' Set it to use the keyboard.
    KeyDevice.SetCommonDataFormat DIFORMAT_KEYBOARD ' Set the data format to the keyboard format
    KeyDevice.SetCooperativeLevel hwnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE ' Set Cooperative level
    KeyDevice.Acquire
   
    Set dimouse = DI.CreateDevice("guid_sysmouse")
    dimouse.SetCommonDataFormat DIFORMAT_MOUSE
    dimouse.SetCooperativeLevel hwnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    dimouse.Acquire
End Sub
'功能:返回鼠标X坐标
Public Function MouseX() As Long
    Dim t As POINTAPI
    Dim client As RECT
    GetCursorPos t
    GetClientRect ObjhWnd, client
    ScreenToClient ObjhWnd, t
    MouseX = t.x * g_MapW / client.Right
    If t.x < client.Left Then MouseX = 0
    If t.x > client.Right Then MouseX = client.Right
End Function
'功能:返回鼠标Y坐标
Public Function MouseY() As Long
    Dim t As POINTAPI
    Dim client As RECT
    GetCursorPos t
    GetClientRect ObjhWnd, client
    ScreenToClient ObjhWnd, t
    MouseY = t.y * g_MapH / client.Bottom
    If t.y < client.Top Then MouseY = 0
    If t.y > client.Bottom Then MouseY = client.Bottom
End Function
'1━━━━━━━━━━━━━初始化WAV(音效处理)━━━━━━━━━━━━━
Private Sub InitWav(hwnd As Long)
    Set DSound = Dx.DirectSoundCreate("")
    DSound.SetCooperativeLevel hwnd, DSSCL_PRIORITY
End Sub
'2━━━━━━━━━━━━━━装入Wav音效文件━━━━━━━━━━━━━━
Public Function LoadWav(FileName As String) As DirectSoundBuffer
    Dim BufferDesc As DSBUFFERDESC
    Dim WaveFormat As WAVEFORMATEX
   
    BufferDesc.lFlags = DSBCAPS_CTRLVOLUME Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPOSITIONNOTIFY
    Set LoadWav = DSound.CreateSoundBufferFromFile(FileName, BufferDesc, WaveFormat)
End Function
'3━━━━━━━━━━━━━━播放Wav音效文件━━━━━━━━━━━━━━
Public Sub PlayWav(Sound As DirectSoundBuffer, nClose As Boolean, LoopSound As Boolean)
    If nClose Then
      Sound.Stop
      Sound.SetCurrentPosition 0
    End If
 
    If LoopSound Then
      Sound.Play 1
    Else
      Sound.Play 0
    End If
End Sub
'4━━━━Wav音量（-10000-0）声道控制（左-10000至右10000调节）━━━━━
Public Sub SetWav(Sound As DirectSoundBuffer, Optional VolumeValue As Integer, Optional PanValue As Integer)
    If PanValue > 10000 Then VolumeValue = 10000
    If PanValue < -10000 Then VolumeValue = -10000
    Sound.SetPan PanValue
    If VolumeValue > 0 Then VolumeValue = 0
    If VolumeValue < -10000 Then VolumeValue = -10000
    Sound.SetVolume VolumeValue
End Sub
'1━━━━━━━━━━━━━━初始化MID设置━━━━━━━━━━━━━━
Private Sub InitMid()
    '建立directmusicloader对象
    Set objdmloader = Dx.DirectMusicLoaderCreate
    '建立directmusicperformance对象
    Set objdmperf = Dx.DirectMusicPerformanceCreate
    '初始化directmusicperformance对象
    objdmperf.Init Nothing, 0
    objdmperf.SetPort -1, 80
    objdmperf.SetMasterAutoDownload True
    objdmperf.SetMasterVolume 0
End Sub
'2━━━━━━━━━━━━━━装入midi文件━━━━━━━━━━━━━━
Public Sub LoadMid(FileName As String)
    Set objdmseg = Nothing
    Set objdmseg = objdmloader.LoadSegment(FileName)
End Sub
'3━━━━━━━━━━━━━━播放midi文件━━━━━━━━━━━━━━
Public Sub PlayMid(Optional Play As Boolean = True, Optional Start As Long)
    If Play = True Then
        If objdmperf.IsPlaying(objdmseg, objdmsegst) = True Then
            '停止播放
            Call objdmperf.Stop(objdmseg, objdmsegst, 0, 0)
        End If
        objdmseg.SetStartPoint (Start)
        Set objdmsegst = objdmperf.PlaySegment(objdmseg, 0, 0)
    Else
        '停止播放midi文件
        Call objdmperf.Stop(objdmseg, objdmsegst, 0, 0)
    End If
End Sub
'4━━━━━━━━━━━━━━播放midi音量,节奏频率━━━━━━━━━━━━━━
Public Sub SetMid(Optional VolumeValue As Integer, Optional TempoValue As Integer)
    If VolumeValue > 0 Then VolumeValue = 0
    If VolumeValue < -10000 Then VolumeValue = -10000
    Call objdmperf.SetMasterVolume(VolumeValue)
    Call objdmperf.SetMasterTempo(TempoValue)
End Sub
'=========================================================
'*****************《控帧》*******************
Public Sub ControlFPS(Time As Integer)
    Do While GetTickCount - FPS_Count < Time
        DoEvents
    Loop
    FPS_Count = GetTickCount
End Sub
 
 '***************《获得速度》*****************
Public Function GetFPSx() As Integer
    If GetTickCount() - mTimer >= 1000 Then
        mTimer = GetTickCount
        GetFPSx = AddFPS + 1
        AddFPS = 0
    Else
        AddFPS = AddFPS + 1
    End If
End Function
 '***************《获得速度》*****************
Public Sub GetFPS() '(FPS As Integer)
    If GetTickCount() - mTimer >= 1000 Then
        mTimer = GetTickCount
        FPS = AddFPS + 1
        AddFPS = 0
    Else
        AddFPS = AddFPS + 1
    End If
End Sub
'======================退出Engine=========================
Public Sub ExitEngine()
    'ExitDDraw
    Call DDraw.RestoreDisplayMode
    Call DDraw.SetCooperativeLevel(ObjhWnd, DDSCL_NORMAL)
    Set BackSurf = Nothing
    Set MainSurf = Nothing
    Set Dx = Nothing
    Set Gamea = Nothing
    'ExitMid
    Set objdmsegst = Nothing
    Set objdmseg = Nothing
    Set objdmperf = Nothing
    Set objdmloader = Nothing
    'ExitDI
    Set DI = Nothing
    Set KeyDevice = Nothing
    Set dimouse = Nothing
    'ExitWav
    Set DSound = Nothing
   
    Set StdFont = Nothing
    Set Font = Nothing
End Sub