|
Option Explicit
Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim ddPF As DDPIXELFORMAT
Dim bmpHintergrund As DirectDrawSurface7
Dim bmpHaus As DirectDrawSurface7
Dim bmpBaum As DirectDrawSurface7
Dim bmpHund As DirectDrawSurface7
Dim SrcColorKey As Integer
Dim running As Boolean
Private Sub Form_Load()
Dim SrcRect As RECT
Dim DestRect As RECT
Dim BGrect As RECT
Me.Show
Me.Refresh
Initialization
BitmapLaden
Hund.X = HundStart
Hund.Y = 510
SrcColorKey = 1
running = True
Do
FrameTime = GetTime
With SrcRect
.Left = 0: .Right = 480
.Top = 0: .Bottom = 320
End With
With BGrect
.Left = 0: .Right = 800
.Top = 0: .Bottom = 600
End With
BackBuffer.Blt BGrect, bmpHintergrund, SrcRect, DDBLT_WAIT
With SrcRect
.Left = 0: .Right = 233
.Top = 0: .Bottom = 235
End With
BackBuffer.BltFast _
567, 280, bmpHaus, SrcRect, DDBLTFAST_WAIT Or SrcColorKey
With SrcRect
.Left = 0: .Right = 218
.Top = 0: .Bottom = 196
End With
BackBuffer.BltFast _
200, 330, bmpBaum, SrcRect, DDBLTFAST_WAIT Or SrcColorKey
BackBuffer.BltFast _
420, 330, bmpBaum, SrcRect, DDBLTFAST_WAIT Or SrcColorKey
With SrcRect
.Left = Int(Hund.AniCount) * HundFrameBreite
.Right = .Left + HundFrameBreite
.Top = 0: .Bottom = 32
End With
Select Case Hund.Status
Case 0:
DisplaySprite DestRect, bmpHund, SrcRect, Hund.X, Hund.Y
Hund.X = Hund.X + 2
Hund.AniCount = Hund.AniCount + 0.2
If Hund.AniCount >= 4 Then
If Hund.X > 350 Then
Hund.Status = 1
Hund.AniCount = 4
Hund.PauseCount = 0
Else
Hund.AniCount = 0
End If
End If
Case 1:
DisplaySprite DestRect, bmpHund, SrcRect, Hund.X, Hund.Y
Hund.AniCount = Hund.AniCount + 0.2
If Hund.AniCount >= 6 Then Hund.AniCount = 4
Hund.PauseCount = Hund.PauseCount + 1
If Hund.PauseCount > HundAniPause Then
Hund.Status = 2
Hund.AniCount = 6
Hund.PauseCount = 0
End If
Case 2:
DisplaySprite DestRect, bmpHund, SrcRect, Hund.X, Hund.Y
Hund.PauseCount = Hund.PauseCount + 1
If Hund.PauseCount > HundAniPause Then
Hund.Status = 3
Hund.AniCount = 6
Hund.PauseCount = 0
End If
Case 3:
DisplaySprite DestRect, bmpHund, SrcRect, Hund.X, Hund.Y
Hund.AniCount = Hund.AniCount + 0.2
If Hund.AniCount >= 6 Then Hund.AniCount = 4
Hund.PauseCount = Hund.PauseCount + 1
If Hund.PauseCount > HundAniPause Then
Hund.Status = 4
Hund.AniCount = 0
Hund.PauseCount = 0
End If
Case 4:
DisplaySprite DestRect, bmpHund, SrcRect, Hund.X, Hund.Y
Hund.X = Hund.X + 2
Hund.AniCount = Hund.AniCount + 0.2
If Hund.AniCount >= 4 Then
If Hund.X > 832 Then
Hund.Status = 5
Hund.AniCount = 0
Hund.PauseCount = 0
Else
Hund.AniCount = 0
End If
End If
Case 5:
Hund.PauseCount = Hund.PauseCount + 1
If Hund.PauseCount > (HundAniPause * 3) Then
Hund.Status = 0
Hund.PauseCount = 0
Hund.X = HundStart
End If
End Select
With SrcRect
.Left = 0: .Right = 218
.Top = 0: .Bottom = 196
End With
BackBuffer.BltFast _
55, 360, bmpBaum, SrcRect, DDBLTFAST_WAIT Or SrcColorKey
BackBuffer.SetForeColor vbRed
BackBuffer.SetFont Me.Font
BackBuffer.DrawText _
10, 10, "DirectDraw und transparente Farben", False
BackBuffer.DrawText _
10, 30, "<Esc> beendet das Programm", False
If SrcColorKey = 0 Then
BackBuffer.DrawText _
10, 50, "<Space> ColorKey: DDBLTFAST_NOCOLORKEY", False
Else
BackBuffer.DrawText _
10, 50, "<Space> ColorKey: DDBLTFAST_SRCCOLORKEY", False
End If
PrimarySurface.Flip Nothing, DDFLIP_WAIT
ClearBuffer vbBlack
Do Until GetTime - FrameTime > 18
Loop
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
If SrcColorKey = 0 Then
SrcColorKey = 1
Else
SrcColorKey = 0
End If
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)
PrimarySurface.GetPixelFormat ddPF
End Sub
Sub BitmapLaden()
Dim BmpDesc As DDSURFACEDESC2
Dim ColorKey As DDCOLORKEY
BmpDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
BmpDesc.lWidth = 480
BmpDesc.lHeight = 320
Set bmpHintergrund = DD7.CreateSurfaceFromFile _
(App.Path & "\Hintergrund.bmp", BmpDesc)
BmpDesc.lWidth = 233
BmpDesc.lHeight = 235
Set bmpHaus = DD7.CreateSurfaceFromFile _
(App.Path & "\Haus.bmp", BmpDesc)
ColorKey.high = (ddPF.lRBitMask + ddPF.lBBitMask)
ColorKey.low = (ddPF.lRBitMask + ddPF.lBBitMask)
bmpHaus.SetColorKey DDCKEY_SRCBLT, ColorKey
BmpDesc.lWidth = 218
BmpDesc.lHeight = 196
Set bmpBaum = DD7.CreateSurfaceFromFile _
(App.Path & "\Baum.bmp", BmpDesc)
ColorKey.high = _
(ddPF.lRBitMask + ddPF.lGBitMask + ddPF.lBBitMask)
ColorKey.low = _
(ddPF.lRBitMask + ddPF.lGBitMask + ddPF.lBBitMask)
bmpBaum.SetColorKey DDCKEY_SRCBLT, ColorKey
BmpDesc.lWidth = 256
BmpDesc.lHeight = 32
Set bmpHund = DD7.CreateSurfaceFromFile _
(App.Path & "\Hund.bmp", BmpDesc)
ColorKey.high = ddPF.lGBitMask
ColorKey.low = ddPF.lGBitMask
bmpHund.SetColorKey DDCKEY_SRCBLT, ColorKey
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 DisplaySprite(DestRect As RECT, Sprite As _
DirectDrawSurface7, SrcRect As RECT, _
Optional ByVal xCoord As Long, _
Optional ByVal yCoord As Long)
Dim XSrcRect As RECT
XSrcRect = SrcRect
With SrcRect
If xCoord > (800 - (.Right - .Left)) Then _
.Right = (.Right - (xCoord - (800 - (.Right - .Left))))
If xCoord < 0 Then
.Left = .Left + (xCoord * -1)
xCoord = 0
End If
If yCoord > (600 - (.Bottom - .Top)) Then _
.Bottom = (.Bottom - (yCoord - (600 - (.Bottom - .Top))))
If yCoord < 0 Then
.Top = .Top + (yCoord * -1)
yCoord = 0
End If
End With
BackBuffer.BltFast xCoord, yCoord, Sprite, SrcRect, _
SrcColorKey Or DDBLTFAST_WAIT
SrcRect = XSrcRect
End Sub
Sub Terminate()
Set bmpHintergrund = Nothing
Set bmpHaus = Nothing
Set bmpBaum = Nothing
Set bmpHund = Nothing
DD7.RestoreDisplayMode
DD7.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
Set PrimarySurface = Nothing
Set DD7 = Nothing
Set DX7 = Nothing
End
End Sub
|
|