Option Explicit

Public Type THUDFont
  Letter(32 To 255) As RECT
  PicHeight As Integer
  FontPic As DirectDrawSurface7
End Type

Public HUDFont(1 To 2) As THUDFont

Option Explicit

Public Sub subLoadFontInfos()
  Dim File As Integer
  Dim TMP As String
  Dim Pos As Long
  Dim Pos2 As Long

  For m = 1 To 2

    File = FreeFile

    Open App.Path & "\pictures\" & m & ".fnt" For Input As File
      For n = 32 To 255
        Input #File, TMP
        TMP = TMP & " "

        Pos = InStr(1, TMP, "X", vbBinaryCompare)
        Pos2 = Pos + 2
        Do While Asc(Mid(TMP, Pos2, 1)) > 32
          Pos2 = Pos2 + 1
        Loop
        HUDFont(m).Letter(n).Left = _
              Mid(TMP, Pos + 2, Pos2 - Pos - 2)

        Pos = InStr(1, TMP, "Y", vbBinaryCompare)
        Pos2 = Pos + 2
        Do While Asc(Mid(TMP, Pos2, 1)) > 32
          Pos2 = Pos2 + 1
        Loop
        HUDFont(m).Letter(n).Top = _
              Mid(TMP, Pos + 2, Pos2 - Pos - 2)

        Pos = InStr(1, TMP, "W", vbBinaryCompare)
        Pos2 = Pos + 2
        Do While Asc(Mid(TMP, Pos2, 1)) > 32
          Pos2 = Pos2 + 1
        Loop
        HUDFont(m).Letter(n).Right = Mid(TMP, Pos + 2, _
              Pos2 - Pos - 2) + HUDFont(m).Letter(n).Left

        Pos = InStr(1, TMP, "H", vbBinaryCompare)
        Pos2 = Pos + 2
        Do While Asc(Mid(TMP, Pos2, 1)) > 32
          Pos2 = Pos2 + 1
        Loop
        HUDFont(m).Letter(n).Bottom = Mid(TMP, Pos + 2, _
              Pos2 - Pos - 2) + HUDFont(m).Letter(n).Top

      Next
    Close File
  Next
End Sub

Option Explicit

Public Sub subDD_LoadPictures()
  subLoadPicture App.Path & "/pictures/font1.bmp", _
        HUDFont(1).FontPic, 170, 228, CKeyB
  subLoadPicture App.Path & "/pictures/font2.bmp", _
        HUDFont(2).FontPic, 266, 357, CKeyB
End Sub

Public Sub subLoadPicture(ByRef Path As String, _
      ByRef Picture As DirectDrawSurface7, _
      ByRef Width As Integer, ByRef Height As Integer, _
      ByRef ckey As DDCOLORKEY)

  Dim OffscrSurf As DDSURFACEDESC2

  With OffscrSurf
    .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
    .ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    .lWidth = Width
    .lHeight = Height
  End With

  Set Picture = DD7.CreateSurfaceFromFile(Path, OffscrSurf)
  Picture.SetColorKey DDCKEY_SRCBLT, ckey
End Sub

Option Explicit
 
Public Sub subDrawGame()
  BackBuffer.BltColorFill EmptyRect, &H200&

  subDrawHudText 100, 100, "Eigene Schriften in DirectDraw", 2

  subDrawHudText 150, 200, "Dieser Tipp zeigt wie man " & _
        "eigene/nichtinstallierte Schriften", 1

  '...
  '...

  subDrawHudText CSng(MX) - fctGetTextLen("X: " & MX, 2), _
        CSng(MY) - fctGetTextHeight(2), "X: " & MX, 2
  subDrawHudText CSng(MX) - fctGetTextLen("Y: " & MY, 2) / 2, _
        CSng(MY) + 20, "Y: " & MY, 2

  subDrawHudText ResolutionX - fctGetTextLen("X: " & MX & _
        "  Y: " & MY, 1), 0, "X: " & MX & "  Y: " & MY, 1

  subCalcFPS
  subDrawFPS

  If UseVSync Then
    FrontBuffer.Flip Nothing, DDFLIP_WAIT
  Else
    FrontBuffer.Flip Nothing, DDFLIP_NOVSYNC
  End If
End Sub

