ctextoutlineex.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 = "CTextOutlineEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function BeginPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hDC As Long) As Long
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 Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function StrokePath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function FillPath Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetBkMode Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) 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

' Background Modes
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const BKMODE_LAST = 2

' Pen Styles
Private Const PS_SOLID = 0
Private Const PS_DASH = 1                    '  -------
Private Const PS_DOT = 2                     '  .......
Private Const PS_DASHDOT = 3                 '  _._._._
Private Const PS_DASHDOTDOT = 4              '  _.._.._
Private Const PS_NULL = 5
Private Const PS_INSIDEFRAME = 6
Private Const PS_USERSTYLE = 7
Private Const PS_ALTERNATE = 8
Private Const PS_STYLE_MASK = &HF

' Member variables
Private m_Angle As Single
Private m_FillColor As OLE_COLOR
Private m_Filled As Boolean
Private m_Font As StdFont
Private m_hDC As Long
Private m_OutlineBehind As Boolean
Private m_OutlineColor As OLE_COLOR
Private m_Outlined As Boolean
Private m_PenWidth As Long
Private m_UseExistingObjs As Boolean

' **************************************************************
'  Init/Term
' **************************************************************
Private Sub Class_Initialize()
   ' initialize props
   m_Filled = False
   m_FillColor = vbRed
   m_OutlineColor = vbBlack
   m_Outlined = True
   m_PenWidth = 1
   m_UseExistingObjs = True
End Sub

Private Sub Class_Terminate()
   '
End Sub

' **************************************************************
'  Public Properties
' **************************************************************
Public Property Let Angle(ByVal NewVal As Single)
   m_Angle = NewVal
End Property

Public Property Get Angle() As Single
   Angle = m_Angle
End Property

Public Property Let FillColor(ByVal NewVal As OLE_COLOR)
   m_FillColor = NewVal
End Property

Public Property Get FillColor() As OLE_COLOR
   FillColor = m_FillColor
End Property

Public Property Let Filled(ByVal NewVal As Boolean)
   m_Filled = NewVal
End Property

Public Property Get Filled() As Boolean
   Filled = m_Filled
End Property

Public Property Set Font(ByVal NewFont As IFont)
   Set m_Font = Nothing
   If Not NewFont Is Nothing Then
      '
      ' Stash a copy of the passed object,
      ' to avoid a new reference to it.
      '
      NewFont.Clone m_Font
   End If
End Property

Public Property Get Font() As IFont
   Set Font = m_Font
End Property

Public Property Let hDC(ByVal NewVal As Long)
   m_hDC = NewVal
End Property

Public Property Get hDC() As Long
   hDC = m_hDC
End Property

Public Property Let OutlineBehind(ByVal NewVal As Boolean)
   m_OutlineBehind = NewVal
End Property

Public Property Get OutlineBehind() As Boolean
   OutlineBehind = m_OutlineBehind
End Property

Public Property Let OutlineColor(ByVal NewVal As OLE_COLOR)
   m_OutlineColor = NewVal
End Property

Public Property Get OutlineColor() As OLE_COLOR
   OutlineColor = m_OutlineColor
End Property

Public Property Let Outlined(ByVal NewVal As Boolean)
   m_Outlined = NewVal
End Property

Public Property Get Outlined() As Boolean
   Outlined = m_Outlined
End Property

Public Property Let PenWidth(ByVal NewVal As Long)
   m_PenWidth = NewVal
End Property

Public Property Get PenWidth() As Long
   PenWidth = m_PenWidth
End Property

Public Property Let UseExistingObjects(ByVal NewVal As Boolean)
   m_UseExistingObjs = NewVal
End Property

Public Property Get UseExistingObjects() As Boolean
   UseExistingObjects = m_UseExistingObjs
End Property

' **************************************************************
'  Public Methods
' **************************************************************
Public Sub DrawText(ByVal Text As String, ByVal X As Long, ByVal Y As Long)
   Static oldAlign As Long
   Static oldBkMode As Long
   Static oldPen As Long
   Static oldBrush As Long
   Static oldFont As Long
   Static hPen As Long
   Static hBrush As Long
   Static nRet As Long
   
   If m_hDC Then
      oldBkMode = SetBkMode(m_hDC, TRANSPARENT)
      If m_UseExistingObjs = False Then
         ' create and select new objects
         If m_Filled Then
            hBrush = CreateSolidBrush(CheckSysColor(m_FillColor))
            oldBrush = SelectObject(m_hDC, hBrush)
         End If
         If m_Outlined Then
            hPen = CreatePen(PS_SOLID, m_PenWidth, CheckSysColor(m_OutlineColor))
            oldPen = SelectObject(m_hDC, hPen)
         End If
         If Not (m_Font Is Nothing) Then
            Dim fnt As New CLogFont
            Set fnt.LogFont = m_Font
            fnt.Rotation = m_Angle
            oldFont = SelectObject(m_hDC, fnt.Handle)
         End If
      End If
      
      ' create the path within the DC
      Call BeginPath(m_hDC)
      Call TextOut(m_hDC, X, Y, Text, Len(Text))
      Call EndPath(m_hDC)
      
      If m_Outlined And m_Filled Then
         If m_OutlineBehind Then
            ' first draw the outline, then...
            Call StrokePath(m_hDC)
            ' recreate the path, then...
            Call BeginPath(m_hDC)
            Call TextOut(m_hDC, X, Y, Text, Len(Text))
            Call EndPath(m_hDC)
            ' fill the path.
            Call FillPath(m_hDC)
         Else
            Call StrokeAndFillPath(m_hDC)
         End If
      ElseIf m_Filled Then
         Call FillPath(m_hDC)
      ElseIf m_Outlined Then
         Call StrokePath(m_hDC)
      End If
      
      If m_UseExistingObjs = False Then
         ' restore old objects, and delete new
         If m_Filled Then
            Call SelectObject(m_hDC, oldBrush)
            Call DeleteObject(hBrush)
         End If
         If m_Outlined Then
            Call SelectObject(m_hDC, oldPen)
            Call DeleteObject(hPen)
         End If
         If Not (m_Font Is Nothing) Then
            Call SelectObject(m_hDC, oldFont)
         End If
      End If
      Call SetBkMode(m_hDC, oldBkMode)
   End If
End Sub

' **************************************************************
'  Private Methods
' **************************************************************
Private Function CheckSysColor(ByVal Color As Long) As Long
   Const HighBit = &H80000000
   '
   ' If high bit set, strip, and get system color.
   '
   If Color And HighBit Then
      CheckSysColor = GetSysColor(Color And Not HighBit)
   Else
      CheckSysColor = Color
   End If
End Function