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
|
|
|
|
|
|
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 ]
|
|
|