如何在内存中生成一个汉字的映像？

[Bonnie_H]

譬如要在内存中生成一个“我“字的映像，就要先定义一个矩阵数组，然后从turetype 字库里找到这个"我“字，然后将这个字的逐点对应写到数组中，这样可以吗？

[Lionking1027]

应该是可以实现的,具体的实现过程关注ING

[quanyi]

up

[yunfeng007]

gz!

[rainstormmaster]

'模块,简单说明一下，过程GetOutline利用api函数GetGlyphOutline将得到的文字轮廓转化为数组（buffer），过程DrawGlyph将得到的数组在picturebox上转化为图形
'其中，很多过程都可以优化一下，大家可以完善一下
Option Explicit
Public Enum TT_GlyphFormat
GGO_BITMAP = 1&
GGO_METRICS = 0&
GGO_NATIVE = 2&
End Enum
Public Enum TT_CurveType
TT_PRIM_LINE = 1&
TT_PRIM_QSPLINE = 2&
TT_POLYGON_TYPE = 24&
End Enum
Type FIXED
Fract As Integer
Value As Integer
End Type

Type POINTFX
x As FIXED
y As FIXED
End Type

Type PointAPI
x As Long
y As Long
End Type

Type PointShort
x As Integer
y As Integer
End Type

Type PointSingle
x As Single
y As Single
End Type

Type GLYPHMETRICS
gmBlackBoxX As Long
gmBlackBoxY As Long
gmptGlyphOrigin As PointAPI
gmCellIncX As Integer
gmCellIncY As Integer
End Type


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


Type TTPOLYGONHEADER
cb As Long
dwType As Long

pfxStart As PointAPI
End Type

Type TTPOLYCURVE
wType As Integer
cpfx As Integer
apfx As PointAPI
End Type

Public Declare Function GetGlyphOutline Lib "gdi32" Alias "GetGlyphOutlineA" _
(ByVal hdc As Long, ByVal uChar As Long, _
ByVal fuFormat As Long, lpgm As GLYPHMETRICS, _
ByVal cbBuffer As Long, lpBuffer As Any, lpmat2 As MAT2) As Long
Public Const FixedFaktor = 65536
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal Bytes As Long)
Private Declare Sub MoveMemoryVal Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal Bytes As Long)
Private Declare Sub PeekPoint Lib "msvbvm60.dll" Alias "GetMem8" (Ptr As Any, RetVal As PointAPI)

Public Function GetIdentityMatrix() As MAT2
With GetIdentityMatrix
.eM11 = 1 * FixedFaktor
.eM12 = 0
.eM21 = 0
.eM22 = 1 * FixedFaktor
End With
End Function

Public Function GetShearMatrix() As MAT2
With GetShearMatrix
.eM11 = 1 * FixedFaktor
.eM12 = 0
.eM21 = 0.25 * FixedFaktor
.eM22 = 1 * FixedFaktor
End With
End Function

Public Function GetRotationMatrix(Angle As Double) As MAT2
Const Pi = 3.14159265358979
Dim angl As Double
angl = Angle * Pi / 180
With GetRotationMatrix
.eM11 = (Cos(angl)) * CDbl(FixedFaktor)
.eM12 = Sin(angl) * CDbl(FixedFaktor)
.eM21 = -.eM12
.eM22 = .eM11
End With
End Function

Public Function GetStrechMatrix(ByVal StrechX As Single, ByVal StrechY As Single) As MAT2
With GetStrechMatrix
.eM11 = StrechX * FixedFaktor
.eM12 = 0
.eM21 = 0
.eM22 = StrechY * FixedFaktor
End With
End Function

Public Function GetOutline(Buffer() As Long, ByVal hdc As Long, ByVal CharASCII As Long, ByVal fuFormat As TT_GlyphFormat, _
metr As GLYPHMETRICS, Matrix As MAT2) As Long
Dim ret As Long
Dim ByteSize As Long
Dim BufSize As Long
Dim Ptr As Long
ret = GetGlyphOutline(hdc, CharASCII, fuFormat, metr, ByteSize, ByVal Ptr, Matrix)

If ret > 0 Then
ByteSize = ret
BufSize = (ret / 4) - 1
Else
GetOutline = ret
Exit Function
End If
ReDim Buffer(BufSize) As Long
Ptr = VarPtr(Buffer(0))
ret = GetGlyphOutline(hdc, CharASCII, fuFormat, metr, ByteSize, ByVal Ptr, Matrix)
GetOutline = ret
If ret <= 0 Then
MsgBox "GetGlyphOutline: Error!"
Exit Function
End If
End Function

