vb6使用drawtext或GdipDrawString画文字的问题

[goodafu2]

画出来的文字效果不好，和在操作系统自带的文本编辑器显示的差别很大，下面代码应该怎么样修改才能和下图显示的一样效果？
代码：

Option Explicit



Private lGdiplusToken As Long


Private Const LOGPIXELSY = 90




Private Const LF_FACESIZE As Long = 32

Private Type logfont
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type




Private Enum DTSTYLE
DT_LEFT = &H0
DT_TOP = &H0
DT_CENTER = &H1
DT_RIGHT = &H2
DT_VCENTER = &H4
DT_BOTTOM = &H8
DT_WORDBREAK = &H10
DT_SINGLELINE = &H20
DT_EXPANDTABS = &H40
DT_TABSTOP = &H80
DT_NOCLIP = &H100
DT_EXTERNALLEADING = &H200
DT_CALCRECT = &H400
DT_NOPREFIX = &H800
DT_INTERNAL = &H1000
DT_EDITCONTROL = &H2000
DT_PATH_ELLIPSIS = &H4000
DT_FORE_ELLIPSIS = &H8000
DT_END_ELLIPSIS = &H8000&
DT_MODIFYSTRING = &H10000
DT_RTLREADING = &H20000
DT_WORD_ELLIPSIS = &H40000
DT_HIDEPREFIX = &H100000
End Enum

Private Const FW_NORMAL As Long = 400
Private Const FW_BOLD As Long = 700
Private Const FF_DONTCARE As Long = 0



Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As rect, ByVal wFormat As Long) As Long



Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As logfont) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long






Private Type POINTAPI
x As Long
y As Long
End Type

Private Type rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type



Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long


Private Declare Function SystemParametersInfo Lib "user32" _
Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Any, _
ByVal fuWinIni As Long) As Long


'根据指定设备场景代表的设备的功能返回信息
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

'文本绘图函数。也请参考SetTextAlign
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" (ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long









Private Sub subDrawText1(ByVal hDC As Long, ByVal Text As String, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal dwFlag As DTSTYLE)
Dim TmpRect As rect

With TmpRect
.Left = x
.Right = x + Width
.Top = y
.Bottom = y + Height
End With


Call DrawText(hDC, Text, -1, TmpRect, dwFlag)

End Sub

Private Sub subDrawText2(ByVal hDC As Long, ByVal Text As String, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long)
Dim TmpRect As RECTF

With TmpRect
.Left = x
.Right = x + Width
.Top = y
.Bottom = y + Height
End With

Dim graphics As Long, Brush As Long
Dim fontfam As Long, strformat As Long, curFont As Long


GdipCreateFromHDC hDC, graphics

Call GdipSetSmoothingMode(graphics, SmoothingModeAntiAlias)


GdipCreateFontFamilyFromName StrPtr(".萍方-简"), 0, fontfam
GdipCreateStringFormat 0, 0, strformat
GdipCreateSolidFill &HFFFF0000, Brush
GdipSetStringFormatAlign strformat, StringAlignmentNear
GdipCreateFont fontfam, 26, FontStyle.FontStyleRegular, UnitPixel, curFont

GdipSetTextRenderingHint graphics, TextRenderingHintAntiAlias



GdipDrawString graphics, StrPtr(Text), -1, curFont, TmpRect, strformat, Brush



GdipDeleteFontFamily fontfam
GdipDeleteStringFormat strformat
GdipDeleteFont curFont
GdipDeleteBrush Brush
GdipDeleteGraphics graphics '释放graphics占用的内存


End Sub

Private Function pCreateFontHandle(lpFont As StdFont) As Long
If lpFont Is Nothing Then Exit Function
Dim tLF As logfont
Dim sFN As String
Dim I As Long
Dim tByte() As Byte
sFN = lpFont.name
With tLF
tByte = StrConv(sFN, vbFromUnicode)
CopyMemory .lfFaceName(0), tByte(0), ArrayLen(tByte)

.lfHeight = -(GetDeviceCaps(picTop.hDC, LOGPIXELSY) * lpFont.size / 72) + 0.5

.lfItalic = lpFont.Italic
If (lpFont.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = 100
End If

.lfOutPrecision = 1
.lfQuality = 4
.lfUnderline = lpFont.Underline
.lfStrikeOut = lpFont.Strikethrough
.lfCharSet = lpFont.Charset
End With
pCreateFontHandle = CreateFontIndirect(tLF)
End Function



Public Function SetTextFont(ByVal hDC As Long, lpFont As StdFont) As Long
Dim hFont As Long
hFont = pCreateFontHandle(lpFont)
Call DeleteObject(SelectObject(hDC, hFont))
SetTextFont = hFont
End Function



Private Function ArrayLen(ByRef paraArr) As Long
On Error GoTo ErrLine
ArrayLen = UBound(paraArr) + 1
Exit Function
ErrLine:
ArrayLen = -1

End Function

Private Sub Command1_Click()
picTop.Cls

Dim tmpFont As New StdFont
' tmpFont.name = "宋体"
tmpFont.name = ".萍方-简"
tmpFont.Charset = 134

tmpFont.size = 26

SetTextFont picTop.hDC, tmpFont


Call subDrawText1(picTop.hDC, Text1.Text, 1, 1, 600, 100, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE)

picTop.Refresh

Set tmpFont = Nothing

End Sub

Private Sub Command2_Click()
picTop.Cls


Call subDrawText2(picTop.hDC, Text1.Text, 1, 1, 600, 100)


picTop.Refresh




End Sub

Private Sub Form_Load()

InitGDIPlusTo lGdiplusToken

End Sub

Private Sub Form_Unload(Cancel As Integer)
TerminateGDIPlusFrom lGdiplusToken
End Sub


下图是文本编辑器的效果，很好看：