VB6 GDI+实现精准中英字符测绘可自定义行距字距

【实例简介】

VB6&GDI 实现精准中英字符测绘，可自定义行距字距。本人写的试验代码，有大量BUG。测绘之中有少许的浮点误差——这是字体设计单位浮点计算造成的，不可避免.

因为代码中很少注释，我在这里说一下关键：重点是GDI 的DrawDriverString的功能，每个字符需要一个POINTF来定位，该POINTF的原点0,0不是左上角，而是左下角，X=字符左边界，Y（当为0时，实际值为字符行距，需要除以字符设计单位emheight再乘以字体emsize（字体大小，比如10磅）。 字符宽度可以用MeasureDriverString测出，很简单。

【实例截图】

【核心代码】

Dim bl As Boolean
Dim startT As Date
Dim endT As Date
startT = Timer

If UBound(b) = 0 Then
Exit Function
End If

Dim fName As String
fName = pObject.FontName
Dim FSize As Long
FSize = pObject.FontSize
Dim l&

l = pObject.TextWidth("龙")
Picture1.AutoRedraw = True
pObject.Cls

InitGDIPlus
Dim G As Long
GdipCreateFromHDC pObject.hdc, G
Dim b1 As Long
GdipCreateSolidFill &HFF0000FF, b1
Dim b2 As Long
GdipCreateSolidFill &HFFFFFFFF, b2
Dim FontFam As Long
GdipCreateFontFamilyFromName StrPtr(fName), 0, FontFam
Dim StrFormat As Long
GdipCreateStringFormat 0, 0, StrFormat
GdipSetStringFormatAlign StrFormat, StringAlignmentCenter


Dim CurFont As Long
GdipCreateFont FontFam, FSize, 0, UnitPoint, CurFont
'GdipCreateFontFromDC pObject.hdc, CurFont
Dim lfont As LOGFONTWW
GdipGetLogFontW CurFont, G, lfont

Debug.Print "charset:", lfont.lfCharSet


Dim dfontFam As Long
GdipCreateFontFamilyFromName StrPtr("微软雅黑"), 0, dfontFam
Dim dcurFont As Long
GdipCreateFontFromDC pObject.hdc, dcurFont
'            GdipCreateFont dfontFam, fsize, 0, UnitPoint, dcurFont



GdipSetTextRenderingHint G, TextRenderingHintSystemDefault


'！！！！！！！！！！！从这里开始是重点！！！！！！！！！！！！！！

Dim i&
i = (UBound(b) 1) \ 2
            If i >= 50000 Then
            ReDim pf(50000)
            Else

            ReDim pf(i - 1)
            
            End If
            
ReDim RcF(1 To UBound(pf))

Dim box As RECTF
Dim m As Long

Dim nums As Integer
GdipGetCellDescent FontFam, 0, nums
Dim emhei As Integer

GdipGetEmHeight FontFam, 0, emhei
Dim emhangju As Integer
GdipGetLineSpacing FontFam, 0, emhangju

Dim numUp As Double
numUp = ((emhangju) / emhei) * FSize
            
            pf(0).y = 0
            pf(0).x = Abs(ziju)
m = NewMatrix(1, 0, 0, 1, 0, 0)
Dim sc$
sc = String$(1, 0)
ReDim pline(0)
pline(0).Bottom = numUp
            
            For i = 0 To UBound(pf)
            CopyMemory ByVal StrPtr(sc), b(i * 2), 2

            
            GdipMeasureDriverString G, StrPtr(sc), 1, CurFont, pf(0), 1, m, box
            If i 1 > UBound(pf) Then
            Else
            pf(i 1).x = pf(i).x box.Right ziju
            RcF(i 1).Left = pf(i).x
            RcF(i 1).Bottom = box.Bottom hangju 0.5
            RcF(i 1).Right = pf(i 1).x - pf(i).x 0.5
            
                    If AscW(sc) = 13 Then
                    i = i 1
                        pf(i 1).x = Abs(ziju)
                      pf(i).y = pf(i).y numUp
                                  RcF(i 1).Left = pf(i).x
            RcF(i 1).Bottom = box.Bottom hangju 0.5
            RcF(i 1).Right = pf(i).x - pf(i - 1).x 0.5
                     RcF(i 1).Top = pf(i).y - (box.Bottom hangju) ((nums) / emhei) * FSize
                     
                      numUp = numUp box.Bottom hangju
                        If numUp > pObject.Height - pf(0).y And Not (bl) Then
                            ReDim Preserve pf(i - 2)
                            ReDim Preserve RcF(1 To i - 1)

                          GdipDrawDriverString G, VarPtr(b(0)), i - 1, CurFont, b1, pf(0), 1, m
                          DrawText = i
                          i = i - 2
                          bl = True
                          Exit For
                        Else
                        End If
                        ReDim Preserve pline(UBound(pline) 1)
                        pline(UBound(pline)).index = i 1
                        pline(UBound(pline)).Bottom = numUp
                    
                    ElseIf (pf(i 1).x > pObject.Width - pf(0).y * 1.5) Then
                      pf(i 1).x = Abs(ziju)
                      pf(i).y = pf(i).y numUp
RcF(i 1).Top = pf(i).y - (box.Bottom hangju) ((nums) / emhei) * FSize
                      numUp = numUp box.Bottom hangju
                        If numUp > pObject.Height - pf(0).y And Not (bl) Then
                            ReDim Preserve pf(i 2)
                            ReDim Preserve RcF(1 To i 3)
                          i = i 2
                          '！！！！！！！注意，这里是判断字符多出窗口，直接绘制而后跳出！！！！！！
                          GdipDrawDriverString G, VarPtr(b(0)), i - 1, CurFont, b1, pf(0), 1, m
                          DrawText = i
                          i = i - 2
                          bl = True
                          Exit For
                        Else
                        End If
                        ReDim Preserve pline(UBound(pline) 1)
                        pline(UBound(pline)).index = i 1
                        pline(UBound(pline)).Bottom = numUp
                    End If
                    If pf(i 1).x - Abs(ziju) < 1 Then
                    Else
                    pf(i).y = pf(i).y numUp
RcF(i 1).Top = pf(i).y - (box.Bottom hangju) ((nums) / emhei) * FSize
                    End If

            End If
            
            Next
            If Not bl Then
            
i = i - 1
'pObject.Cls
ReDim Preserve pf(i - 1)
ReDim Preserve RcF(1 To i)


'！！！！！！！！！！！一次性输出，输出一万字符最多90毫秒（而且已经计算好了每个字符的绝对位置）！！！！！！！！！！！！！！
            GdipDrawDriverString G, VarPtr(b(0)), i, CurFont, b1, pf(0), 1, m
            DrawText = i
'！！！！！！！！！！！输出完毕！！！！！！！！！！！！！！！
            End If