Public Sub DrawGlyph(Buffer() As Long, pb As PictureBox, ByVal xoff As Long, ByVal yoff As Long)
Dim i As Long
Dim j As Long
Dim idx As Long
Dim UB As Long
Dim EndPoly As Long
Dim PtsCnt As Long
Dim ptStart As PointAPI
Dim x As Single
Dim y As Single
Dim typ As Long
Dim xs() As Long
Dim ys() As Long
Dim xp(2) As Long
Dim yp(2) As Long
Dim pt() As PointAPI
UB = UBound(Buffer())
Do
EndPoly = Buffer(idx) \ 4 + idx
If Buffer(idx + 1) <> TT_POLYGON_TYPE Then
MsgBox "Fehler Polygon zeichnen: Kurve ist kein Polygonzug"
Exit Sub
End If
ptStart.x = Buffer(idx + 2)
ptStart.y = Buffer(idx + 3)
x = ptStart.x / FixedFaktor + xoff
y = yoff - ptStart.y / FixedFaktor
pb.PSet (x, y), 0
idx = idx + 4
Do
PtsCnt = Buffer(idx) \ 65536
typ = Buffer(idx) And 65535
idx = idx + 1
Select Case typ
Case TT_PRIM_LINE
For i = 1 To PtsCnt
x = Buffer(idx) / FixedFaktor + xoff
y = yoff - Buffer(idx + 1) / FixedFaktor
pb.Line -(x, y)
idx = idx + 2
Next
Case TT_PRIM_QSPLINE
ReDim xs(1 To PtsCnt)
ReDim ys(1 To PtsCnt)
For i = 1 To PtsCnt
xs(i) = xoff + Buffer(idx) / FixedFaktor
ys(i) = yoff - Buffer(idx + 1) / FixedFaktor
idx = idx + 2
Next i
For i = 1 To PtsCnt - 1
xp(0) = pb.CurrentX
yp(0) = pb.CurrentY
xp(1) = xs(i)
yp(1) = ys(i)
Select Case PtsCnt - i
Case 0
Case 1
xp(2) = xs(i + 1)
yp(2) = ys(i + 1)
Case Else
xp(2) = xp(1) + (xs(i + 1) - xp(1)) / 2
yp(2) = yp(1) + (ys(i + 1) - yp(1)) / 2
End Select
pb.CurrentX = xp(0)
pb.CurrentY = yp(0)
Call Qspline(30, xp(), yp(), pt())
For j = 0 To UBound(pt)
pb.Line -(pt(j).x, pt(j).y)
Next j
Next i
End Select
Loop Until idx >= (EndPoly)
pb.Line -(ptStart.x / FixedFaktor + xoff, yoff - ptStart.y / FixedFaktor)
Loop Until idx >= UB
End Sub

Sub Qspline(ByVal n As Long, ByRef x() As Long, ByRef y() As Long, ByRef ptOut() As PointAPI)
Dim i As Long
Dim t As Double
Dim tstep As Double
ReDim ptOut(0 To n)
tstep = 1 / (n)
For i = 0 To n
t = i * tstep
ptOut(i).x = (x(0) - 2 * x(1) + x(2)) * t ^ 2 + (2 * x(1) - 2 * x(0)) * t ^ 1 + x(0)
ptOut(i).y = (y(0) - 2 * y(1) + y(2)) * t ^ 2 + (2 * y(1) - 2 * y(0)) * t ^ 1 + y(0)
Next i
End Sub

[rainstormmaster]

'续上
'窗体：一个按钮，3个标签，一个picturebox ，一个listbox，一个textbox
Option Explicit
Private Buf() As Long
Dim x1 As Long
Dim y1 As Long

Private Sub Command1_Click()
GlyphTest
End Sub
Private Sub GlyphTest()
Dim metr As GLYPHMETRICS
Dim char As Long
Dim ret As Long
Dim matz As MAT2
char = Asc(Left$(Text1.Text, 1))
If List1.ListIndex < 0 Then
List1.ListIndex = 0
End If
Picture1.Cls
Picture1.FontName = List1.List(List1.ListIndex)
Picture1.FontSize = 300
Picture1.DrawWidth = 1
matz = GetIdentityMatrix()
ret = GetOutline(Buf(), Picture1.hdc, char, GGO_NATIVE, metr, matz)
DrawGlyph Buf(), Picture1, 100, 300
Label1.FontName = Picture1.FontName
Label1.FontSize = 300
Label1.Caption = Chr$(char)
End Sub

Private Sub Form_Load()
Dim i As Long
For i = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(i)
Next
List1.ListIndex = 0
End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
x1 = x
y1 = y
End Sub


Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Label1.Move Label1.Left / 1 + (x / 15 - x1 / 15), Label1.Top / 1 + (y / 15 - y1 / 15)
End If
End Sub


直接分析TTF字体的文件格式并读出每个字的轮廓矢量是相当困难的，我们可以借助API函数来方便地获得这些数据。
调用函数GetGlyphOutline可以得到一个字的轮廓矢量或者位图。
可以参考：
http://www.china-askpro.com/msg29/qa46.shtml
http://www.china-askpro.com/msg13/qa80.shtml
http://www.china-askpro.com/msg2/qa27.shtml
http://www2.ccw.com.cn/2000/0031/0031b12.asp

[rainstormmaster]

对了，picturebox的scalemode要设置为3

[pigpag]

学习——