标签.ctl

自制标签文件。可以增加系统的标签没有的功能

VERSION 5.00
Begin VB.UserControl SuperLabel 
   BackColor       =   &H00000000&
   BackStyle       =   0  '透明
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ClipBehavior    =   0  '无
   HitBehavior     =   0  '无
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "标签.ctx":0000
   Windowless      =   -1  'True
   Begin VB.Timer tmrFlashBack 
      Enabled         =   0   'False
      Interval        =   300
      Left            =   2400
      Top             =   2190
   End
   Begin VB.Timer tmrFrash 
      Enabled         =   0   'False
      Interval        =   300
      Left            =   1230
      Top             =   2160
   End
End
Attribute VB_Name = "SuperLabel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Const def_ID = ""
Const def_NameColor = &HFFFFFF

Dim m_ID As String
Dim H As Double
Dim W As Double
Dim m_ShowID As Boolean

Dim m_WorkStation As ZD

Public Enum ZD
   学员机
   教练机
End Enum
  
Public Enum BK
   透明
   不透明
End Enum
  
Public Type Coordinate
  X As Double
  Y As Double
  X1 As Double
  Y1 As Double
  X2 As Double
  Y2 As Double
  Top As Double
  Left As Double
  Right As Double
  Height As Double
  Width As Double
  Bottom As Double
End Type

Dim m_NameSite As Coordinate

Dim m_Flash As Boolean
Dim blnFocus As Boolean
Dim m_FlashBackCol1 As OLE_COLOR, m_FlashBackCol2 As OLE_COLOR
 
'缺省属性值:
Const m_def_BackStyle = 0
Const m_def_OutlineWidth = 1
Const m_def_OutlineColor = vbRed
Const m_def_Outline = False
Const m_def_ForeColor = vbWhite
Const m_def_BackColor = vbBlack
Const m_def_AutoSize = 0
'属性变量:
Dim m_BackStyle As BK
Dim m_OutlineWidth As Integer
Dim m_OutlineColor As OLE_COLOR
Dim m_Outline As Boolean
Dim m_ForeColor As OLE_COLOR
Dim m_BackColor As OLE_COLOR
Dim m_AutoSize As Boolean

Event Click()
Event MouseUp(Button As Integer, X As Single, Y As Single)
Event MouseDown(Button As Integer, X As Single, Y As Single)
Event CaptionChanged(OldCaption As String, NewCaption As String)

Private Sub UserControl_Click()
   If blnFocus Then
      If m_WorkStation = 教练机 Then
         RaiseEvent Click
      End If
   End If
End Sub

Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer)
   If IsInName(X, Y) Then
      HitResult = vbHitResultHit
   Else
      HitResult = vbHitResultClose
   End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If blnFocus Then
      If m_WorkStation = 教练机 Then
         RaiseEvent MouseDown(Button, X, Y)
      End If
   End If
End Sub

Private Sub UserControl_Mouseup(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If blnFocus Then
      If m_WorkStation = 教练机 Then
         RaiseEvent MouseUp(Button, X, Y)
      End If
   End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   blnFocus = False
   If m_WorkStation = 教练机 Then              '鼠标操作
      If X > 0 And X < UserControl.ScaleWidth And Y > 0 And Y < UserControl.ScaleHeight Then
         blnFocus = True
         SetCapture UserControl.hwnd
         MousePointer = 99: UserControl.MouseIcon = LoadPicture(App.Path & "\hand.ico")
      Else
         ReleaseCapture
         MousePointer = 0
      End If
   End If
End Sub

Private Function IsInName(X As Single, Y As Single) As Boolean
   If X >= m_NameSite.Left And X <= m_NameSite.Right And Y >= m_NameSite.Top And Y <= m_NameSite.Bottom Then
      IsInName = True
   End If
End Function

Private Sub tmrFlashBack_Timer()
   Static blnFlag As Boolean
   If blnFlag Then
      UserControl.BackColor = m_FlashBackCol1
   Else
      UserControl.BackColor = m_FlashBackCol2
   End If
   UserControl.Refresh
   
   blnFlag = Not blnFlag
End Sub

Private Sub tmrFrash_Timer()
   Static Flag As Boolean
   CurrentX = m_NameSite.Left
   CurrentY = m_NameSite.Top
   UserControl.ForeColor = IIf(Flag, m_ForeColor, UserControl.BackColor)
   Print m_ID
   Flag = Not Flag
End Sub

'显示名称
Public Property Get Caption() As String
   Caption = m_ID
End Property

Public Property Let Caption(ByVal vNewValue As String)
   Dim ss As String
   ss = m_ID
   m_ID = vNewValue
   PropertyChanged "Caption"
   RaiseEvent CaptionChanged(ss, vNewValue)
   UserControl.Refresh
End Property

'显示字体大小
Public Property Get Font() As Font
   Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal vNewValue As Font)
   Set UserControl.Font = vNewValue
   PropertyChanged "Font"
   UserControl.Refresh
