text.ctl

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

VERSION 5.00
Begin VB.UserControl Text 
   BackColor       =   &H00C0C0C0&
   BackStyle       =   0  '透明
   ClientHeight    =   315
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   315
   ScaleWidth      =   4800
   Begin VB.PictureBox Pic 
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   0  'None
      Height          =   330
      Left            =   0
      ScaleHeight     =   330
      ScaleWidth      =   1200
      TabIndex        =   0
      Top             =   0
      Width           =   1200
      Begin VB.TextBox T 
         BorderStyle     =   0  'None
         Height          =   195
         Left            =   15
         TabIndex        =   1
         Text            =   "Text1"
         Top             =   15
         Width           =   945
      End
   End
End
Attribute VB_Name = "Text"
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
'属性变量:
Dim m_BackStyle As Integer
'事件声明:
Event Click() 'MappingInfo=T,T,-1,Click
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick() 'MappingInfo=T,T,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=T,T,-1,KeyDown
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer) 'MappingInfo=T,T,-1,KeyPress
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=T,T,-1,KeyUp
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=T,T,-1,MouseDown
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=T,T,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=T,T,-1,MouseUp
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"




Private Function xptxt(txt As TextBox, Pic As PictureBox, State As states)
'Make sure you have a border of 6 pixels around
'textbox before you use this function

'states = normal, disable, read only
    Pic.ScaleMode = 3
    txt.Appearance = 0
    Pic.AutoRedraw = True
    Dim a, b, c, d As Integer
    a = txt.top + txt.Height + 1
    b = txt.left - 1
    c = txt.left + txt.Width + 1
    d = txt.top - 1
    Pic.DrawWidth = 1
    Pic.Line (b, a)-(c, a), RGB(127, 157, 185)
    Pic.Line (c, a)-(c, d), RGB(127, 157, 185)
    Pic.Line (c, d)-(b, d), RGB(127, 157, 185)
    Pic.Line (b, d)-(b, a), RGB(127, 157, 185)
    
    If State = Normal Then
        txt.BackColor = vbWhite
        txt.Enabled = True
        txt.Locked = False
    ElseIf State = Disable Then
        txt.Enabled = False
        txt.BackColor = RGB(235, 235, 228)
        txt.ForeColor = RGB(161, 161, 146)
    ElseIf State = ReadOnly Then
        txt.Enabled = True
        txt.Locked = True
    End If
End Function

Private Sub UserControl_Resize()
Pic.Width = UserControl.Width
T.Width = Pic.Width - 50
T.Text = Str(T.Width) + Str(UserControl.Width) + Str(Pic.Width)
xptxt T, Pic, Normal

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

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

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

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

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

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

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

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

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

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

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

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

'注意！不要删除或修改下列被注释的行！
'MappingInfo=T,T,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "强制完全重画一个对象。"
    T.Refresh
End Sub

Private Sub T_Click()
    RaiseEvent Click
End Sub

Private Sub T_DblClick()
    RaiseEvent DblClick
End Sub

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

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

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

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

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

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

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

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

    T.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    T.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set T.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    T.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
End Sub

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

    Call PropBag.WriteProperty("BackColor", T.BackColor, &H80000005)
    Call PropBag.WriteProperty("ForeColor", T.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Font", T.Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", T.BorderStyle, 0)
End Sub