Get Windows Vectorfonts Data and calc the QSplines.

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Get Windows Vectorfonts Data and calc the QSplines.

Postby D.J.Peters » Oct 24, 2005 4:58

!!!Only for Win9x and ME!!!

I write a FBGUI for Win and Lin and here is how to read Vector Fonts
and calc the QSplines for drawing.

Joshy

Code: Select all

' Fontexample Copyright D.J.Peters (Joshy)
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 100
wend

SelectObject hDC,hOldFont
DeleteObject hBMP
DeleteObject hFont
DeleteDC hDC
end
Last edited by D.J.Peters on Oct 31, 2008 11:31, edited 3 times in total.
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Postby D.J.Peters » Oct 24, 2005 14:53

Look next posts for XP version
Last edited by D.J.Peters on Oct 26, 2005 11:41, edited 2 times in total.
Adigun A. Polack
Posts: 230
Joined: May 27, 2005 15:14
Contact:

I have my results for your code right here. ;)

Postby Adigun A. Polack » Oct 24, 2005 14:57

D.J.Peters, I have just now this morning tested your code here on Windows ME, and I am very happy to say that it works great, no errors there!! ^_- ! As for the program itself, it can indeed render *any* TrueType font at all in vector form besides just Arial alone, telling from how this test went, man, and you did quite a marvelous work, you know?

My thumbs are up from me to you on a job well done, so keep it up now!!! d=^-^=b
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Postby D.J.Peters » Oct 26, 2005 11:30

Now this code use FB 0.15b with the curent include files from CVS.
And i hope it runs now on Win9x, ME and XP too.

Joshy

Code: Select all

'Copyright D.J.Peters (Joshy)
'
Option Explicit

#include "windows.bi"

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 = 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 'spline = blue
    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 HDC,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
   
  Dim AFX             As LongVector
  Dim BFX             As LongVector
  Dim CFX             As LongVector
  Dim MFX             As LongVector

  ReDim PointsFX(0)   As LongVector

  BufferSize = GetGlyphOutline(hDC, ascCode, GGO_NATIVE, @GM, 0, NULL, @Mat)
 
  If (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+=8: SectionSize-=8
          ReDim Preserve Points(PointCounter)
          Points(PointCounter).c = &HFF 'red
          Points(PointCounter).x = AFX.x
          Points(PointCounter).y = AFX.y
          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)
                  CopyAny AFX, Buffer(BufferPtr), 8: BufferPtr+=8: SectionSize-=8
                  Points(PointCounter).c = &HFF00 'green
                  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   = 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
'
dim hWin     as HWND
dim hScrDC   as HDC
dim hDC      as HDC
dim hBMP     as HBITMAP
dim hFont    as HFONT
dim hOldFont as HFONT

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 (-20,300)-(620,-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 100
wend

SelectObject hDC,hOldFont
DeleteObject hBMP
DeleteObject hFont
DeleteDC hDC
end
Last edited by D.J.Peters on Oct 31, 2008 11:32, edited 1 time in total.
jofers
Posts: 1525
Joined: May 27, 2005 17:18
Contact:

Postby jofers » Oct 26, 2005 12:11

Sorry, no dice :(
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Postby D.J.Peters » Oct 26, 2005 12:39

?!?
Last edited by D.J.Peters on Oct 31, 2008 11:32, edited 1 time in total.
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

Postby D.J.Peters » Nov 09, 2005 5:48

Tested with Win9x, Me and XP.

Code: Select all

' Copyright by D.J.Peters (Joshy)
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

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest