Option ExplicitPrivate Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As LongPrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As LongPrivate 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 LongPrivate Type RECTLeft As LongTop As LongRight As LongBottom As LongEnd Type  Private Const TA_LEFT = 0  Private Const TA_RIGHT = 2  Private Const TA_CENTER = 6  Private Const TA_TOP = 0  Private Const TA_BOTTOM = 8  Private Const TA_BASELINE = 24Private Type LOGFONTlfHeight As LonglfWidth As LonglfEscapement As LonglfOrientation As LonglfWeight As LonglfItalic As BytelfUnderline As BytelfStrikeOut As BytelfCharSet As BytelfOutPrecision As BytelfClipPrecision As BytelfQuality As BytelfPitchAndFamily As BytelfFaceName As String * 50End TypePrivate m_LF As LOGFONTPrivate NewFont As LongPrivate OrgFont As LongPublic Sub CharPlace(o As Object, txt, x, y)Dim Throw As LongDim hregion As LongDim R As RECTR.Left = x     R.Right = x + o.TextWidth(txt) * 2R.Top = yR.Bottom = y + o.TextHeight(txt) * 2hregion = CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom)Throw = SelectClipRgn(o.hdc, hregion)Throw = TextOut(o.hdc, x, y, txt, Len(txt))DeleteObject (hregion)End SubPublic Sub SetAlign(o As Object, Top, BaseLine, Bottom, Left, Center, Right)Dim Vert As LongDim Horz As LongIf Top = True Then Vert = TA_TOPIf BaseLine = True Then Vert = TA_BASELINEIf Bottom = True Then Vert = TA_BOTTOMIf Left = True Then Horz = TA_LEFTIf Center = True Then Horz = TA_CENTERIf Right = True Then Horz = TA_RIGHTSetTextAlign o.hdc, Vert Or HorzEnd Sub    Public Sub setcolor(o As Object, CValue As Long)Dim Throw As LongThrow = SetTextColor(o.hdc, CValue)End SubPublic Sub SelectOrg(o As Object)Dim Throw As LongNewFont = SelectObject(o.hdc, OrgFont)Throw = DeleteObject(NewFont)End SubPublic Sub SelectFont(o As Object)NewFont = CreateFontIndirect(m_LF)OrgFont = SelectObject(o.hdc, NewFont)End Sub    Public Sub FontOut(text, o As Control, XX, YY)Dim Throw As LongThrow = TextOut(o.hdc, XX, YY, text, Len(text))End SubPublic Property Get Width() As LongWidth = m_LF.lfWidthEnd Property    Public Property Let Width(ByVal W As Long)m_LF.lfWidth = WEnd PropertyPublic Property Get Height() As LongHeight = m_LF.lfHeightEnd Property    Public Property Let Height(ByVal vNewValue As Long)m_LF.lfHeight = vNewValueEnd PropertyPublic Property Get Escapement() As LongEscapement = m_LF.lfEscapementEnd Property    Public Property Let Escapement(ByVal vNewValue As Long)m_LF.lfEscapement = vNewValueEnd PropertyPublic Property Get Weight() As LongWeight = m_LF.lfWeightEnd Property    Public Property Let Weight(ByVal vNewValue As Long)m_LF.lfWeight = vNewValueEnd PropertyPublic Property Get Italic() As ByteItalic = m_LF.lfItalicEnd Property    Public Property Let Italic(ByVal vNewValue As Byte)m_LF.lfItalic = vNewValueEnd PropertyPublic Property Get UnderLine() As ByteUnderLine = m_LF.lfUnderlineEnd Property    Public Property Let UnderLine(ByVal vNewValue As Byte)m_LF.lfUnderline = vNewValueEnd PropertyPublic Property Get StrikeOut() As ByteStrikeOut = m_LF.lfStrikeOutEnd Property    Public Property Let StrikeOut(ByVal vNewValue As Byte)m_LF.lfStrikeOut = vNewValueEnd PropertyPublic Property Get FaceName() As StringFaceName = m_LF.lfFaceNameEnd Property    Public Property Let FaceName(ByVal vNewValue As String)m_LF.lfFaceName = vNewValueEnd PropertyPrivate Sub Class_Initialize()m_LF.lfHeight = 15m_LF.lfWidth = 15m_LF.lfEscapement = 0m_LF.lfWeight = 400m_LF.lfItalic = 0m_LF.lfUnderline = 0m_LF.lfStrikeOut = 0m_LF.lfOutPrecision = 0m_LF.lfClipPrecision = 0m_LF.lfQuality = 0m_LF.lfPitchAndFamily = 0m_LF.lfCharSet = 0m_LF.lfFaceName = "Arial" + Chr(0)End Sub

Option ExplicitDim af As APIFontDim x, y As IntegerPrivate Sub cmdAngle_Click()Dim i As IntegerSet af = NothingSet af = New APIFontPicture1.Cls     For i = 0 To 3600 Step 90af.Escapement = iaf.SelectFont Picture1x = Picture1.ScaleWidth / 2y = Picture1.ScaleHeight / 2af.FontOut "Comrade Studio", Picture1, x, yaf.SelectOrg Picture1Next iEnd SubPrivate Sub cmdHeight_Click()  Dim i As IntegerSet af = NothingSet af = New APIFontPicture1.Cls     For i = 0 To 360 Step 1Picture1.Clsaf.Height = iaf.SelectFont Picture1x = Picture1.ScaleWidth / 2y = Picture1.ScaleHeight / 2af.FontOut "Comrade Studio", Picture1, x, yaf.SelectOrg Picture1Next iEnd SubPrivate Sub cmdWeight_Click()Dim i As Integeri = 0Set af = NothingSet af = New APIFontPicture1.Cls     For i = 0 To 3600 Step 1Picture1.Clsaf.Weight = i * 5af.SelectFont Picture1x = Picture1.ScaleWidth / 2y = Picture1.ScaleHeight / 2af.FontOut "Comrade Studio", Picture1, x, yaf.SelectOrg Picture1Next iEnd SubPrivate Sub cmdWidth_Click()Dim i As IntegerSet af = NothingSet af = New APIFontPicture1.Cls     For i = 0 To 360 Step 1Picture1.Clsaf.Width = iaf.SelectFont Picture1x = Picture1.ScaleWidth / 2y = Picture1.ScaleHeight / 2‘在字符串后面要加入5个空格af.FontOut "同志工作室     ", Picture1, x, yaf.SelectOrg Picture1Next iEnd SubPrivate Sub Form_Load()Picture1.ScaleMode = 3End Sub