ftextoutline.frm

实现文本的描边和空心字的源代码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form FTextOutline 
   Caption         =   "Form1"
   ClientHeight    =   6270
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7050
   LinkTopic       =   "Form1"
   ScaleHeight     =   6270
   ScaleWidth      =   7050
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame1 
      Caption         =   "Options"
      Height          =   1815
      Left            =   0
      TabIndex        =   1
      Top             =   4440
      Width           =   7035
      Begin VB.TextBox txtAngle 
         Height          =   315
         Left            =   3360
         TabIndex        =   15
         Text            =   "txtAngle"
         Top             =   1320
         Width           =   1155
      End
      Begin VB.TextBox txtPenWidth 
         Height          =   315
         Left            =   180
         TabIndex        =   11
         Text            =   "txtPenWidth"
         Top             =   1320
         Width           =   1275
      End
      Begin VB.CheckBox chkOutlineBehind 
         Caption         =   "OutlineBehind"
         Height          =   255
         Left            =   3000
         TabIndex        =   4
         Top             =   300
         Width           =   1635
      End
      Begin VB.CheckBox chkUseExistingObjs 
         Caption         =   "Use Existing Objects"
         Height          =   255
         Left            =   4680
         TabIndex        =   5
         Top             =   360
         Value           =   1  'Checked
         Width           =   2115
      End
      Begin VB.CommandButton cmdOutlineColor 
         Caption         =   "OutlineColor"
         Height          =   315
         Left            =   180
         TabIndex        =   6
         Top             =   660
         Width           =   1275
      End
      Begin VB.CommandButton cmdFillColor 
         Caption         =   "FillColor"
         Height          =   315
         Left            =   1620
         TabIndex        =   7
         Top             =   660
         Width           =   1035
      End
      Begin VB.CheckBox chkOutlined 
         Caption         =   "Outlined"
         Height          =   255
         Left            =   180
         TabIndex        =   2
         Top             =   300
         Value           =   1  'Checked
         Width           =   1035
      End
      Begin VB.CheckBox chkFilled 
         Caption         =   "Filled"
         Height          =   255
         Left            =   1620
         TabIndex        =   3
         Top             =   300
         Width           =   1035
      End
      Begin VB.CommandButton cmdClear 
         Caption         =   "Clear"
         Height          =   315
         Left            =   5280
         TabIndex        =   9
         Top             =   1320
         Width           =   1035
      End
      Begin VB.TextBox txtDrawText 
         Height          =   315
         Left            =   1620
         TabIndex        =   13
         Text            =   "txtDrawText"
         Top             =   1320
         Width           =   1395
      End
      Begin VB.CommandButton cmdFont 
         Caption         =   "Font"
         Height          =   315
         Left            =   3000
         TabIndex        =   8
         Top             =   660
         Width           =   1035
      End
      Begin VB.Label Label4 
         Caption         =   "Label4"
         Height          =   555
         Left            =   4680
         TabIndex        =   16
         Top             =   660
         Width           =   2235
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "Text &Angle:"
         Height          =   195
         Left            =   3360
         TabIndex        =   14
         Top             =   1080
         Width           =   1050
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "&PenWidth"
         Height          =   195
         Left            =   180
         TabIndex        =   10
         Top             =   1080
         Width           =   705
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "&Text to draw:"
         Height          =   195
         Left            =   1620
         TabIndex        =   12
         Top             =   1080
         Width           =   1275
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   0
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox Picture1 
      Height          =   4335
      Left            =   0
      ScaleHeight     =   4275
      ScaleWidth      =   6975
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   0
      Width           =   7035
   End
End
Attribute VB_Name = "FTextOutline"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdClear_Click()
   Picture1.Cls
End Sub

Private Sub cmdFillColor_Click()
   With CommonDialog1
      .CancelError = True
      .Flags = cdlCCFullOpen Or cdlCCRGBInit
      .Color = Picture1.FillColor
      On Error Resume Next
      .ShowColor
      If Err.Number = 0 Then
         Picture1.FillColor = .Color
      End If
   End With
End Sub

Private Sub cmdFont_Click()
   With CommonDialog1
      .CancelError = True
      .Flags = cdlCFScreenFonts Or cdlCFTTOnly  'must be truetype!
      .FontName = Picture1.Font.Name
      .FontSize = Picture1.Font.Size
      On Error Resume Next
      .ShowFont
      If Err.Number = 0 Then
         Picture1.Font.Name = .FontName
         Picture1.Font.Size = .FontSize
         Label4.Caption = "Current Font:" & vbCrLf & _
            Picture1.Font.Name & ", " & Picture1.Font.Size & " pt."
      End If
   End With
