Tipp 0137 PixelFading - 1 -
Autor/Einsender:
Datum:
  Alexander Csadek
07.10.2001
Entwicklungsumgebung:
DirectX-Version:
  VB 6
DirectX 7
Mit dem Fading können schon einige Effekte erzielt werden, auch wenn man die Farbwerte noch nicht verändert. Ob nun per Zufall die Pixel des einen Bitmaps statt dem anderen gezeichnet werden bis das zweite Bitmap komplett angezeigt wird, oder ob man nur die Pixel eines bestimmten Farbwertes nimmt, der Fantasie sind keine Grenzen gesetzt.
Zu diesem Tipp finden Sie eine ausführliche Beschreibung in unserer DirectX-Rubrik zu DirectDraw unter Get/SetLockedPixel, Fading, Alpha-Blending
 
ption 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(436, 72) As Long

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
  Randomize Time

  running = True

  Do
    With srcrect
      .Left = 0: .Right = 436
      .Top = 0: .Bottom = 72
    End With
    PixelFade

    BackBuffer.BltFast _
          100, 100, bmpErgebnis, srcrect, DDBLTFAST_WAIT

    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText 10, 10, "DirectDraw und Pixel-Fade", 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
  If (KeyAscii = vbKeySpace) Then ZielPixelDefault
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)

  Set bmpErgebnis = DD7.CreateSurface(BmpDesc)

  With destrect
    .Bottom = 72
    .Left = 0
    .Right = 436
    .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

  bmpErgebnis.Lock _
        destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_WRITEONLY, 0

  For i = 1 To 500
    x = Int(Rnd * 436) + 0
    If x > 436 Then x = 436
    y = Int(Rnd * 72) + 0
    If y > 72 Then y = 72
    If ZielPixel(x, y) = 0 Then _
          ZielPixel(x, y) = bmpBild2.GetLockedPixel(x, y)
  Next i
  For y = 0 To 72
    For x = 0 To 436
      If ZielPixel(x, y) = 0 Then
        bmpErgebnis.SetLockedPixel x, y, _
              bmpBild1.GetLockedPixel(x, y)
      Else
        bmpErgebnis.SetLockedPixel x, y, ZielPixel(x, y)
      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 436
      ZielPixel(x, y) = 0
    Next x
  Next y
End Sub
 
Weitere Links zum Thema
AlphaBlending 16-bit
PixelFading - 2 -
Hinweis
Um dieses Beispiel ausführen zu können, wird die DirectX 7 for Visual Basic Type Library benötigt (siehe dazu die Erläuterungen in der DirectX-Rubrik).

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (26,2 kB) Downloads bisher: [ 2047 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 8. August 2011