Public Sub subDrawFPS()
  subDrawHudText 0, 0, "(F)PS: " & FPS, 1
End Sub

Public Sub subDrawHudText(ByVal X As Single, ByVal Y As Single, _
      ByVal Text As String, ByVal i As Integer)

  Dim n As Long
  Dim TMPX As Single
  Dim TMPY As Single
  Dim TMPRect As RECT
  Dim TMPRect2 As RECT

  TMPX = X

  For n = 1 To Len(Text)
    TMPY = Y

    If Asc(Mid(Text, n, 1)) >= 32 Then
      TMPRect2 = HUDFont(i).Letter(Asc(Mid(Text, n, 1)))

      With TMPRect
        .Left = 0
        .Top = 0
        .Right = 0
        .Bottom = 0

        subOverEdge TMPRect2.Right - TMPRect2.Left, _
            TMPRect2.Bottom - TMPRect2.Top, 0, TMPX, TMPY, TMPRect

        .Left = TMPRect2.Left + .Left
        .Top = TMPRect2.Top + .Top

        .Right = TMPRect2.Left + .Right
        .Bottom = TMPRect2.Top + .Bottom

        BackBuffer.BltFast TMPX, TMPY, HUDFont(i).FontPic, _
            TMPRect, DDBLTFAST_SRCCOLORKEY

        TMPX = TMPX + .Right - .Left
      End With
    End If
  Next n
End Sub

Option Explicit

Public Sub subCalcFPS()
  If FPSTimer + 500 < DX7.TickCount Then
    FPSTimer = DX7.TickCount
    FPS = FPSCounter * 2 + 1
    FPSCounter = 0
  Else
    FPSCounter = FPSCounter + 1
  End If

  If FPS > 0 Then ConstSpeed = 85 / FPS
End Sub

Public Function fctGetTextLen(ByVal Text As String, _
      ByVal i As Integer) As Long

  Dim n As Long
  Dim TMPX As Single
  Dim TMPRect As RECT

  TMPX = 0

  For n = 1 To Len(Text)
    If Asc(Mid(Text, n, 1)) >= 32 Then
      TMPRect = HUDFont(i).Letter(Asc(Mid(Text, n, 1)))
      TMPX = TMPX + TMPRect.Right - TMPRect.Left
    End If
  Next n

  fctGetTextLen = TMPX
End Function

Public Function fctGetTextHeight(ByVal i As Integer) As Long
  Dim TMP As Single
  Dim TMPRect As RECT

  TMPRect = HUDFont(i).Letter(32)
  TMP = TMPRect.Bottom - TMPRect.Top

  fctGetTextHeight = TMP
End Function

Public Sub subOverEdge(lWidth As Integer, lHeight As Integer, _
      lAnimationNumber As Single, RX As Single, RY As Single, _
      ByRef lRectangle As RECT)

  Dim BackUplX      As Single
  Dim BackUplY      As Single
  Dim BackUplWidth  As Single
  Dim BackUplHeight As Single
  Dim BackUplRect   As RECT

  BackUplX = RX
  BackUplY = RY
  BackUplWidth = BackUplX + lWidth
  BackUplHeight = BackUplY + lHeight

  With BackUplRect
    .Left = lWidth * Int(lAnimationNumber)
    .Right = .Left + lWidth
    .Top = 0
    .Bottom = .Top + lHeight

    lRectangle.Left = .Left
    lRectangle.Right = .Right
    lRectangle.Top = .Top
    lRectangle.Bottom = .Bottom

    If (BackUplX < 0) And (BackUplWidth >= 0) Then
      lRectangle.Left = Round(.Left - BackUplX)
      RX = 0
    End If

    If (BackUplY < 0) And (BackUplHeight >= 0) Then
      lRectangle.Top = Round(.Top - BackUplY)
      RY = 0
    End If

    If (BackUplX <= ResolutionX) And _
          (BackUplWidth > ResolutionX) Then
      lRectangle.Right = Round((ResolutionX - BackUplX) + .Left)
    End If

    If (BackUplY <= ResolutionY) And _
          (BackUplHeight > ResolutionY) Then
      lRectangle.Bottom = Round((ResolutionY - BackUplY) + .Top)
    End If
  End With
End Sub