End Sub

Private Sub cmdOutlineColor_Click()
   With CommonDialog1
      .CancelError = True
      .Flags = cdlCCFullOpen Or cdlCCRGBInit
      .Color = Picture1.ForeColor
      On Error Resume Next
      .ShowColor
      If Err.Number = 0 Then
         Picture1.ForeColor = .Color
      End If
   End With
End Sub

Private Sub Form_Load()
   Set Me.Icon = Nothing
   Me.Caption = "Click on the PictureBox to test CTextOutline"
   
   ' set default properties
   txtDrawText.Text = "ABC"
   txtPenWidth.Text = "1"
   txtAngle.Text = "0"
   With Picture1
      .FillColor = vbRed
      .FillStyle = 0 'solid
      .ForeColor = vbBlack
      .ScaleMode = vbPixels
      .Font.Name = "WingDings"
      .Font.Size = 72
      Label4.Caption = "Current Font:" & vbCrLf & _
         Picture1.Font.Name & ", " & Picture1.Font.Size & " pt."
   End With
End Sub

Private Sub Form_Resize()
   With Picture1
      Frame1.Move .Left, Me.ScaleHeight - Frame1.Height - .Top
      .Move .Left, .Top, Me.ScaleWidth - .Left * 2, Me.ScaleHeight - .Top * 3 - Frame1.Height
   End With
End Sub

Private Sub Picture1_Click()
   Dim ot As CTextOutlineEx
      
   Set ot = New CTextOutlineEx
   
   With Picture1
      ot.hDC = .hDC
      ot.Filled = CBool(chkFilled.Value)
      ot.UseExistingObjects = CBool(chkUseExistingObjs.Value)
      ot.OutlineBehind = CBool(chkOutlineBehind.Value)
      ot.Outlined = CBool(chkOutlined.Value)
      If ot.UseExistingObjects = False Then
         ot.Angle = Val(txtAngle.Text)
         ot.FillColor = .FillColor
         Set ot.Font = .Font
         ot.OutlineColor = .ForeColor
         ot.PenWidth = .DrawWidth
      End If
      ot.DrawText txtDrawText.Text, .CurrentX, .CurrentY
   End With
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   ' update current position to click-point
   With Picture1
      .CurrentX = X
      .CurrentY = Y
   End With
End Sub

'Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'   Static s As String
'   ' show mouse position in caption
'   s = X & ", " & Y
'   If InStr(Me.Caption, s) = 0 Then
'      Me.Caption = s
'   End If
'End Sub

Private Sub txtAngle_Change()
   Static PrevVal As Long
   Dim NewVal As Long
   On Error GoTo BailOut
   NewVal = Val(txtAngle.Text)
   If NewVal >= 0 And NewVal <= 360 Then
      PrevVal = NewVal
   End If
BailOut:
   If Err.Number <> 0 Then
      Call Highlight(txtAngle)
      Beep
   End If
   txtAngle.Text = CStr(PrevVal)
End Sub

Private Sub txtAngle_GotFocus()
   Call Highlight(txtAngle)
End Sub

Private Sub txtAngle_KeyPress(KeyAscii As Integer)
   ' just numerics!
   If InStr("0123456789", Chr$(KeyAscii)) = 0 Then
      KeyAscii = 0
      Beep
   End If
End Sub

Private Sub txtDrawText_GotFocus()
   Call Highlight(txtDrawText)
End Sub

Private Sub txtPenWidth_Change()
   Static PrevVal As Long
   Dim NewVal As Long
   On Error GoTo BailOut
   NewVal = Val(txtPenWidth.Text)
   If NewVal >= 0 And NewVal <= 10 Then
      PrevVal = NewVal
   End If
BailOut:
   If Err.Number <> 0 Then
      Call Highlight(txtPenWidth)
      Beep
   End If
   txtPenWidth.Text = CStr(PrevVal)
   Picture1.DrawWidth = PrevVal
End Sub

Private Sub txtPenWidth_GotFocus()
   Call Highlight(txtPenWidth)
End Sub

Private Sub txtPenWidth_KeyPress(KeyAscii As Integer)
   ' just numerics!
   If InStr("0123456789", Chr$(KeyAscii)) = 0 Then
      KeyAscii = 0
      Beep
   End If
End Sub

Private Sub Highlight(txt As TextBox)
   With txt
      .SelStart = 0
      .SelLength = Len(.Text)
   End With
End Sub