DX7游戲引擎（夢想之翼） for VB6
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
浙公網安備 33010602011771號