focustext.ctl

星级酒店管理系统（附带系统自写控件源码）

VERSION 5.00
Begin VB.UserControl GridFocusText 
   ClientHeight    =   315
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2340
   LockControls    =   -1  'True
   ScaleHeight     =   315
   ScaleWidth      =   2340
   ToolboxBitmap   =   "FocusText.ctx":0000
   Begin VB.TextBox MyText 
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   300
      Left            =   75
      TabIndex        =   0
      Top             =   45
      Width           =   2025
   End
   Begin VB.Line lBottom 
      BorderColor     =   &H00FFFFFF&
      Visible         =   0   'False
      X1              =   90
      X2              =   3705
      Y1              =   330
      Y2              =   330
   End
   Begin VB.Line lRight 
      BorderColor     =   &H00FFFFFF&
      Visible         =   0   'False
      X1              =   3645
      X2              =   3645
      Y1              =   45
      Y2              =   675
   End
   Begin VB.Line lLeft 
      BorderColor     =   &H00808080&
      Visible         =   0   'False
      X1              =   30
      X2              =   30
      Y1              =   30
      Y2              =   690
   End
   Begin VB.Line lTop 
      BorderColor     =   &H00808080&
      BorderWidth     =   2
      Visible         =   0   'False
      X1              =   45
      X2              =   3645
      Y1              =   30
      Y2              =   30
   End
End
Attribute VB_Name = "GridFocusText"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'缺省属性值:
Const m_def_LineOut = 0
Const m_def_TextType = 0
Const m_def_BackStyle = 1
Const m_def_GotBackColor = &HFF0000
Const m_def_GotForeColor = &H80000005
Const m_def_LostBackColor = &H80000005
Const m_def_LostForeColor = &H80000008

Enum MyType
   普通文本类型
   无小数点数字
   有小数点数字
End Enum

Enum OutType
   固定边框
   浮动边框
End Enum

'属性变量:
Dim m_LineOut As OutType
Dim m_TextType As MyType
Dim m_PreControl As String
Dim m_NextControl As String
Dim m_BackStyle As Integer

Dim m_GotBackColor As OLE_COLOR
Dim m_GotForeColor As OLE_COLOR
Dim m_LostBackColor As OLE_COLOR
Dim m_LostForeColor As OLE_COLOR
'事件声明:
Event Change() 'MappingInfo=MyText,MyText,-1,Change
Attribute Change.VB_Description = "当控件内容改变时发生。"
Event Click() 'MappingInfo=MyText,MyText,-1,Click
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick() 'MappingInfo=MyText,MyText,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=MyText,MyText,-1,KeyDown
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer) 'MappingInfo=MyText,MyText,-1,KeyPress
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=MyText,MyText,-1,KeyUp
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=MyText,MyText,-1,MouseDown
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=MyText,MyText,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=MyText,MyText,-1,MouseUp
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"

Private Sub MyText_GotFocus()
 
  If LineOut = 浮动边框 Then
     LineVisible True
  End If
  
  MyText.SelStart = 0
  MyText.SelLength = Len(MyText.Text)
  MyText.BackColor = GotBackColor
  MyText.ForeColor = GotForeColor
  
End Sub

Private Sub MyText_LostFocus()

  If LineOut = 浮动边框 Then
     LineVisible False
  End If
  MyText.BackColor = LostBackColor
  MyText.ForeColor = LostForeColor
  
End Sub

Private Sub UserControl_Resize()

   On Error Resume Next
   
   If UserControl.Height < 300 Then
      UserControl.Height = 300
      Exit Sub
   End If
   
   If UserControl.Width < 300 Then
      UserControl.Width = 300
      Exit Sub
   End If
   
   MyText.Left = 25
   MyText.Top = 25
   
   lTop.X1 = 3
   lTop.Y1 = 3
   lTop.Y2 = 3
   lTop.X2 = UserControl.Width - 6
   lLeft.X1 = 3
   lLeft.X2 = 3
   lLeft.Y1 = 3
   lLeft.Y2 = UserControl.Height - 4
   lBottom.X1 = lTop.X1
   lBottom.X2 = lTop.X2 + 8
   lBottom.Y1 = UserControl.Height - 10
   lBottom.Y2 = UserControl.Height - 10
   
   lTop.Y1 = 3
   lTop.Y2 = 3
   lBottom.X2 = lTop.X2
   lRight.X1 = UserControl.Width - 8
   lRight.X2 = UserControl.Width - 8
   lRight.Y1 = lLeft.Y1
   lRight.Y2 = lLeft.Y2
   
   MyText.Width = UserControl.Width - 60
   MyText.Height = UserControl.Height - 60
  
End Sub
'注意！不要删除或修改下列被注释的行！
'MappingInfo=MyText,MyText,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = MyText.BackColor
End Property

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

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

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

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

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

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

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

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

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

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

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

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

Private Sub MyText_Click()
    RaiseEvent Click
End Sub

Private Sub MyText_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub MyText_KeyDown(KeyCode As Integer, Shift As Integer)
    
  '判断类型
   'DirectFocus PreControl, NextControl, MyText, MyText, KeyCode
   RaiseEvent KeyDown(KeyCode, Shift)
    
End Sub

Private Sub MyText_KeyPress(KeyAscii As Integer)
   
   If TextType = 无小数点数字 Then
      If KeyAscii = 8 Then  '删除键与回退键
         Exit Sub
       Else
         If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 45 Then
            KeyAscii = 0
            Exit Sub
         End If
      End If
   End If
   If TextType = 有小数点数字 Then
      If KeyAscii = 8 Then  '删除键与回退键
         Exit Sub
       ElseIf InStr(1, MyText.Text, ".", vbTextCompare) Then
         If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 45 Then
            KeyAscii = 0
            Exit Sub
         End If
        Else
         If ((KeyAscii < 46 Or KeyAscii = 47) Or KeyAscii > 57) And KeyAscii <> 45 Then
            KeyAscii = 0
            Exit Sub
         End If
      End If
   End If
   
   RaiseEvent KeyPress(KeyAscii)
   
End Sub

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

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

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