nicetextbox.ctl

来自「非常漂亮的VB控件」· CTL 代码 · 共 380 行

VERSION 5.00
Begin VB.UserControl NiceTextBox 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "NiceTextBox.ctx":0000
   Begin VB.PictureBox Pic 
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   0
      ScaleHeight     =   375
      ScaleWidth      =   1800
      TabIndex        =   0
      Top             =   0
      Width           =   1800
      Begin VB.TextBox Tx 
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         Height          =   270
         Left            =   10
         ScrollBars      =   3  'Both
         TabIndex        =   1
         Text            =   "Text1"
         Top             =   10
         Width           =   855
      End
   End
   Begin VB.Label l 
      Caption         =   "Label1"
      Height          =   15
      Left            =   1080
      TabIndex        =   2
      Top             =   1680
      Width           =   375
   End
End
Attribute VB_Name = "NiceTextBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private Enum states
    Normal = 0
    Disable = 1
    ReadOnly = 2
End Enum
'缺省属性值:
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
'属性变量:
Dim m_BackStyle As Boolean
Dim m_BorderStyle As Integer
'事件声明:
Event Click() 'MappingInfo=Tx,Tx,-1,Click
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick() 'MappingInfo=Tx,Tx,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=Tx,Tx,-1,KeyDown
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer) 'MappingInfo=Tx,Tx,-1,KeyPress
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=Tx,Tx,-1,KeyUp
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Tx,Tx,-1,MouseDown
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Tx,Tx,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Tx,Tx,-1,MouseUp
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"
Event Change() 'MappingInfo=Tx,Tx,-1,Change
Attribute Change.VB_Description = "当控件内容改变时发生。"



Private Function XpTxt(BackColor As ColorConstants, State As states, TxtColor As ColorConstants)
'Make sure you have a border of 6 pixels around
'textbox before you use this function

'states = normal, disable, read only
    'Pic.BackColor = BackColor
    Pic.ScaleMode = 1
    Tx.Appearance = 0
    Tx.BorderStyle = 0
    Pic.AutoRedraw = True
    Dim a, B, c, d As Integer
    a = Tx.Top + Tx.Height + 10
    B = Tx.Left - 10
    c = Tx.Left + Tx.Width + 10
    d = Tx.Top - 10
    Pic.DrawWidth = 1
    Pic.Line (B, a)-(c, a), TxtColor
    Pic.Line (c, a)-(c, d), TxtColor
    Pic.Line (c, d)-(B, d), TxtColor
    Pic.Line (B, d)-(B, a), TxtColor
    
    If State = Normal Then
        Tx.BackColor = Tx.BackColor
        Tx.ForeColor = Tx.ForeColor
        Tx.Enabled = True
        Tx.Locked = False
    ElseIf State = Disable Then
        Tx.Enabled = False
        Tx.BackColor = RGB(235, 235, 228)
        Tx.ForeColor = RGB(161, 161, 146)
    ElseIf State = ReadOnly Then
        Tx.Enabled = True
        Tx.Locked = True
    End If
End Function
'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = Tx.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    Tx.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "返回/设置对象中文本和图形的前景色。"
    ForeColor = Tx.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    Tx.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = Tx.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    Tx.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "返回一个 Font 对象。"
Attribute Font.VB_UserMemId = -512
    Set Font = Tx.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set Tx.Font = New_Font
    PropertyChanged "Font"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get BackStyle() As Boolean
Attribute BackStyle.VB_Description = "指出 Label 或 Shape 的背景样式是透明的还是不透明的。"
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Boolean)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

Private Sub Tx_Click()
    RaiseEvent Click
End Sub

Private Sub Tx_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub Tx_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub Tx_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub Tx_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub Tx_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub Tx_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub Tx_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,Text
Public Property Get Text() As String
Attribute Text.VB_Description = "返回/设置控件中包含的文本。"
    Text = Tx.Text
End Property

Public Property Let Text(ByVal New_Text As String)
    Tx.Text() = New_Text
    PropertyChanged "Text"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,ToolTipText
