Qbasicnews.com

Qbasicnews.com > Qbasic "like" compilers/interpreters > FB Discussion & Programming Help > Use Windows Vectorfonts with FreeBASIC.
Full Version: Use Windows Vectorfonts with FreeBASIC.
You're currently viewing a stripped down version of our content. View the full version with proper formatting.

d.j.peters

10-24-2005, 11:27 AM
Only for Win9x and ME.

I write an FBGUI Lib for Win and Lin and here is an example how to get data from Windows
Vectorfonts.

Joshy
Code:
' Copyright D.J.Peters (Joshy)
'Source: http://www.FBForum.de
Option Explicit

Const GDI_ERROR As integer = -1

Type POINTAPI
  x As integer
  y As integer
End Type

Type FIXED
  Fract As Integer    '2
  Value As Integer    '4
End Type

Type FIXED2
  Value As integer    '4
End Type

Type MAT2
  eM11 As FIXED
  eM12 As FIXED
  eM21 As FIXED
  eM22 As FIXED
End Type

Type POINTFX2
  x    As FIXED2      '4
  y    As FIXED2      '8
End Type

Const TT_POLYGON_TYPE As integer = 24
Type TTPOLYGONHEADER
  Size            As integer    ' 4
  TT_TYPE_24      As integer    ' 8
  pfxStart        As POINTFX2   '16
End Type

Const TT_PRIM_LINE    As short = 1
Const TT_PRIM_QSPLINE As short = 2
Type TTPOLYCURVE
  TT_PRIM_TYPE    As short    ' 2
  NumOfPointsFX   As short    ' 4
  Pn              As POINTFX2 ' 12
End Type

Type GLYPHMETRICS
  gmBlackBoxX     As integer
  gmBlackBoxY     As integer
  gmptGlyphOrigin As POINTAPI
  gmCellIncX      As short
  gmCellIncY      As short
End Type

Enum GGO_FLAGS
  GGO_METRICS = 0
  GGO_BITMAP = 1
  GGO_NATIVE = 2
  GGO_GRAY2_BITMAP = 4
  GGO_GRAY4_BITMAP = 5
  GGO_GRAY8_BITMAP = 6
  GGO_GLYPH_INDEX = &H80
End Enum

Declare Function CreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hdc As Integer) As Integer
Declare Function CreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hdc As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Integer, _
                                                 ByVal W As Integer, _
                                                 ByVal E As Integer, _
                                                 ByVal O As Integer, _
                                                 ByVal W As Integer, _
                                                 ByVal I As Integer, _
                                                 ByVal u As Integer, _
                                                 ByVal S As Integer, _
                                                 ByVal C As Integer, _
                                                 ByVal OP As Integer, _
                                                 ByVal CP As Integer, _
                                                 ByVal Q As Integer, _
                                                 ByVal PAF As Integer, _
                                                 ByVal F As String) As Integer

Declare Function DeleteDC        Lib "gdi32"    Alias "DeleteDC" (ByVal hdc As Integer) As Integer
Declare Function DeleteObject    Lib "gdi32"    Alias "DeleteObject" (byval hObject as integer) as integer
Declare Function SelectObject    Lib "gdi32"    Alias "SelectObject" (byval hDC as integer,byval hObject as integer) as integer
Declare Function GetDC           Lib "user32"   Alias "GetDC" (byval hWin as integer) as integer
Declare Function GetGlyphOutline Lib "gdi32"    Alias "GetGlyphOutlineA" (ByVal hdc As Integer, ByVal uChar As Integer, ByVal fuFormat As Integer, ByRef lpgm As GLYPHMETRICS, ByVal cbBuffer As Integer, ByRef lpBuffer As ANY, ByRef lpmat2 As MAT2) As Integer
Declare Sub      CopyAny         Lib "kernel32" Alias "RtlMoveMemory" (Des As Any, src As Any, ByVal Size As integer)

Const ZOOM As Single = 0.005
Type LongVector
  x As integer
  y As integer
End Type
Type LongVector2
  c As integer
  x As integer
  y As integer
End Type

dim shared Points()     As LongVector2
dim shared PointCounter As integer

dim TT_HEADER     As TTPOLYGONHEADER
dim TT_POLYCURVE  As TTPOLYCURVE
dim shared GM     As GLYPHMETRICS
dim shared Mat    As MAT2
dim shared Buffer() As Byte
dim code          As integer
dim k             As string

