Dim PosPlus1 As Long
Dim PosPlus2 As Long
Dim PosPlus3 As Long
Public Pal(255) As PALETTEENTRY
Public Palette As DirectDrawPalette
Public BlitRect As RECT
Public FullSize As Boolean
Public ExitLoop As Boolean
Dim Accum As Long
Dim Msg(9) As String
Dim Counter As Long
Dim MsgIndex As Long
Dim bDrawText As Boolean
Dim lastTime As Long
Dim XPos As Long, YPos As Long
Dim wait As Long
Dim Angle As Single
Dim Flag As Boolean
Dim Count As Long
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean
Dim Mode As Boolean
Private Sub Main()
InitializeDX
'初始化Picture1以获得DirectDraw界面图像
With MainForm.Picture1 .Width = 640 ＊ Screen.TwipsPerPixelX .Height = 480 ＊ Screen.TwipsPerPixelY
End With
DDSBack.SetForeColor RGB(255, 255, 255)
MainForm.Font.Name = “宋体”
DDSBack.SetFont MainForm.Font
Msg(0) =“一个显示火焰字的演示”
Msg(1) =“演示”
Msg(2) =“利用VB阵列”
Msg(3) =“对显示内存”
Msg(4) =“进行直接存取”
Msg(5) =“{Esc}键退出”
'设置8位的调色板
For Index = 0 To 84
Pal(Index ＋ 1).red = Index ＊ 3 ＋ 3
Pal(Index ＋ 1).green = 0
Pal(Index ＋ 1).blue = 0
Pal(Index ＋ 86).red = 255
Pal(Index ＋ 86).green = Index ＊ 3 ＋ 3
Pal(Index ＋ 86).blue = 0
Pal(Index ＋ 171).red = 255
Pal(Index ＋ 171).green = 255
Pal(Index ＋ 171).blue = Index ＊ 3 ＋ 3
Next
Set Palette = DDraw.CreatePalette(DDPCAPS_8BIT _ Or DDPCAPS_ALLOW256, Pal())
DDSFront.SetPalette Palette
AlphaRect.Right = DDSBackDesc.lWidth － 1
AlphaRect.Bottom=DDSBackDesc.lHeight－ 1
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For X = 0 To 639
For Y = 0 To 479
Pict(X, Y) = 0
Next
Next
'Corresponding unlock
DDSBack.Unlock AlphaRect
While Not ExitLoop
Mode = ExModeActive
bRestore = False
Do Until ExModeActive
DoEvents
bRestore = True
Loop
DoEvents
If bRestore Then
bRestore = False
DDraw.RestoreAllSurfaces
End If
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For Y = 0 To 479
Pict(0, Y) = 0
Pict(639, Y) = 0
Next
For X = 0 To 639
Pict(X, 477) = Rnd ＊ 220 ＋ 35
Pict(X, 478) = Rnd ＊ 220 ＋ 35
Pict(X, 479) = Rnd ＊ 220 ＋ 35
Next
Accum = 0
For X = 1 To 638
For Y = 0 To 477
Accum = (Accum ＋ Pict(X, Y ＋ 1) _
＋ Pict(X, Y ＋ 2) _
＋ Pict(X ＋ 1, Y ＋ 1) _
＋ Pict(X － 1, Y ＋ 1)) \ 5
If Accum < 0 Then
Accum = 0
ElseIf Accum > 255 Then
Accum = 255
End If
Pict(X, Y) = Accum
Next
Next
For X = 0 To 639
Pict(X, 0) = 0
Pict(X, 1) = 0
Next
X = Rnd ＊ 639
For Y = 50 To 439
Next
DDSBack.Unlock AlphaRect
If DX.TickCount() － lastTime > wait Then
If Counter = 0 Then
bDrawText = True
Counter = 1
XPos = Rnd ＊ 200
YPos = 300 ＋ Rnd ＊ 140
wait = 400
ElseIf Counter = 1 Then
MsgIndex = MsgIndex ＋ 1
If MsgIndex > 5 Then MsgIndex = 0
bDrawText = False
Counter = 0
wait = 2000
End If
lastTime = DX.TickCount
End If
If bDrawText Then
On Error Resume Next
DDSBack.DrawText XPos, YPos, Msg(MsgIndex), False
On Error GoTo 0
End If
MainForm.Form_Paint
Wend
TerminateDX
End
End Sub
Function ExModeActive() As Boolean
Dim TestCoopRes As Long
TestCoopRes = DDraw.TestCooperativeLevel
Select Case TestCoopRes
Case DDERR_NOEXCLUSIVEMODE
ExModeActive = False
Case DD_OK
ExModeActive = True
End Select
End Function
Public Sub InitializeDX()
MainForm.Left = 0
MainForm.Top = 0
MainForm.Height =640 ＊ Screen.TwipsPerPixelY
MainForm.Width = 480 ＊ Screen.TwipsPerPixelX
MainForm.Show
'建立DirectDraw对象
Set DDraw = DX.DirectDrawCreate(“”)
'设定DirectDraw对象的协作层
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN ' DDSCL_NORMAL
文章整理：西部数码--专业提供域名注册、虚拟主机服务
http://www.west263.com
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!