End Property

Public Property Get BackColor() As OLE_COLOR
   BackColor = m_BackColor
End Property

Public Property Let BackColor(ByVal vNewValue As OLE_COLOR)
   m_BackColor = vNewValue
   PropertyChanged "BackColor"
   UserControl.Refresh
End Property

Private Sub UserControl_InitProperties()
   m_ID = def_ID
'   m_ForeColor = def_NameColor
   m_ShowID = True
   m_WorkStation = 学员机
   m_AutoSize = m_def_AutoSize
   m_ForeColor = m_def_ForeColor
   m_BackColor = m_def_BackColor
   m_Flash = False
   m_Outline = m_def_Outline
'   m_OutlineWidth = m_def_OutlineWidth
   m_OutlineColor = m_def_OutlineColor
   m_OutlineWidth = m_def_OutlineWidth
   m_BackStyle = m_def_BackStyle
End Sub

Private Sub UserControl_Paint()
   If m_AutoSize Then
      UserControl.Width = TextWidth(m_ID) * 15
      UserControl.Height = TextHeight(m_ID) * 15
   End If
   
   H = UserControl.ScaleHeight
   W = UserControl.ScaleWidth
   
   
   If Not tmrFlashBack.Enabled Then
      UserControl.BackColor = m_BackColor
   End If
   If m_BackStyle = 不透明 Then
      Line (0, 0)-(W, H), UserControl.BackColor, BF
   End If
   m_NameSite.Left = (W - TextWidth(m_ID)) / 2
   m_NameSite.Top = (H - TextHeight(m_ID)) / 2
   m_NameSite.Right = m_NameSite.Left + TextWidth(m_ID)
   m_NameSite.Bottom = m_NameSite.Top + TextHeight(m_ID)
   CurrentX = m_NameSite.Left
   CurrentY = m_NameSite.Top
   UserControl.ForeColor = m_ForeColor
   Print m_ID
   If m_Outline Then
      FillStyle = 1
      DrawWidth = m_OutlineWidth
      Line (m_NameSite.Left, m_NameSite.Top)-(m_NameSite.Right, m_NameSite.Bottom), m_OutlineColor, B
   End If
   
   tmrFrash.Enabled = m_Flash
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
   m_ID = PropBag.ReadProperty("Caption", def_ID)
   m_ShowID = PropBag.ReadProperty("ShowID", True)
   m_WorkStation = PropBag.ReadProperty("WorkStation", 0)
   m_AutoSize = PropBag.ReadProperty("AutoSize", m_def_AutoSize)
   m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
   m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
   m_Outline = PropBag.ReadProperty("Outline", m_def_Outline)
'   m_OutlineWidth = PropBag.ReadProperty("OutlineWidth", m_def_OutlineWidth)
   m_OutlineColor = PropBag.ReadProperty("OutlineColor", m_def_OutlineColor)
   m_OutlineWidth = PropBag.ReadProperty("OutlineWidth", m_def_OutlineWidth)
   m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
   Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
   Call PropBag.WriteProperty("Caption", m_ID, def_ID)
   Call PropBag.WriteProperty("ShowID", m_ShowID, True)
   Call PropBag.WriteProperty("WorkStation", m_WorkStation, 0)
   Call PropBag.WriteProperty("AutoSize", m_AutoSize, m_def_AutoSize)
   Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
   Call PropBag.WriteProperty("Outline", m_Outline, m_def_Outline)
