A piece of code found on the Internet can be changed to DX8 and DX12 if you are interested, and a simplest game interface can be realized as a learning reference for learning VB6 game development and TWINBASIC DirectX tlb development.
The original Chinese notes are kept, please translate them into English by Google or CHATGPT.
=================
DX7 for VB6 Game Engine Enhanced Edition
B+DirectX7, including image, keyboard, mouse and sound processing.
'
After many improvements and perfection, it is an easy-to-use engine.
'
-Author: Yuan Jinfeng
September 13, 2004
-Strengthening: liuhan
Re: DirectX7 DX7 for VB6 Game Engine Enhanced Edition
CODE:
Code:
' ??????
'
'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
Re: DirectX7 DX7 for VB6 Game Engine Enhanced Edition
code2:
Code:
'************************????**************************************
'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
Reply With Quote