Sub DrawSection()
  Dim i As integer
    
  PSet (Points(0).x*zoom, Points(0).y*zoom),Points(0).c
  For i = 0 To PointCounter - 1
    'pset(points(i).x*zoom,points(i).y*zoom),&HFFFFFF
    Line - (Points(i).x*zoom, Points(i).y*zoom),Points(0).c
  Next
  Line - (Points(0).x*zoom, Points(0).y*zoom),Points(0).c
    
  PSet (Points(0).x*zoom, Points(0).y*zoom),Points(0).c
  For i = 0 To PointCounter - 1
    PSet (Points(i).x*zoom, Points(i).y*zoom),Points(0).c
  Next
  PointCounter = 0
End Sub

Sub IncL(ByRef Value As integer, ByVal IncValue As integer)
  Value = Value + IncValue
End Sub

Function CreateQSplinePoints(A As LongVector, B As LongVector, c As LongVector) As LongVector
  Dim T As Single, Tq As Single
  Dim Term1 As LongVector, Term2 As LongVector,Tmp as LongVector
  
  Term1.x = A.x - 2 * B.x + c.x
  Term1.y = A.y - 2 * B.y + c.y
  Term2.x = 2 * B.x - 2 * A.x
  Term2.y = 2 * B.y - 2 * A.y
  
  For T = 0! To 1! Step 0.25!
    Tq = T * T
    ReDim Preserve Points(PointCounter)
    Points(PointCounter).c = RGB(255, 0, 0)
    Points(PointCounter).x = Term1.x * Tq + Term2.x * T + A.x
    Points(PointCounter).y = Term1.y * Tq + Term2.y * T + A.y
    IncL PointCounter, 1
  Next
  tmp.x = Points(PointCounter - 1).x
  tmp.y = Points(PointCounter - 1).y
  return tmp
End Function

Sub CreatePointArray(ByVal hDC as integer,ByVal ascCode As integer)
  Dim i               As integer
  Dim BufferSize      As integer
  Dim SectionSize     As integer
  Dim PolyType        As integer
  Dim intType         As short
  Dim intNums         As short
  Dim BufferPtr       As integer
  ReDim PointsFX(0)   As LongVector
  Dim AFX             As LongVector
  Dim BFX             As LongVector
  Dim CFX             As LongVector
  Dim MFX             As LongVector
    
  BufferSize = GetGlyphOutline(hDC, ascCode, GGO_NATIVE, GM, 0, ByVal 0, Mat)

  If (BufferSize <> GDI_ERROR) And (BufferSize > 0) Then
    ReDim Buffer(BufferSize - 1) as byte
    If GetGlyphOutline(hDC, ascCode, GGO_NATIVE, GM, BufferSize, Buffer(0), Mat) <> GDI_ERROR Then
      While BufferPtr < (BufferSize - 1)
        CopyAny SectionSize, Buffer(BufferPtr), 4: BufferPtr = BufferPtr + 4: SectionSize = SectionSize - 4
        CopyAny PolyType, Buffer(BufferPtr), 4:    BufferPtr = BufferPtr + 4: SectionSize = SectionSize - 4
        If PolyType = TT_POLYGON_TYPE Then
          'startpoint
          CopyAny AFX, Buffer(BufferPtr), 8: BufferPtr = BufferPtr + 8: SectionSize = SectionSize - 8
          ReDim Preserve Points(PointCounter)
          Points(PointCounter).c = RGB(0, 0, 255)
          Points(PointCounter).x = AFX.x
          Points(PointCounter).y = AFX.y
          PointCounter = PointCounter + 1
          While (SectionSize& > 0&)
            CopyAny intType, Buffer(BufferPtr), 2: BufferPtr = BufferPtr + 2: SectionSize = SectionSize - 2
            CopyAny intNums, Buffer(BufferPtr), 2: BufferPtr = BufferPtr + 2: SectionSize = SectionSize - 2
            Select Case intType
              Case TT_PRIM_LINE
                For i = 1 To intNums
                  ReDim Preserve Points(PointCounter)
                  CopyAny AFX, Buffer(BufferPtr), 8: BufferPtr = BufferPtr + 8: SectionSize = SectionSize - 8
                  Points(PointCounter).c = RGB(0, 0, 255)
                  Points(PointCounter).x = AFX.x
                  Points(PointCounter).y = AFX.y
                  PointCounter = PointCounter + 1
                Next
              Case TT_PRIM_QSPLINE
                Select Case intNums
                  Case 0, 1
                    print "Error: intNums less 2 Q-Spline"
                    End 1
                  Case 2
                    CopyAny BFX, Buffer(BufferPtr), 8
                    BufferPtr = BufferPtr + 8
                    SectionSize = SectionSize - 8
                    CopyAny CFX, Buffer(BufferPtr), 8
                    BufferPtr = BufferPtr + 8
                    SectionSize = SectionSize - 8
                    AFX = CreateQSplinePoints(AFX, BFX, CFX)
                
                  Case Else
                    ReDim PointsFX(intNums - 1)
                    CopyAny PointsFX(0), Buffer(BufferPtr), CLng(intNums * 8)
                    BufferPtr = BufferPtr + intNums * 8
                    SectionSize = SectionSize - intNums * 8
                    For i = 0 To intNums - 2
                      BFX = PointsFX(i)

                      If i < (intNums - 2) Then
                        MFX = PointsFX(i + 1)
                        CFX.x = (BFX.x + MFX.x) / 2
                        CFX.y = (BFX.y + MFX.y) / 2
                      Else
                        CFX = PointsFX(i + 1)
                      End If
                      AFX = CreateQSplinePoints(AFX, BFX, CFX)
                    Next
                End Select 'intNums
              Case Else
                print "Error: Unknown Curvetype: " + Str(intType)
                End 1
            End Select
          Wend   'SectionSize>0
        End If 'PolyType
        DrawSection
      Wend  'BufferPtr < BufferSize
    End If 'GetBuffer
  Else
    print "Error: GetBufferSize()" + str(BufferSize)
  End If  'GetBufferSize
