apifont.cls

即时通讯

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "APIFont"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End 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 = 24


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 As String * 50
End Type

Private m_LF As LOGFONT
Private NewFont As Long
Private OrgFont As Long
Public Sub CharPlace(o As Object, txt$, X, Y)
    Dim Throw As Long
    Dim hregion As Long
    Dim R As RECT
    
    R.Left = X
    R.Right = X + o.TextWidth(txt$) * 2
    R.Top = Y
    R.Bottom = Y + o.TextHeight(txt$) * 2
    
    hregion = 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 Sub
Public Sub SetAlign(o As Object, Top, BaseLine, Bottom, Left, Center, Right)
    Dim Vert As Long
    Dim Horz As Long
    
    If Top = True Then Vert = TA_TOP
    If BaseLine = True Then Vert = TA_BASELINE
    If Bottom = True Then Vert = TA_BOTTOM
    If Left = True Then Horz = TA_LEFT
    If Center = True Then Horz = TA_CENTER
    If Right = True Then Horz = TA_RIGHT
    SetTextAlign o.hdc, Vert Or Horz
End Sub
Public Sub setcolor(o As Object, CValue As Long)
    Dim Throw As Long
    
    Throw = SetTextColor(o.hdc, CValue)
End Sub
Public Sub SelectOrg(o As Object)
    Dim Throw As Long
    
    NewFont = SelectObject(o.hdc, OrgFont)
    Throw = DeleteObject(NewFont)
End Sub
Public 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 Long
    
    Throw = TextOut(o.hdc, XX, YY, text$, Len(text$))
End Sub

Public Property Get Width() As Long
    Width = m_LF.lfWidth
End Property

Public Property Let Width(ByVal W As Long)
    m_LF.lfWidth = W
End Property

Public Property Get Height() As Long
    Height = m_LF.lfHeight
End Property

Public Property Let Height(ByVal vNewValue As Long)
    m_LF.lfHeight = vNewValue
End Property

Public Property Get Escapement() As Long
    Escapement = m_LF.lfEscapement
End Property

Public Property Let Escapement(ByVal vNewValue As Long)
    m_LF.lfEscapement = vNewValue
End Property

Public Property Get weight() As Long
    weight = m_LF.lfWeight
End Property

Public Property Let weight(ByVal vNewValue As Long)
    m_LF.lfWeight = vNewValue
End Property

Public Property Get Italic() As Byte
    Italic = m_LF.lfItalic
End Property

Public Property Let Italic(ByVal vNewValue As Byte)
    m_LF.lfItalic = vNewValue
End Property

Public Property Get UnderLine() As Byte
    UnderLine = m_LF.lfUnderline
End Property

Public Property Let UnderLine(ByVal vNewValue As Byte)
    m_LF.lfUnderline = vNewValue
End Property

Public Property Get StrikeOut() As Byte
    StrikeOut = m_LF.lfStrikeOut
End Property

Public Property Let StrikeOut(ByVal vNewValue As Byte)
    m_LF.lfStrikeOut = vNewValue
End Property

Public Property Get FaceName() As String
    FaceName = m_LF.lfFaceName
End Property

Public Property Let FaceName(ByVal vNewValue As String)
    m_LF.lfFaceName = vNewValue
End Property

Private Sub Class_Initialize()
    m_LF.lfHeight = 30
    m_LF.lfWidth = 10
    m_LF.lfEscapement = 0
    m_LF.lfWeight = 400
    m_LF.lfItalic = 0
    m_LF.lfUnderline = 0
    m_LF.lfStrikeOut = 0
    m_LF.lfOutPrecision = 0
    m_LF.lfClipPrecision = 0
    m_LF.lfQuality = 0
    m_LF.lfPitchAndFamily = 0
    m_LF.lfCharSet = 0
    m_LF.lfFaceName = "Arial" + Chr(0)
End Sub