|
Option Explicit
Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim bmpBild1 As DirectDrawSurface7
Dim bmpBild2 As DirectDrawSurface7
Dim bmpErgebnis As DirectDrawSurface7
Dim ZielPixel(10, 72) As Long
Dim BlendStatus As Integer
Dim running As Boolean
Dim FPSCounter As Single
Dim FPS As Single
Dim FPSTickLast As Long
Private Sub Form_Load()
Dim srcrect As RECT
Me.Show
Me.Refresh
Initialization
BitmapLaden
BlendStatus = -10
running = True
Do
If BlendStatus < 426 Then
With srcrect
.Left = 0: .Right = 436
.Top = 0: .Bottom = 72
End With
BackBuffer.BltFast _
100, 100, bmpBild1, srcrect, DDBLTFAST_WAIT
With srcrect
.Left = 0: .Right = BlendStatus
.Top = 0: .Bottom = 72
End With
BackBuffer.BltFast _
100, 100, bmpBild2, srcrect, DDBLTFAST_WAIT
PixelFade
With srcrect
.Left = 0: .Right = 10
.Top = 0: .Bottom = 72
End With
BackBuffer.BltFast 100 + BlendStatus, 100, bmpErgebnis, _
srcrect, DDBLTFAST_WAIT
BlendStatus = BlendStatus + 1
Else
With srcrect
.Left = 0: .Right = 436
.Top = 0: .Bottom = 72
End With
BackBuffer.BltFast _
100, 100, bmpBild2, srcrect, DDBLTFAST_WAIT
End If
BackBuffer.SetForeColor vbRed
BackBuffer.SetFont Me.Font
BackBuffer.DrawText _
10, 10, "DirectDraw und Pixel-Fade 2", False
BackBuffer.DrawText _
10, 30, "<Esc> beendet das Programm", False
BackBuffer.DrawText _
10, 50, "FPS: " & Format(FPS, "0.0"), False
PrimarySurface.Flip Nothing, DDFLIP_WAIT
ClearBuffer vbBlack
If FPSCounter = 30 Then
If FPSTickLast <> 0 Then _
FPS = 1000 * 30 / (GetTime - FPSTickLast) + 1
FPSTickLast = GetTime
FPSCounter = 0
End If
FPSCounter = FPSCounter + 1
DoEvents
Loop While running
Terminate
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If (KeyAscii = vbKeyEscape) Then
running = False
End If
If (KeyAscii = vbKeySpace) Then
ZielPixelDefault
BlendStatus = -10
End If
End Sub
Sub Initialization()
Set DD7 = DX7.DirectDrawCreate("")
DD7.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or _
DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT
DD7.SetDisplayMode 800, 600, 16, 0, DDSDM_DEFAULT
With SurfaceDesc
.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or _
DDSCAPS_FLIP Or DDSCAPS_COMPLEX
.lBackBufferCount = 1
End With
Set PrimarySurface = DD7.CreateSurface(SurfaceDesc)
SurfaceDesc.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
Set BackBuffer = _
PrimarySurface.GetAttachedSurface(SurfaceDesc.ddsCaps)
End Sub
Sub BitmapLaden()
Dim BmpDesc As DDSURFACEDESC2
Dim destrect As RECT
BmpDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
BmpDesc.lWidth = 436
BmpDesc.lHeight = 72
Set bmpBild1 = _
DD7.CreateSurfaceFromFile(App.Path & "\DX7.bmp", BmpDesc)
Set bmpBild2 = _
DD7.CreateSurfaceFromFile(App.Path & "\VBFun.bmp", BmpDesc)
BmpDesc.lWidth = 10
BmpDesc.lHeight = 72
Set bmpErgebnis = DD7.CreateSurface(BmpDesc)
With destrect
.Bottom = 72
.Left = 0
.Right = 10
.Top = 0
End With
bmpErgebnis.BltColorFill destrect, 0
ZielPixelDefault
End Sub
Sub Terminate()
Set bmpBild1 = Nothing
Set bmpBild2 = Nothing
Set bmpErgebnis = Nothing
DD7.RestoreDisplayMode
DD7.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
Set PrimarySurface = Nothing
Set DD7 = Nothing
Set DX7 = Nothing
End
End Sub
Sub ClearBuffer(Color As Long)
Dim destrect As RECT
With destrect
.Bottom = 600
.Left = 0
.Right = 800
.Top = 0
End With
BackBuffer.BltColorFill destrect, Color
End Sub
Function GetTime() As Long
GetTime = DX7.TickCount
End Function
Sub PixelFade()
Dim destrect As RECT
Dim BmpDesc As DDSURFACEDESC2
Dim x As Integer
Dim y As Integer
Dim i As Single
On Error GoTo ErrEnd
BmpDesc.lFlags = _
DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_PIXELFORMAT
BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
BmpDesc.lWidth = 436
BmpDesc.lHeight = 72
bmpBild1.Lock _
destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_READONLY, 0
bmpBild2.Lock _
destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_READONLY, 0
BmpDesc.lWidth = 10
BmpDesc.lHeight = 72
bmpErgebnis.Lock _
destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_WRITEONLY, 0
For y = 0 To 71 Step 2
For x = 0 To 9 Step 2
If BlendStatus + x >= 0 Then
bmpErgebnis.SetLockedPixel x, y, _
bmpBild2.GetLockedPixel(x + BlendStatus, y)
bmpErgebnis.SetLockedPixel x + 1, y, _
bmpBild1.GetLockedPixel(x + 1 + BlendStatus, y)
bmpErgebnis.SetLockedPixel x, y + 1, _
bmpBild1.GetLockedPixel(x + BlendStatus, y + 1)
bmpErgebnis.SetLockedPixel x + 1, y + 1, _
bmpBild2.GetLockedPixel(x + 1 + BlendStatus, y + 1)
Else
bmpErgebnis.SetLockedPixel x, y, 0
bmpErgebnis.SetLockedPixel x + 1, y, 0
bmpErgebnis.SetLockedPixel x, y + 1, 0
bmpErgebnis.SetLockedPixel x + 1, y + 1, 0
End If
Next x
Next y
bmpBild1.Unlock destrect
bmpBild2.Unlock destrect
bmpErgebnis.Unlock destrect
Exit Sub
ErrEnd:
running = False
End Sub
Private Sub ZielPixelDefault()
Dim x As Integer
Dim y As Integer
For y = 0 To 72
For x = 0 To 10
ZielPixel(x, y) = 0
Next x
Next y
End Sub
|
|