Option Explicit

Dim binit As Boolean
Dim dx As New DirectX7
Dim dd As DirectDraw7
Dim Mainsurf As DirectDrawSurface7
Dim primary As DirectDrawSurface7
Dim backbuffer As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd3 As DDSURFACEDESC2
Dim brunning As Boolean
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean
Dim FillRect As RECT
Dim FillRet As Long
Dim FontInfo As New StdFont

Sub Init()
  On Local Error GoTo errOut

  Set dd = dx.DirectDrawCreate("")
  Me.Show

  Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or _
       DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
  Call dd.SetDisplayMode(640, 480, 16, 0, DDSDM_DEFAULT)
  ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or _
        DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  ddsd1.lBackBufferCount = 1
  Set primary = dd.CreateSurface(ddsd1)

  Dim caps As DDSCAPS2
  caps.lCaps = DDSCAPS_BACKBUFFER
  Set backbuffer = primary.GetAttachedSurface(caps)
  backbuffer.GetSurfaceDesc ddsd3

  backbuffer.SetFontTransparency True
  backbuffer.SetForeColor RGB(0, 0, 200)

  binit = True
  brunning = True
  Do While brunning
    blt
    DoEvents
  Loop

errOut:
  EndIt
End Sub

Sub blt()
  On Local Error GoTo errOut

  If binit = False Then Exit Sub

  bRestore = False
  Do Until ExModeActive
     DoEvents
     bRestore = True
  Loop

  DoEvents
  If bRestore Then
    bRestore = False
    dd.RestoreAllSurfaces
  End If

  FillRect.Bottom = 480: FillRect.Right = 640
  FillRet = backbuffer.BltColorFill(FillRect, RGB(0, 0, 0))
  FontInfo.Bold = True
  FontInfo.Size = 20
  FontInfo.Name = "Verdana"
  backbuffer.SetFont FontInfo
  backbuffer.SetForeColor RGB(0, 0, 225)
  Call backbuffer.DrawText(10, 10, _
       "DirectDraw Textausgabe-Beispiel.", False)

  FontInfo.Bold = False
  FontInfo.Size = 20
  FontInfo.Name = "Verdana"
  backbuffer.SetFont FontInfo
  backbuffer.SetForeColor RGB(255, 0, 0)
  Call backbuffer.DrawText(10, 385, _
       "Maus-Klick zum Verlassen", False)

  primary.Flip Nothing, DDFLIP_WAIT

errOut:
End Sub

Sub EndIt()
  Call dd.RestoreDisplayMode
  Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
  End
End Sub

Private Sub Form_Click()
  EndIt
End Sub

Private Sub Form_Load()
  Init
End Sub

Private Sub Form_Paint()
  blt
End Sub

Function ExModeActive() As Boolean
  Dim TestCoopRes As Long

  TestCoopRes = dd.TestCooperativeLevel

  If (TestCoopRes = DD_OK) Then
    ExModeActive = True
  Else
    ExModeActive = False
  End If
End Function