| '------------- Class: clsFont
Option Explicit
Private Declare Function GetTextExtentPoint Lib "gdi32" Alias _
"GetTextExtentPointA" (ByVal hdc As Long, ByVal lpszString As _
String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectW" (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 Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const LF_FACESIZE = 32
Private Const NONANTIALIASED_QUALITY = 3
Private Const LOGPIXELSY = 90
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type Size
cx As Long
cy As Long
End Type
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 * LF_FACESIZE
End Type
Private m_nSize As Double
Private m_szFontName As String
Private m_bNotAntialiased As Boolean
Private m_nEscapement As Long
Private m_pctBox As PictureBox
Public Property Get PctBox() As PictureBox
Set PctBox = m_pctBox
End Property
Public Property Set PctBox(pctNewBox As PictureBox)
Set m_pctBox = pctNewBox
End Property
Public Property Get FontSize() As Double
FontSize = m_nSize
End Property
Public Property Let FontSize(ByVal nNewSize As Double)
m_nSize = nNewSize
End Property
Public Property Get FontName() As String
FontName = m_szFontName
End Property
Public Property Let FontName(ByVal szNewFontName As String)
m_szFontName = szNewFontName
End Property
Public Property Get NotAntialiased() As Boolean
NotAntialiased = m_bNotAntialiased
End Property
Public Property Let NotAntialiased(ByVal bNewNotAntialiased As Boolean)
m_bNotAntialiased = bNewNotAntialiased
End Property
Public Property Get Escapement() As Long
Escapement = m_nEscapement
End Property
Public Property Let Escapement(ByVal nNewEscapement As Long)
m_nEscapement = nNewEscapement
End Property
Private Sub SetupFont(hdc As Long, font As LOGFONT)
font.lfEscapement = m_nEscapement
font.lfFaceName = m_szFontName
font.lfHeight = -Int((m_nSize * _
GetDeviceCaps(hdc, LOGPIXELSY) / 72#) + 0.5)
font.lfQuality = IIf(m_bNotAntialiased, NONANTIALIASED_QUALITY, 0)
End Sub
Public Sub PrintText(ByVal sText As String)
Dim font As LOGFONT
Dim prevFont As Long
Dim hFont As Long
SetupFont m_pctBox.hdc, font
hFont = CreateFontIndirect(font)
prevFont = SelectObject(m_pctBox.hdc, hFont)
m_pctBox.Print sText
SelectObject m_pctBox.hdc, prevFont
DeleteObject hFont
End Sub
Public Sub PrintTextLine(ByVal sText As String)
Dim font As LOGFONT
Dim prevFont As Long
Dim hFont As Long
SetupFont m_pctBox.hdc, font
hFont = CreateFontIndirect(font)
prevFont = SelectObject(m_pctBox.hdc, hFont)
m_pctBox.Print sText;
SelectObject m_pctBox.hdc, prevFont
DeleteObject hFont
End Sub
Public Function GetTextHeight(ByVal sText As String) As Long
Dim font As LOGFONT
Dim prevFont As Long
Dim hFont As Long
SetupFont m_pctBox.hdc, font
hFont = CreateFontIndirect(font)
prevFont = SelectObject(m_pctBox.hdc, hFont)
Dim sSize As Size
GetTextExtentPoint m_pctBox.hdc, sText, Len(sText), sSize
GetTextHeight = m_pctBox.ScaleY(sSize.cy, vbPixels, _
m_pctBox.ScaleMode)
SelectObject m_pctBox.hdc, prevFont
DeleteObject hFont
End Function
Public Function GetTextWidth(ByVal sText As String) As Long
Dim font As LOGFONT
Dim prevFont As Long
Dim hFont As Long
SetupFont m_pctBox.hdc, font
hFont = CreateFontIndirect(font)
prevFont = SelectObject(m_pctBox.hdc, hFont)
Dim sSize As Size
GetTextExtentPoint m_pctBox.hdc, sText, Len(sText), sSize
GetTextWidth = m_pctBox.ScaleX(sSize.cx, _
vbPixels, m_pctBox.ScaleMode)
SelectObject m_pctBox.hdc, prevFont
DeleteObject hFont
End Function
Public Sub PrintCenterText(ByVal sText As String)
m_pctBox.CurrentX = (m_pctBox.Width - GetTextWidth(sText)) / 2
m_pctBox.CurrentY = (m_pctBox.Height - GetTextHeight(sText)) / 2
PrintText sText
End Sub
Private Sub Class_Initialize()
m_nSize = 10
m_szFontName = "Times New Roman"
End Sub
'Dim myfont As clsFont
'Set myfont = New clsFont
'Set myfont.PctBox = Picture1
'myfont.Escapement = 450
'myfont.PrintCenterText "Hello World!"
'------------- End of class: clsFont
|