'   Call PropBag.WriteProperty("OutlineWidth", m_OutlineWidth, m_def_OutlineWidth)
   Call PropBag.WriteProperty("OutlineColor", m_OutlineColor, m_def_OutlineColor)
   Call PropBag.WriteProperty("OutlineWidth", m_OutlineWidth, m_def_OutlineWidth)
   Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
End Sub

Public Sub Refresh()
   UserControl.Refresh
End Sub

Public Property Get ShowID() As Boolean
   ShowID = m_ShowID
End Property

Public Property Let ShowID(ByVal New_ShowID As Boolean)
   m_ShowID = New_ShowID
   PropertyChanged "ShowID"
   UserControl.Refresh
End Property

Public Property Get WorkStation() As ZD
Attribute WorkStation.VB_Description = "教练机状态可以接受鼠标事件"
  WorkStation = m_WorkStation
End Property

Public Property Let WorkStation(ByVal vNewValue As ZD)
  m_WorkStation = vNewValue
  PropertyChanged "WorkStation"
End Property
 
Public Property Get Flash() As Boolean
   Flash = m_Flash
End Property

Public Property Let Flash(ByVal vNewValue As Boolean)
   m_Flash = vNewValue
   PropertyChanged "Flash"
   UserControl.Refresh
End Property

'
'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get AutoSize() As Boolean
Attribute AutoSize.VB_Description = "决定控件是否能自动调整大小以显示所有的内容。"
   AutoSize = m_AutoSize
End Property

Public Property Let AutoSize(ByVal New_AutoSize As Boolean)
   m_AutoSize = New_AutoSize
   PropertyChanged "AutoSize"
   UserControl.Refresh
End Property
'
'
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,
Public Property Get ForeColor() As OLE_COLOR
   ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
   m_ForeColor = New_ForeColor
   PropertyChanged "ForeColor"
   UserControl.Refresh
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Sub FlashBack(Col1 As OLE_COLOR, Col2 As OLE_COLOR, blnFlag As Boolean)
Attribute FlashBack.VB_Description = "背景闪烁"
   tmrFlashBack.Enabled = blnFlag
   If blnFlag Then
      m_FlashBackCol1 = Col1
      m_FlashBackCol2 = Col2
   Else
      UserControl.BackColor = m_BackColor
      UserControl.Refresh
   End If
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,false
Public Property Get Outline() As Boolean
Attribute Outline.VB_Description = "文字外是否有外框"
   Outline = m_Outline
End Property

Public Property Let Outline(ByVal New_Outline As Boolean)
   m_Outline = New_Outline
   PropertyChanged "Outline"
   UserControl.Refresh
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,vbred
Public Property Get OutlineColor() As OLE_COLOR
Attribute OutlineColor.VB_Description = "外框颜色"
   OutlineColor = m_OutlineColor
End Property

Public Property Let OutlineColor(ByVal New_OutlineColor As OLE_COLOR)
   m_OutlineColor = New_OutlineColor
   PropertyChanged "OutlineColor"
   UserControl.Refresh
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,1
Public Property Get OutlineWidth() As Integer
Attribute OutlineWidth.VB_Description = "外框线条粗细"
   OutlineWidth = m_OutlineWidth
End Property

Public Property Let OutlineWidth(ByVal New_OutlineWidth As Integer)
   m_OutlineWidth = New_OutlineWidth
   PropertyChanged "OutlineWidth"
   UserControl.Refresh
End Property

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

Public Property Let BackStyle(ByVal New_BackStyle As BK)
   m_BackStyle = New_BackStyle
   PropertyChanged "BackStyle"
   UserControl.Refresh
End Property