End Sub

'
'main
'
const ANSI_CHARSET as integer        = 0
const CLIP_DEFAULT_PRECIS as integer = 0
const DEFAULT_QUALITY     as integer = 0
const OUT_TT_PRECIS       as integer = 4
const FF_MODERN           as integer = 48
const FW_NORMAL           as integer = 400

dim hWin     as integer
dim hScrDC   as integer
dim hDC      as integer
dim hBMP     as integer
dim hFont    as integer
dim hOldFont as integer

screenres 640,480,32
hScrDC  =GetDC(0)
hDC     =CreateCompatibleDC(hScrDC)
hBMP    =CreateCompatibleBitmap(hDC,100,100)
SelectObject hDC,hBMP
hFont   =CreateFont(0, 0, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, "Arial")
hOldFont=SelectObject(hDC,hFont)

window (-320,320)-(320,-320)

code=33
while len(k)=0
  WindowTitle str(code)
  Cls
  CreatePointArray hDC,code
  code+=1: If code > 255 Then code = 33
  k=inkey$
  sleep 50
wend

SelectObject hDC,hOldFont
DeleteObject hBMP
DeleteObject hFont
DeleteDC hDC
end

d.j.peters

11-09-2005, 11:46 AM
Tested with Win9x, Me and XP.
If you need for example 3D fonst you can get the 2D vectors from any truetype font but you must do the qspline math.
CreateQSplinePoints

Joshy
Code:
' Copyright by D.J.Peters (Joshy)
'Quelle: http://www.FBForum.de
Option Explicit

Const GDI_ERROR As integer = -1

Type POINTAPI
  x As integer
  y As integer
End Type

Type FIXED
  Fract As short    '2
  Value As short    '4
End Type

Type FIXED2
  Value As integer    '4
End Type

Type MAT2
  eM11 As FIXED
  eM12 As FIXED
  eM21 As FIXED
  eM22 As FIXED
End Type

Type POINTFX2
  x    As FIXED2      '4
  y    As FIXED2      '8
End Type

Const TT_POLYGON_TYPE As integer = 24
Type TTPOLYGONHEADER
  Size            As integer    ' 4
  TT_TYPE_24      As integer    ' 8
  pfxStart        As POINTFX2   '16
End Type

Const TT_PRIM_LINE    As short = 1
Const TT_PRIM_QSPLINE As short = 2
Type TTPOLYCURVE
  TT_PRIM_TYPE    As short    ' 2
  NumOfPointsFX   As short    ' 4
  Pn              As POINTFX2 ' 12
End Type

Type GLYPHMETRICS
  gmBlackBoxX     As integer
  gmBlackBoxY     As integer
  gmptGlyphOrigin As POINTAPI
  gmCellIncX      As short
  gmCellIncY      As short
End Type

Enum GGO_FLAGS
  GGO_METRICS = 0
  GGO_BITMAP = 1
  GGO_NATIVE = 2
  GGO_GRAY2_BITMAP = 4
  GGO_GRAY4_BITMAP = 5
  GGO_GRAY8_BITMAP = 6
  GGO_GLYPH_INDEX = &H80
End Enum

