Option Explicit

Public Enum COLOR_SEQUENZ
  C_RGB = 1
  C_BGR = 2
End Enum

Public Enum c16BIT
  Mode555 = 1
  Mode565 = 2
End Enum

Public RGBForm As COLOR_SEQUENZ
Public Mode16 As c16BIT
Public BitDepth As Integer
Public GBitMask As Single
Public RBitMask As Single
Public BBitMask As Single

Public Type cRGB
  r As Byte
  g As Byte
  b As Byte
End Type

Public Sub GetColorMode(ddPS As DirectDrawSurface7)
  Dim ddsd As DDSURFACEDESC2

  ddPS.GetSurfaceDesc ddsd

  With ddsd.ddpfPixelFormat
    BitDepth = .lRGBBitCount
    If .lRBitMask > .lBBitMask Then
      RGBForm = C_BGR
    Else
      RGBForm = C_RGB
    End If

    If BitDepth = 16 Then
      If .lGBitMask = &H7E0 Then
        Mode16 = Mode565
      Else
        Mode16 = Mode555
      End If
    End If

    GBitMask = .lGBitMask
    RBitMask = .lRBitMask
    BBitMask = .lBBitMask
  End With
End Sub

Public Function GetRGB16(Color As Long) As cRGB
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single

  bsG = &H20
  If Mode16 = Mode555 Then
    If RGBForm = C_BGR Then
      bsR = &H400
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H400
      bsR = 1
    End If
  ElseIf Mode16 = Mode565 Then
    If RGBForm = C_BGR Then
      bsR = &H800
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H800
      bsR = 1
    End If
  End If

  With GetRGB16
    .r = (Color And RBitMask) / bsR
    .g = (Color And GBitMask) / bsG
    .b = (Color And BBitMask) / bsB
  End With
End Function

Public Function Get16BitColor(Color As cRGB) As Long
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single

  bsG = &H20
  If Mode16 = Mode555 Then
    If RGBForm = C_BGR Then
      bsR = &H400
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H400
      bsR = 1
    End If
  ElseIf Mode16 = Mode565 Then
    If RGBForm = C_BGR Then
      bsR = &H800
      bsB = 1
    ElseIf RGBForm = C_RGB Then
        bsB = &H800
        bsR = 1
    End If
  End If

  Get16BitColor = Color.r * bsR Or Color.g * bsG Or Color.b * bsB
End Function

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 RGBBild1 As cRGB
Dim RGBBild2 As cRGB
Dim BlendStatus As Single

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
  GetColorMode PrimarySurface
  BitmapLaden

  running = True

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

    AlphaBlending

    BackBuffer.BltFast _
          100, 100, bmpErgebnis, srcrect, DDBLTFAST_WAIT
    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText _
          10, 10, "DirectDraw und 16bit AlphaBlending", False
    BackBuffer.DrawText _
          10, 30, "<Esc> beendet das Programm", False
    BackBuffer.DrawText _
          10, 50, "FPS: " & Format(FPS, "0.0"), False
    BackBuffer.DrawText _
          10, 70, "<Cursor rauf/runter> BlendStatus: " & _
          BlendStatus, 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_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyUp Then
    BlendStatus = BlendStatus + 10
    If BlendStatus > 100 Then BlendStatus = 100
  End If

  If KeyCode = vbKeyDown Then
    BlendStatus = BlendStatus - 10
    If BlendStatus < 0 Then BlendStatus = 0
  End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyEscape) Then running = False
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
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 AlphaBlending()
  Dim destrect As RECT
  Dim BmpDesc As DDSURFACEDESC2
  Dim Pixel1 As Long
  Dim Pixel2 As Long
  Dim ZielRGB As cRGB
  Dim x As Integer
  Dim y As Integer

  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 y = 0 To 72
    For x = 0 To 436
      Pixel1 = bmpBild1.GetLockedPixel(x, y)
      Pixel2 = bmpBild2.GetLockedPixel(x, y)
      RGBBild1 = GetRGB16(Pixel1)
      RGBBild2 = GetRGB16(Pixel2)

      ZielRGB.r = (RGBBild1.r * BlendStatus + RGBBild2.r * _
            (100 - BlendStatus)) \ 100
      ZielRGB.g = (RGBBild1.g * BlendStatus + RGBBild2.g * _
            (100 - BlendStatus)) \ 100
      ZielRGB.b = (RGBBild1.b * BlendStatus + RGBBild2.b * _
            (100 - BlendStatus)) \ 100

      bmpErgebnis.SetLockedPixel x, y, Get16BitColor(ZielRGB)
    Next x
  Next y

  bmpBild1.Unlock destrect
  bmpBild2.Unlock destrect
  bmpErgebnis.Unlock destrect
  Exit Sub
ErrEnd:
  running = False
End Sub