Option Explicit

'**************************************************************
'
'                        《梦想之翼》
'
'VB+DirectX7编写，包括图像、键盘、鼠标、声音处理。
'
'经过多次改进和完善，是一个比较易用的引擎。
'
'                                    ----作者：袁进峰
'
'                                        2004年9月13日
'
'**************************************************************

'=========================《鼠标指针位置》======================
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
    X As Long
    Y As Long
End Type
'========================《显示或隐藏鼠标》=====================
Public Declare Function ShowCursor Lib "user32" (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 Long
'==============================================================
Public Type POS
    X As Integer
    Y As Integer
End Type
'==============================================================

Dim ObjhWnd As Long
Dim BlthWnd As Long

Dim Dx As New DirectX7
Dim DDraw As DirectDraw7

Public KeJianMian As DirectDrawSurface7
Public HuanChong 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

'初始化DDraw
Public Sub InitEngine(FormhWnd As Long, _
Optional Width As Integer, Optional Height As Integer, _
Optional FullScreen As Boolean = False, _
Optional FWidth As Integer = 640, Optional FHeight As Integer = 480, _
Optional Color As Integer = 16)
    g_MapW = Width
    g_MapH = Height
    ObjhWnd = FormhWnd
    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)
    End If
    '======================================================================
    '定义变量
    Dim ddsd As DDSURFACEDESC2
    '========================《设置主表面》================================
    ddsd.lFlags = DDSD_CAPS 'Or DDSD_BACKBUFFERCOUNT
    ddsd.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
    Set KeJianMian = 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 HuanChong = DDraw.CreateSurface(ddsd)
    '==========================《初始化字体》==============================
    Set Font = StdFont
    Font.Name = "宋体"
    '************************************************************
    Call InitDI(FormhWnd)
    Call InitMid
    Call initGamma
End Sub

'===========================《Gamea色彩控制》==========================
Sub initGamma()
    Dim mmap As DDGAMMARAMP
    Set Gamea = KeJianMian.GetDirectDrawGammaControl
    Call Gamea.GetGammaRamp(DDSGR_DEFAULT, mmap)
End Sub

'=======================《剪切》=======================================
'窗体调用成功后，调用，必写
Public Sub ClipperhWnd(hWnd As Long)
    BlthWnd = hWnd
    Set Clipper = DDraw.CreateClipper(0)
    Clipper.SetHWnd hWnd
    KeJianMian.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
    '设置透明色
    Dim key As DDCOLORKEY
    key.low = Color
    key.high = Color
    Call LoadImage.Image.SetColorKey(DDCKEY_SRCBLT, key)
    Exit Function
LoadImageErr:
    MsgBox "没有找到" + FileName + "图像文件。"
End Function

'*********************************************************************
'BltImage(DirectDrawSurface7变量,输X,输Y,宽,高,取X,取Y)
Public Sub BltImage(Image As DSurface, X1 As Integer, Y1 As Integer, _
Width As Integer, Height As Integer, Optional X2 As Integer, _
Optional Y2 As Integer)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = X1
    BY = Y1
    '-----------------输出图像的大小------------------
    ImageRECT.Left = X2
    ImageRECT.Top = Y2
    ImageRECT.Right = Width + X2
    ImageRECT.Bottom = Height + Y2
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If X1 < 0 Then
        BX = 0
        ImageRECT.Left = Abs(X1) + X2
        If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    End If
   
    If Y1 < 0 Then
        BY = 0
        ImageRECT.Top = Abs(Y1) + Y2
        If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    End If
 
    If Width + X1 > g_MapW Then
        ImageRECT.Right = X2 - X1 + g_MapW
    End If
   
    If Height + Y1 > g_MapH Then
        ImageRECT.Bottom = Y2 - Y1 + g_MapH
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    '透明绘图
    Call HuanChong.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_SRCCOLORKEY)  'DDBLTFAST_WAIT
End Sub

'************************画出所有**************************************
'BltImageAll(图像,X,Y)
Public Sub BltImageAll(Image As DSurface, X1 As Integer, Y1 As Integer)
    Dim ImageRECT As RECT              '输入输出时图像的大小
    Dim BX As Integer, BY As Integer   '输出图像的位置
    BX = X1
    BY = Y1
    '-----------------输出图像的大小------------------
    ImageRECT.Left = 0
    ImageRECT.Top = 0
    ImageRECT.Right = Image.W
    ImageRECT.Bottom = Image.H
   
    '自己做的自动剪切处理，比DirectX提供的快很多
    '----------------若碰边自动剪切--------------------
    If X1 < 0 Then
        BX = 0
        ImageRECT.Left = Abs(X1)
        If ImageRECT.Left >= ImageRECT.Right Then Exit Sub
    End If
   
    If Y1 < 0 Then
        BY = 0
        ImageRECT.Top = Abs(Y1)
        If ImageRECT.Top >= ImageRECT.Bottom Then Exit Sub
    End If
 
    If Image.W + X1 > g_MapW Then
        ImageRECT.Right = g_MapW - X1
    End If
   
    If Image.H + Y1 > g_MapH Then
        ImageRECT.Bottom = g_MapH - Y1
    End If
    '一点也没出画出来
    If ImageRECT.Right <= 0 Or ImageRECT.Bottom <= 0 Then Exit Sub
    '-------------------------------------------------
    '透明绘图
    Call HuanChong.BltFast(BX, BY, Image.Image, ImageRECT, DDBLTFAST_SRCCOLORKEY)  'DDBLTFAST_WAIT
End Sub

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
    HuanChong.SetFont Font
    HuanChong.SetForeColor Color
    HuanChong.DrawText X, Y, Text, False
End Sub

'全屏下淡入
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

'全屏下淡出
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

Sub BltScreen()
    Call Dx.GetWindowRect(BlthWnd, destRect)
    Call KeJianMian.Blt(destRect, HuanChong, srcRect, DDBLT_WAIT)
End Sub

'=========================键盘和鼠标处理=======================
Public 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

'========================音效处理==============================
Public Sub InitWav(hWnd As Long)
    Set DSound = Dx.DirectSoundCreate("")
    DSound.SetCooperativeLevel hWnd, DSSCL_PRIORITY
End Sub

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 CreSound = DSound.CreateSoundBufferFromFile(FileName, BufferDesc, WaveFormat)

End Function

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

'===========================播放MID函数===============================
Public 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

Public Sub LoadMid(FileName As String)
    Set objdmseg = Nothing
    Set objdmseg = objdmloader.LoadSegment(FileName)
End Sub
 
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

Public Sub ScrollMid(Optional Value As Integer)
    Call objdmperf.SetMasterVolume(Value)
End Sub

'=========================================================
'*****************《控帧》*******************
Public Sub ControlFPS(Time As Integer)
    Do While GetTickCount - FPS_Count < Time
        DoEvents
    Loop
    FPS_Count = GetTickCount
End Sub

'***************《获得速度》*****************
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 HuanChong = Nothing
    Set KeJianMian = 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