Tipp 0229 DirectDraw - Eigene Schriften verwenden
Autor/Einsender:
Datum:
  Richard Schubert
21.04.2002
Entwicklungsumgebung:
DirectX-Version:
  VB 6
DirectX 7
Dieser Tipp zeigt wie man eigene / nichtinstallierte Schriften in DirectDraw verwenden kann. Es ist empfehlenswert diese Methode zu verwenden, um Text auszugeben, da diese Variante wesentlich schneller ist.
Weitere Schriftbitmaps können mit dem Programm Ttf2Bmp.exe, das dem Downloadprojekt im Ordner Ttf2Bmp beiliegt, erstellt werden.
Der abgebildete Code bezieht sich auf die wichtigsten Funktionen zum Verwenden eigener Schriften. Da u.a. der Code für die Initialisierung von DirectX meistens gleich bleibt, wird dieser hier nicht mehr gesondert abgebildet. Das Download-Beispiel enthält jedoch das komplette Projekt.
Code im Codebereich des Moduls mod01_Variablen
 
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
 
Code im Codebereich des Moduls mod03_VariablenInitialisierung
 
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
 
Code im Codebereich des Moduls mod04_Loading
 
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
 
Code im Codebereich des Moduls mod05_Engine
 
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
 
Code im Codebereich des Moduls mod06_Berechnungen
 
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
 
Weitere Links zum Thema
DirectDraw - Text
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  (44,4 kB) Downloads bisher: [ 842 ]

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: Samstag, 17. September 2011