Declare Function CreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hdc As Integer) As Integer
Declare Function CreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hdc As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Integer, _
                                                 ByVal W As Integer, _
                                                 ByVal E As Integer, _
                                                 ByVal O As Integer, _
                                                 ByVal W As Integer, _
                                                 ByVal I As Integer, _
                                                 ByVal u As Integer, _
                                                 ByVal S As Integer, _
                                                 ByVal C As Integer, _
                                                 ByVal OP As Integer, _
                                                 ByVal CP As Integer, _
                                                 ByVal Q As Integer, _
                                                 ByVal PAF As Integer, _
                                                 ByVal F As String) As Integer

Declare Function DeleteDC        Lib "gdi32"    Alias "DeleteDC" (ByVal hdc As Integer) As Integer
Declare Function DeleteObject    Lib "gdi32"    Alias "DeleteObject" (byval hObject as integer) as integer
Declare Function SelectObject    Lib "gdi32"    Alias "SelectObject" (byval hDC as integer,byval hObject as integer) as integer
Declare Function GetGlyphOutline Lib "gdi32"    Alias "GetGlyphOutlineA" (ByVal hdc As Integer, ByVal uChar As Integer, ByVal fuFormat As Integer, ByRef gm As GLYPHMETRICS, ByVal cbBuffer As Integer, ByVal lpBuffer As ANY ptr, ByRef mat As MAT2) As Integer
Declare Function GetDC           Lib "user32"   Alias "GetDC" (byval hWin as integer) as integer
Declare Sub      CopyAny         Lib "kernel32" Alias "RtlMoveMemory" (Des As Any, src As Any, ByVal Size As integer)


Type LongVector
  x As integer
  y As integer
End Type
Type LongVector2
  c As integer
  x As integer
  y As integer
End Type

dim shared Points()     As LongVector2
dim shared PointCounter As integer
dim shared GM           As GLYPHMETRICS
dim shared Mat          As MAT2
dim shared Buffer()     As Byte

Const ZOOM As Single = 1.0
Sub DrawSection()
  Dim i As integer
  PSet (Points(0).x*zoom, Points(0).y*zoom),Points(0).c
  For i = 1 To PointCounter - 1
    Line - (Points(i).x*zoom, Points(i).y*zoom),Points(i).c
  Next
  Line - (Points(0).x*zoom, Points(0).y*zoom),Points(0).c

  For i = 0 To PointCounter - 1
    PSet (Points(i).x*zoom, Points(i).y*zoom),&HFFffFF
  Next
  PointCounter = 0
End Sub

Function CreateQSplinePoints(A As LongVector, B As LongVector, c As LongVector) As LongVector
  Dim T As Single, Tq As Single
  Dim Term1 As LongVector, Term2 As LongVector,Tmp as LongVector
  
  Term1.x = A.x - 2 * B.x + c.x
  Term1.y = A.y - 2 * B.y + c.y
  Term2.x = 2 * B.x - 2 * A.x
  Term2.y = 2 * B.y - 2 * A.y
  
  For T = 0! To 1! Step 0.25!
    Tq = T * T
    ReDim Preserve Points(PointCounter)
    Points(PointCounter).c = &HFF0000
    Points(PointCounter).x = Term1.x * Tq + Term2.x * T + A.x
    Points(PointCounter).y = Term1.y * Tq + Term2.y * T + A.y
    PointCounter+=1
  Next
  tmp.x = Points(PointCounter - 1).x
  tmp.y = Points(PointCounter - 1).y
  return tmp
End Function

