Option Explicit

Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim sngDrawStyle As Single
Dim lngDrawStyle As Long
Dim lngDrawWidth As Long
Dim sngFillStyle As Single
Dim lngFillStyle As Long
Dim myFont As New StdFont
Dim bolFontBold As Boolean
Dim bolFontItalic As Boolean
Dim bolFontUnderline As Boolean
Dim bolFontStrikethrough As Boolean
Dim sngFontSize As Single
Dim sngFontName As Single

Dim running As Boolean
Dim FPSCounter As Single
Dim FPS As Single
Dim FPSTickLast As Long

Private Sub Form_Load()
  Dim destrect As RECT
  Dim strFontName As String

  Me.Show
  Me.Refresh

  lngDrawWidth = 1
  sngFontSize = 8
  Initialization

  running = True

  Do
    Select Case sngDrawStyle
      Case 0: lngDrawStyle = DrawStyleConstants.vbDash
      Case 1: lngDrawStyle = DrawStyleConstants.vbDashDot
      Case 2: lngDrawStyle = DrawStyleConstants.vbDashDotDot
      Case 3: lngDrawStyle = DrawStyleConstants.vbDot
      Case 4: lngDrawStyle = DrawStyleConstants.vbInsideSolid
      Case 5: lngDrawStyle = DrawStyleConstants.vbInvisible
      Case 6: lngDrawStyle = DrawStyleConstants.vbSolid
    End Select
    BackBuffer.setDrawStyle lngDrawStyle

    BackBuffer.setDrawWidth lngDrawWidth
    BackBuffer.SetFillColor vbWhite

    Select Case sngFillStyle
      Case 0: lngFillStyle = FillStyleConstants.vbCross
      Case 1: lngFillStyle = FillStyleConstants.vbDiagonalCross
      Case 2: lngFillStyle = FillStyleConstants.vbDownwardDiagonal
      Case 3: lngFillStyle = FillStyleConstants.vbFSSolid
      Case 4: lngFillStyle = FillStyleConstants.vbFSTransparent
      Case 5: lngFillStyle = FillStyleConstants.vbHorizontalLine
      Case 6: lngFillStyle = FillStyleConstants.vbUpwardDiagonal
      Case 7: lngFillStyle = FillStyleConstants.vbVerticalLine
    End Select
    BackBuffer.SetFillStyle lngFillStyle

    BackBuffer.SetForeColor vbRed
    BackBuffer.DrawCircle 100, 250, 50
    BackBuffer.DrawText 75, 310, "DrawCircle", False

    BackBuffer.SetForeColor vbGreen
    BackBuffer.DrawEllipse 200, 200, 250, 300
    BackBuffer.DrawText 200, 310, "DrawEllipse", False

    BackBuffer.SetForeColor vbBlue
    BackBuffer.DrawBox 300, 200, 350, 300
    BackBuffer.DrawText 300, 310, "DrawBox", False

    BackBuffer.SetForeColor vbYellow
    BackBuffer.DrawRoundedBox 400, 200, 480, 300, 25, 25
    BackBuffer.DrawText 400, 310, "DrawRoundedBox", False

    BackBuffer.SetForeColor vbMagenta
    BackBuffer.DrawLine 500, 300, 550, 200
    BackBuffer.DrawText 500, 310, "DrawLine", False

    With destrect
      .Left = 50: .Right = 550
      .Top = 350: .Bottom = 370
    End With

    BackBuffer.BltColorFill destrect, vbWhite
    BackBuffer.SetForeColor vbWhite
    BackBuffer.SetFontBackColor vbBlack
    BackBuffer.SetFontTransparency False
    BackBuffer.DrawText 70, 354, "BltColorFill", False

    BackBuffer.SetForeColor vbRed
    myFont.Bold = bolFontBold
    myFont.Italic = bolFontItalic
    myFont.Underline = bolFontUnderline
    myFont.Strikethrough = bolFontStrikethrough
    myFont.Size = sngFontSize

    Select Case sngFontName
      Case 0: strFontName = "Arial"
      Case 1: strFontName = "Times New Roman"
      Case 2: strFontName = "Comic Sans MS"
    End Select
    myFont.Name = strFontName
    BackBuffer.SetFont myFont

    BackBuffer.DrawText 10, 10, _
            "DirectDraw einfaches Zeichnen", False
    BackBuffer.DrawText 10, 30, _
            "<Esc> beendet das Programm", False
    BackBuffer.DrawText 10, 50, _
            "FPS: " & Format(FPS, "0.0"), False

    Select Case sngDrawStyle
      Case 0: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbDash", False
      Case 1: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbDashDot", False
      Case 2: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbDashDotDot", False
      Case 3: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbDot", False
      Case 4: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbInsideSolid", False
      Case 5: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbInvisible", False
      Case 6: BackBuffer.DrawText 10, 70, _
                  "<D> DrawStyle: vbSolid", False
    End Select

    BackBuffer.DrawText 10, 90, _
            "<Up/Down> DrawWidth: " & lngDrawWidth, False

    Select Case sngFillStyle
      Case 0: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbCross", False
      Case 1: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbDiagonalCross", False
      Case 2: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbDownwardDiagonal", False
      Case 3: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbFSSolid", False
      Case 4: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbFSTransparent", False
      Case 5: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbHorizontalLine", False
      Case 6: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbUpwardDiagonal", False
      Case 7: BackBuffer.DrawText 10, 110, _
                  "<F> FillStyle: vbVerticalLine", False
    End Select

    BackBuffer.DrawText 200, 30, _
          "<B> Font Bold: " & bolFontBold, False
    BackBuffer.DrawText 200, 50, _
          "<I> Font Italic: " & bolFontItalic, False
    BackBuffer.DrawText 200, 70, _
          "<U> Font Underline: " & bolFontUnderline, False
    BackBuffer.DrawText 200, 90, _
          "<S> Font Strikethrough: " & bolFontStrikethrough, False
    BackBuffer.DrawText 200, 110, _
          "<Left/Right> Font Size: " & sngFontSize, False
    BackBuffer.DrawText 400, 30, _
          "<N> Font Name: " & strFontName, 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

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

