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

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

'模块,简单说明一下，过程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 TypeType POINTFX
    x As FIXED
    y As FIXED
End TypeType PointAPI
    x As Long
    y As Long
End TypeType PointShort
    x As Integer
    y As Integer
End TypeType PointSingle
    x As Single
    y As Single
End TypeType 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 TypeType TTPOLYCURVE
    wType As Integer
    cpfx As Integer
    apfx As PointAPI
End TypePublic 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 FunctionPublic Function GetShearMatrix() As MAT2
   With GetShearMatrix
      .eM11 = 1 * FixedFaktor
      .eM12 = 0
      .eM21 = 0.25 * FixedFaktor
      .eM22 = 1 * FixedFaktor
   End With
End FunctionPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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 SubSub 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

'续上
'窗体：一个按钮，3个标签，一个picturebox ，一个listbox，一个textbox
Option Explicit
Private Buf() As Long
Dim x1 As Long
Dim y1 As LongPrivate 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 SubPrivate Sub Form_Load()
    Dim i As Long
    For i = 0 To Screen.FontCount - 1
      List1.AddItem Screen.Fonts(i)
    Next
    List1.ListIndex = 0
End SubPrivate 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

对了，picturebox的scalemode要设置为3

调试易

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

解决方案 »