Public Property Get ToolTipText() As String
Attribute ToolTipText.VB_Description = "返回/设置当鼠标在控件上暂停时显示的文本。"
    ToolTipText = Tx.ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
    Tx.ToolTipText() = New_ToolTipText
    PropertyChanged "ToolTipText"
End Property

Private Sub Tx_Change()
    RaiseEvent Change
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,Locked
Public Property Get Locked() As Boolean
Attribute Locked.VB_Description = "决定控件是否可编辑。"
    Locked = Tx.Locked
End Property

Public Property Let Locked(ByVal New_Locked As Boolean)
    Tx.Locked() = New_Locked
    PropertyChanged "Locked"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,PasswordChar
Public Property Get PasswordChar() As String
Attribute PasswordChar.VB_Description = "返回/设置一个值，决定是否在控件中显示用户键入字符或保留区字符。"
    PasswordChar = Tx.PasswordChar
End Property

Public Property Let PasswordChar(ByVal New_PasswordChar As String)
    Tx.PasswordChar() = New_PasswordChar
    PropertyChanged "PasswordChar"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,ScrollBars
Public Property Get ScrollBars() As Integer
Attribute ScrollBars.VB_Description = "返回/设置一个值，指出对象是否有垂直或水平滚动条。"
    ScrollBars = Tx.ScrollBars
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,SelLength
Public Property Get SelLength() As Long
Attribute SelLength.VB_Description = "返回/设置选定的字符数。"
    SelLength = Tx.SelLength
End Property

Public Property Let SelLength(ByVal New_SelLength As Long)
    Tx.SelLength() = New_SelLength
    PropertyChanged "SelLength"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,SelStart
Public Property Get SelStart() As Long
Attribute SelStart.VB_Description = "返回/设置选定文本的起始点。"
    SelStart = Tx.SelStart
End Property

Public Property Let SelStart(ByVal New_SelStart As Long)
    Tx.SelStart() = New_SelStart
    PropertyChanged "SelStart"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,SelText
Public Property Get SelText() As String
Attribute SelText.VB_Description = "返回/设置包含当前选定文本的字符串。"
    SelText = Tx.SelText
End Property

Public Property Let SelText(ByVal New_SelText As String)
    Tx.SelText() = New_SelText
    PropertyChanged "SelText"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=l,l,-1,BackColor
Public Property Get BorderColor() As OLE_COLOR
Attribute BorderColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BorderColor = l.BackColor
End Property

Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
    l.BackColor() = New_BorderColor
    PropertyChanged "BorderColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Tx,Tx,-1,MultiLine
Public Property Get MultiLine() As Boolean
Attribute MultiLine.VB_Description = "返回/设置一个值，决定一个控件是否可以接受多行文本。"
    MultiLine = Tx.MultiLine
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    Tx.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    Tx.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    Tx.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Tx.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    Tx.Text = PropBag.ReadProperty("Text", "Text1")
    Tx.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
    Tx.Locked = PropBag.ReadProperty("Locked", False)
    Tx.PasswordChar = PropBag.ReadProperty("PasswordChar", "")
    Tx.SelLength = PropBag.ReadProperty("SelLength", 0)
    Tx.SelStart = PropBag.ReadProperty("SelStart", 0)
    Tx.SelText = PropBag.ReadProperty("SelText", "")
    l.BackColor = PropBag.ReadProperty("BorderColor", &H8000000F)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", Tx.BackColor, &H80000005)
    Call PropBag.WriteProperty("ForeColor", Tx.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Enabled", Tx.Enabled, True)
    Call PropBag.WriteProperty("Font", Tx.Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("Text", Tx.Text, "Text1")
    Call PropBag.WriteProperty("ToolTipText", Tx.ToolTipText, "")
    Call PropBag.WriteProperty("Locked", Tx.Locked, False)
    Call PropBag.WriteProperty("PasswordChar", Tx.PasswordChar, "")
    Call PropBag.WriteProperty("SelLength", Tx.SelLength, 0)
    Call PropBag.WriteProperty("SelStart", Tx.SelStart, 0)
    Call PropBag.WriteProperty("SelText", Tx.SelText, "")
    Call PropBag.WriteProperty("BorderColor", l.BackColor, &H8000000F)
End Sub