VB中使用DirectX库的简明教程(3)

ddsd1.lBackBufferCount = 1
ddsd1.ddsCaps.lCaps = DDSCAPS_COMPLEX Or DDSCAPS_FLIP Or DDSCAPS_PRIMARYSURFACE
'设置缓冲绘图平面的属性
ddsd2.ddsCaps.lCaps = DDSCAPS_BACKBUFFER

'根据ddsd1建立主绘图平面
Set MainSurf = objDraw.CreateSurface(ddsd1)
'将BackSurf设置为MainSurf的附加平面
Set BackSurf = MainSurf.GetAttachedSurface(ddsd2.ddsCaps)
'设置背景绘图平面的字体和颜色
BackSurf.SetForeColor RGB(255, 255, 255)
Form1.Font.Name = "宋体"
BackSurf.SetFont Form1.Font

'获得缓冲绘图平面的属性并设置到ddsd4中
BackSurf.GetSurfaceDesc ddsd4
'设置图形绘图平面的属性
ddsd3.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsd3.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsd3.lWidth = ddsd4.lWidth
ddsd3.lHeight = ddsd4.lHeight
'建立图形绘图平面
Set BmpSurf = objDraw.CreateSurfaceFromFile(App.Path "\demo.bmp", ddsd3)

'设定角色位图平面的属性
ddsd5.lFlags = DDSD_CAPS
ddsd5.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
'建立角色位图平面
Set SpriteSurf = objDraw.CreateSurfaceFromFile(App.Path "\sprite.bmp", ddsd5)

Dim key As DDCOLORKEY
'设定透明色（在这里设定为0，黑色）
key.low = 0
key.high = 0
SpriteSurf.SetColorKey DDCKEY_SRCBLT, key
sx = 20: sy = 20

lastTime = objDx.TickCount

While True
DoEvents
Blt
Wend
ErrHandler:
Select Case Err.Number
Case 0 ''No Errors
Case Else '错误退出
Call Cleanup
End Select
End Sub
Sub Blt()
Dim mrectScreen As RECT
Dim sTimePass As Single
Dim sFramePerS As Single

'以黑色清除并填充后台绘图平面
BackSurf.BltColorFill mrectScreen, 0

'获得背景位图平面的矩形区域的尺寸
mrectScreen.Right = ddsd2.lWidth
mrectScreen.Bottom = ddsd2.lHeight
'将图形绘图平面中的内容复制到后台绘图平面上
Call BackSurf.BltFast(0, 0, BmpSurf, mrectScreen, DDBLTFAST_WAIT)

'获得前景角色位图平面的矩形区域
mrectScreen.Right = ddsd5.lWidth
mrectScreen.Bottom = ddsd5.lHeight
'将前景角色位图复制到后台绘图平面上。
Call BackSurf.BltFast(sx, sy, SpriteSurf, mrectScreen, DDBLTFAST_SRCCOLORKEY)
sx = sx 2: sy = sy 2
If sx > 400 Then sx = 20
If sy > 400 Then sy = 20

'在后台绘图平面上输出文本
BackSurf.DrawText 30, 30, "This is my first DirectX program", False
BackSurf.DrawText 30, 60, "点击屏幕退出程序", False

'获得每秒的播放帧数。
FrameCount = FrameCount 1
sTimePass = (objDx.TickCount - lastTime) / 1000
If sTimePass > 0.5 Then
sFramePerS = FrameCount / sTimePass
End If
BackSurf.DrawText 30, 90, "每秒帧数：" Format$(sFramePerS, "##00.0"), False

'将后台绘图平面上的内容翻转到前台来
MainSurf.Flip Nothing, DDFLIP_WAIT
End Sub
Private Function SetNewDisplayMode()
On Error GoTo ErrHandler

Dim i As Long

i = List1.ListIndex
If i = -1 Then
MsgBox "请在列表中选择一种显示模式", vbOKOnly, "错误"
Exit Function
End If

'获得用户选择的显示模式
objEnumModes.GetItem (i 1), ddsd

''设置协作模式
objDraw.SetCooperativeLevel Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX _
Or DDSCL_EXCLUSIVE

''设置显示模式
objDraw.SetDisplayMode ddsd.lWidth, ddsd.lHeight, ddsd.ddpfPixelFormat.lRGBBitCount, _
0, DDSDM_DEFAULT

Me.Refresh
ErrHandler:
Select Case Err.Number
Case 0 ''No Errors
Case Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpContext, _
Err.HelpContext
Call Cleanup
End Select
End Function

Sub Cleanup() 'Cleanup函数回复屏幕并且清除DirectX对象
Call objDraw.RestoreDisplayMode
Call objDraw.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
Set objDraw = Nothing
Set objDx = Nothing
End
End Sub

Private Sub Command1_Click()
End
End Sub

Private Sub Command2_Click()
Dim i

For i = 0 To Form1.Controls.Count - 1
Form1.Controls(i).Visible = False
Next i

SetNewDisplayMode
InitSurf
End Sub

Private Sub Form_Click()
Cleanup
End Sub

Private Sub Form_Load()
Command1.Caption = "结束"
Command2.Caption = "设置显示模式"

On Error GoTo ErrHandler:

Dim ddsd As DDSURFACEDESC2
Dim i As Long, lgCount As Long

Set objDx = New DirectX7
'建立 DirectDraw 对象
Set objDraw = objDx.DirectDrawCreate("")

'将DirectDraw对象支持的显示模式设置到DirectDrawEnumModes对象中
Set objEnumModes = objDraw.GetDisplayModesEnum(DDEDM_DEFAULT, ddsd)

'将数据设置到ListBox中
lgCount = objEnumModes.GetCount()
For i = 1 To lgCount
objEnumModes.GetItem i, ddsd
List1.AddItem CStr(ddsd.lWidth) & "x" & CStr(ddsd.lHeight) & "x" _
& CStr(ddsd.ddpfPixelFormat.lRGBBitCount)

标签：

版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有