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)
文章整理：西部数码--专业提供域名注册、虚拟主机服务
http://www.west263.com
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!
