DX7 GameEngine for VB6
Option Explicit
'Dx7迟早会被更高的版替代，所以您无需明白下面的代码。
'=========================《DX程序组》==================================
' ---作者袁进峰
'此程序没有进行控帧，如大家有控帧的程序，希望可以告诉我。
'E_mail:mengxiangcn2003@yahoo.com.cn
'变量前的"DxVBlib"可以省去。
Dim Dx As New DirectX7
Dim DDraw As DirectDraw7
Dim KeJianMian As DxVBLib.DirectDrawSurface7
Dim HuanChong As DxVBLib.DirectDrawSurface7
Dim Clipper As DxVBLib.DirectDrawClipper
Dim Pic As PictureBox
Dim Gamea As DxVBLib.DirectDrawGammaControl
Dim mmap As DxVBLib.DDGAMMARAMP
Dim BBB As DxVBLib.RECT
Dim DDD As DxVBLib.RECT
Dim DI As DxVBLib.DirectInput
Public DI_Device As DxVBLib.DirectInputDevice
Public DI_State As DxVBLib.DIKEYBOARDSTATE
Public dimouse As DxVBLib.DirectInputDevice
Public dismouse As DxVBLib.DIMOUSESTATE
Dim DSound As DxVBLib.DirectSound
Dim objdmloader As DxVBLib.DirectMusicLoader
Dim objdmperf As DxVBLib.DirectMusicPerformance
Dim objdmseg As DxVBLib.DirectMusicSegment
Public objdmsegst As DxVBLib.DirectMusicSegmentState
Public MusicMax As Long
Dim G_MapW As Integer
Dim G_MapH As Integer
Dim lasttime As Long
Dim framecount As Long
'初始化DDraw
Sub InitDraw(Picbox As PictureBox, Width As Integer, Height As Integer, _
Optional FullScreen As Boolean = False, Optional FWidth As Integer = 800, _
Optional FHeight As Integer = 600, Optional Se As Integer = 16)
Set Pic = Picbox
G_MapW = Width
G_MapH = Height
Set DDraw = Dx.DirectDrawCreate("")
'========================《设置显示模式》===========================================
If FullScreen = True Then
Call DDraw.SetCooperativeLevel(Form1.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE)
Call DDraw.SetDisplayMode(FWidth, FHeight, Se, 0, DDSDM_DEFAULT)
Else
Call DDraw.SetCooperativeLevel(Form1.hWnd, 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 Clipper = DDraw.CreateClipper(0)
Clipper.SetHWnd Pic.hWnd
KeJianMian.SetClipper Clipper
'===========================《Gamea色彩控制》=======================================
Set Gamea = KeJianMian.GetDirectDrawGammaControl
Call Gamea.GetGammaRamp(DDSGR_DEFAULT, mmap)
End Sub
'载入图像过程
Sub BmpCopy(Image As DirectDrawSurface7, FileName As String, _
Optional TouMing As Boolean = True, Optional Se As Long = &HF81F)
Dim ddsd As DDSURFACEDESC2
ddsd.lFlags = DDSD_CAPS
ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
'装载图像
Set Image = DDraw.CreateSurfaceFromFile(FileName, ddsd)
'图像是否透明
If TouMing = True Then
Dim key As DDCOLORKEY
key.low = Se
key.high = Se
Call Image.SetColorKey(DDCKEY_SRCBLT, key)
End If
End Sub
'把图像画在"纸"上
Sub ShuChu(Image As DirectDrawSurface7, X1 As Integer, Y1 As Integer, _
Width As Integer, Height As Integer, Optional X2 As Integer, _
Optional Y2 As Integer, Optional TouMing As Boolean = True)
Dim Sr As RECT
Dim Dr As RECT
'==================输出图像的大小==================
Sr.Left = X2
Sr.Top = Y2
Sr.Right = Width + X2
Sr.Bottom = Height + Y2
'==================输入图像的大小=========================
Dr.Left = X1
Dr.Top = Y1
'==================若碰边自动剪切==========================
If X1 < 0 Then
Sr.Left = Abs(Dr.Left) + X2
If Sr.Left > Sr.Right Then Sr.Left = Sr.Right
Dr.Left = 0
End If
If Y1 < 0 Then
Sr.Top = Abs(Dr.Top) + Y2
If Sr.Top > Sr.Bottom Then Sr.Top = Sr.Bottom
Dr.Top = 0
End If
If Width + X1 > G_MapW Then If X2 - X1 + G_MapW > 0 Then Sr.Right = X2 - X1 + G_MapW
If Height + Y1 > G_MapH Then If Y2 - Y1 + G_MapH > 0 Then Sr.Bottom = Y2 - Y1 + G_MapH
'==========================================================
If TouMing = True Then
Call HuanChong.BltFast(Dr.Left, Dr.Top, Image, Sr, DDBLTFAST_SRCCOLORKEY)
Else
Call HuanChong.BltFast(Dr.Left, Dr.Top, Image, Sr, DDBLTFAST_WAIT)
End If
End Sub
Sub PrintText(X As Integer, Y As Integer, Text As String, Optional FontSize As Integer, Optional Se As Long = 0)
With Pic.Font
.Name = "宋体"
.Size = FontSize
End With
HuanChong.SetFont Pic.Font
HuanChong.SetForeColor Se
HuanChong.DrawText X, Y, Text, False
End Sub
Sub DrawBox(X As Integer, Y As Integer, Width As Integer, Height As Integer, Se As Long)
HuanChong.SetForeColor Se
HuanChong.DrawBox X, Y, Width + X, Height + Y
End Sub
Sub DDrawCls()
HuanChong.BltColorFill BBB, 0
End Sub
Sub BltScreen()
Call Dx.GetWindowRect(Pic.hWnd, BBB)
Call KeJianMian.Blt(BBB, HuanChong, DDD, DDBLT_WAIT)
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 InitDI()
Set DI = Dx.DirectInputCreate() ' Create the DirectInput Device
Set DI_Device = DI.CreateDevice("GUID_SysKeyboard") ' Set it to use the keyboard.
DI_Device.SetCommonDataFormat DIFORMAT_KEYBOARD ' Set the data format to the keyboard format
DI_Device.SetCooperativeLevel Form1.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE ' Set Cooperative level
DI_Device.Acquire
Set dimouse = DI.CreateDevice("guid_sysmouse")
dimouse.SetCommonDataFormat DIFORMAT_MOUSE
dimouse.SetCooperativeLevel Form1.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
dimouse.Acquire
End Sub
'=========================================================================================================================
'====================================音效处理==============================================================================
Sub InitSound()
Set DSound = Dx.DirectSoundCreate("")
DSound.SetCooperativeLevel Form1.hWnd, DSSCL_PRIORITY
End Sub
Function CreSound(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
Sub PlaySound(Sound As DirectSoundBuffer, CloseFirst As Boolean, LoopSound As Boolean)
If CloseFirst Then
Sound.Stop
Sound.SetCurrentPosition 0
End If
If LoopSound Then
Sound.Play 1
Else
Sound.Play 0
End If
End Sub
Sub RollWav(Sound As DirectSoundBuffer, Roll As Integer)
Sound.SetVolume -Roll
End Sub
'=========================================播放MID函数====================================================
Sub InitMid(FileName As String)
'建立directmusicloader对象
Set objdmloader = Dx.DirectMusicLoaderCreate
'建立directmusicperformance对象
Set objdmperf = Dx.DirectMusicPerformanceCreate
'初始化directmusicperformance对象
objdmperf.Init Nothing, 0
objdmperf.SetPort -1, 80
objdmperf.SetMasterAutoDownload (True)
objdmperf.SetMasterVolume (-2800)
Set objdmseg = objdmloader.LoadSegment(FileName)
MusicMax = objdmseg.GetLength
End Sub
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
Sub RollMid(Roll As Integer)
objdmperf.SetMasterVolume (-2800 + Roll)
End Sub
'=================================退出Directx====================================
Sub ExitDirectx()
'ExitDDraw
Call DDraw.RestoreDisplayMode
Call DDraw.SetCooperativeLevel(Form1.hWnd, 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 DI_Device = Nothing
Set dimouse = Nothing
'ExitWav
Set DSound = Nothing
End Sub
Sub DxLast()
lasttime = Dx.TickCount
End Sub
Function DxFPS() As String
Dim stimepass As Single
Dim sframepers As Single
'获得每秒的播放帧数。
framecount = framecount + 1
stimepass = (Dx.TickCount - lasttime) / 1000
If stimepass > 0.5 Then
sframepers = framecount / stimepass
End If
DxFPS = Format$(sframepers, "##00.0")
End Function