Sub CreatePointArray(ByVal hDC as integer,ByVal ascCode As integer)
  Dim i               As integer
  Dim BufferSize      As integer
  Dim SectionSize     As integer
  Dim PolyType        As integer
  Dim intType         As short
  Dim intNums         As short
  Dim BufferPtr       As integer
  ReDim PointsFX(0)   As LongVector
  Dim AFX             As LongVector
  Dim BFX             As LongVector
  Dim CFX             As LongVector
  Dim MFX             As LongVector
  Mat.eM11.Value=1:Mat.eM22.Value=1
  
  BufferSize = GetGlyphOutline(hDC, ascCode, GGO_NATIVE, GM, 0, ByVal 0, Mat)
  If (BufferSize <> GDI_ERROR) And (BufferSize > 0) Then
    ReDim Buffer(BufferSize - 1) as byte
    If GetGlyphOutline(hDC, ascCode, GGO_NATIVE, GM, BufferSize, @Buffer(0), Mat)>0 Then
      While BufferPtr < (BufferSize - 1)
        CopyAny SectionSize, Buffer(BufferPtr), 4: BufferPtr+=4:SectionSize-=4
        CopyAny PolyType   , Buffer(BufferPtr), 4: BufferPtr+=4:SectionSize-=4
        If PolyType = TT_POLYGON_TYPE Then
          'startpoint
          CopyAny AFX, Buffer(BufferPtr), 8: BufferPtr+=8:SectionSize-=8
          ReDim Preserve Points(PointCounter+1)
          Points(PointCounter).c = &H0000FF
          Points(PointCounter).x = AFX.x
          Points(PointCounter).y = AFX.y
          PointCounter = PointCounter + 1
          While (SectionSize& > 0&)
            CopyAny intType, Buffer(BufferPtr), 2:BufferPtr+=2:SectionSize-=2
            CopyAny intNums, Buffer(BufferPtr), 2:BufferPtr+=2:SectionSize-=2
            Select Case intType
              Case TT_PRIM_LINE
                For i = 1 To intNums
                  ReDim Preserve Points(PointCounter+1)
                  CopyAny AFX, Buffer(BufferPtr),8:BufferPtr+=8:SectionSize-=8
                  Points(PointCounter).c = &H00FF00
                  Points(PointCounter).x = AFX.x
                  Points(PointCounter).y = AFX.y
                  PointCounter+=1
                Next
              Case TT_PRIM_QSPLINE
                Select Case intNums
                  Case 0, 1
                    print "Error: intNums less 2 Q-Spline"
                    End 1
                  Case 2
                    CopyAny BFX, Buffer(BufferPtr),8
                    BufferPtr+=8:SectionSize-=8
                    CopyAny CFX, Buffer(BufferPtr), 8
                    BufferPtr+=8:SectionSize-=8
                    AFX = CreateQSplinePoints(AFX, BFX, CFX)
                
                  Case Else
                    ReDim PointsFX(intNums - 1)
                    CopyAny PointsFX(0), Buffer(BufferPtr), CLng(intNums * 8)
                    BufferPtr  +=intNums * 8
                    SectionSize-=intNums * 8
                    For i = 0 To intNums - 2
                      BFX = PointsFX(i)

                      If i < (intNums - 2) Then
                        MFX = PointsFX(i + 1)
                        CFX.x = (BFX.x + MFX.x) / 2
                        CFX.y = (BFX.y + MFX.y) / 2
                      Else
                        CFX = PointsFX(i + 1)
                      End If
                      AFX = CreateQSplinePoints(AFX, BFX, CFX)
                    Next
                End Select 'intNums
              Case Else
                print "Error: Unknown Curvetype: " + Str(intType)
                End 1
            End Select
          Wend   'SectionSize>0
        End If 'PolyType
        DrawSection
      Wend  'BufferPtr < BufferSize
    End If 'GetBuffer
  Else
    print "Error: GetBufferSize()" + str(BufferSize)
  End If  'GetBufferSize
End Sub

'
'main
'
type dummy
  res1 as integer
  res2 as integer
  res3 as integer
  hWin as integer
end type
Extern Driver Alias "fb_win32" As dummy
const ANSI_CHARSET        as integer = 0
const CLIP_DEFAULT_PRECIS as integer = 0
const DEFAULT_QUALITY     as integer = 0
const OUT_TT_PRECIS       as integer = 4
const FF_MODERN           as integer = 48
const FW_NORMAL           as integer = 400

dim hWin     as integer
dim hScrDC   as integer
dim hDC      as integer
dim hBMP     as integer
dim hFont    as integer
dim hOldFont as integer
dim code     as integer
dim k        as string

screenres 640,480,32
hWin    =Driver.hWin
hScrDC  =GetDC(hWin)
hDC     =CreateCompatibleDC(hScrDC)
hBMP    =CreateCompatibleBitmap(hDC,100,100)
SelectObject hDC,hBMP
hFont   =CreateFont(1,1, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, "Symbol")
'hFont   =CreateFont(1,1, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, "Times New Roman")
'hFont   =CreateFont(1,1, 0, 0, FW_NORMAL, 0, 0, 0, 0, 0, 0, 0, 0, "Arial")
hOldFont=SelectObject(hDC,hFont)

window (-10000,100000)-(200000,-100000)

code=49
while len(k)=0
  WindowTitle str(code)
  Cls
  CreatePointArray hDC,code
  code+=1: If code > 255 Then code = 33
  k=inkey$
  sleep 100
wend

SelectObject hDC,hOldFont
DeleteObject hBMP
DeleteObject hFont
DeleteDC hDC
end
Qbasicnews.com > Qbasic "like" compilers/interpreters > FB Discussion & Programming Help > Use Windows Vectorfonts with FreeBASIC.