Private Sub Form_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyEscape) Then
    running = False
  End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  If (KeyCode = vbKeyD) Then
    sngDrawStyle = sngDrawStyle + 1
    If sngDrawStyle > 6 Then sngDrawStyle = 0
  End If
  If (KeyCode = vbKeyF) Then
    sngFillStyle = sngFillStyle + 1
    If sngFillStyle > 6 Then sngFillStyle = 0
  End If
  If (KeyCode = vbKeyUp) Then
    lngDrawWidth = lngDrawWidth + 1
  End If
  If (KeyCode = vbKeyDown) Then
    If lngDrawWidth > 1 Then
      lngDrawWidth = lngDrawWidth - 1
    End If
  End If
  If (KeyCode = vbKeyB) Then
    If bolFontBold Then
      bolFontBold = False
    Else
      bolFontBold = True
    End If
  End If
  If (KeyCode = vbKeyI) Then
    If bolFontItalic Then
      bolFontItalic = False
    Else
      bolFontItalic = True
    End If
  End If
  If (KeyCode = vbKeyU) Then
    If bolFontUnderline Then
      bolFontUnderline = False
    Else
      bolFontUnderline = True
    End If
  End If
  If (KeyCode = vbKeyS) Then
    If bolFontStrikethrough Then
      bolFontStrikethrough = False
    Else
      bolFontStrikethrough = True
    End If
  End If
  If (KeyCode = vbKeyRight) Then
    sngFontSize = sngFontSize + 1
  End If
  If (KeyCode = vbKeyLeft) Then
    If sngFontSize > 1 Then
      sngFontSize = sngFontSize - 1
    End If
  End If
  If (KeyCode = vbKeyN) Then
    sngFontName = sngFontName + 1
    If sngFontName > 2 Then sngFontName = 0
  End If
End Sub

Sub Terminate()
  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