nicetip.ctl

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

VERSION 5.00
Begin VB.UserControl NiceToolTip 
   Appearance      =   0  'Flat
   CanGetFocus     =   0   'False
   ClientHeight    =   495
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   510
   ClipControls    =   0   'False
   EditAtDesignTime=   -1  'True
   Enabled         =   0   'False
   InvisibleAtRuntime=   -1  'True
   PropertyPages   =   "NiceTip.ctx":0000
   ScaleHeight     =   495
   ScaleWidth      =   510
   ToolboxBitmap   =   "NiceTip.ctx":002B
   Begin VB.Image Image1 
      Height          =   480
      Left            =   0
      Picture         =   "NiceTip.ctx":033D
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "NiceToolTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public Enum IconMode
   [Exclamation Icon] = 0
   [Question Icon] = 1
   [Information Icon] = 2
   [Critical Icon] = 3
End Enum

'Default Property Values:
Const m_def_TitleColor = &H0&
Const m_def_TipColor = &H0&
Const m_def_Ctrl_hWnd = 0
Const m_def_BackColor = &H9BFFFF
Const m_def_FrameColor = &H0
Const m_def_TipText = "This is the tip!"
Const m_def_TitleText = "Title"
Const m_def_Icon = [Information Icon]

'Property Variables:
Dim m_TitleColor As OLE_COLOR
Dim m_TipColor As OLE_COLOR
Dim m_Ctrl_hWnd As Long
Dim m_BackColor As OLE_COLOR
Dim m_Font As Font
Dim m_FrameColor As OLE_COLOR
Dim m_TipText As String
Dim m_TitleText As String
Dim m_Icon As IconMode

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&HFFFFFF&
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
   BackColor = m_BackColor
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=6,0,0,0
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
   Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
   Set m_Font = New_Font
   TipFontName = m_Font.Name
   PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&9BFFFF&
Public Property Get FrameColor() As OLE_COLOR
Attribute FrameColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
   FrameColor = m_FrameColor
End Property

Public Property Let FrameColor(ByVal New_FrameColor As OLE_COLOR)
   m_FrameColor = New_FrameColor
   PropertyChanged "FrameColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,This is the tip!
Public Property Get TipText() As String
   TipText = m_TipText
End Property

Public Property Let TipText(ByVal New_TipText As String)
   m_TipText = New_TipText
'   TipStr = m_TipText
   PropertyChanged "TipText"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,Title
Public Property Get TitleText() As String
   TitleText = m_TitleText
End Property

Public Property Let TitleText(ByVal New_TitleText As String)
   m_TitleText = New_TitleText
'   TitleStr = m_TitleText
   PropertyChanged "TitleText"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get Icon() As IconMode
   Icon = m_Icon
End Property

Public Property Let Icon(ByVal New_Icon As IconMode)
   m_Icon = New_Icon
   PropertyChanged "Icon"
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()

   m_BackColor = m_def_BackColor
   Set m_Font = Ambient.Font
   m_FrameColor = m_def_FrameColor
   m_TipText = m_def_TipText
   m_TitleText = m_def_TitleText
   m_Icon = m_def_Icon
   m_Ctrl_hWnd = m_def_Ctrl_hWnd
   m_TitleColor = m_def_TitleColor
   m_TipColor = m_def_TipColor
     
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

   m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
   Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
   m_FrameColor = PropBag.ReadProperty("FrameColor", m_def_FrameColor)
   m_TipText = PropBag.ReadProperty("TipText", m_def_TipText)
   m_TitleText = PropBag.ReadProperty("TitleText", m_def_TitleText)
   m_Icon = PropBag.ReadProperty("Icon", m_def_Icon)
   m_Ctrl_hWnd = PropBag.ReadProperty("Ctrl_hWnd", m_def_Ctrl_hWnd)
   m_TitleColor = PropBag.ReadProperty("TitleColor", m_def_TitleColor)
   m_TipColor = PropBag.ReadProperty("TipColor", m_def_TipColor)
   
End Sub

Private Sub UserControl_Resize()
   UserControl.ScaleHeight = 555
   UserControl.ScaleWidth = 495
   UserControl.Size 555, 495
'   Image1.Left = (UserControl.ScaleWidth - Image1.Width) / 2
'   Image1.Top = (UserControl.ScaleHeight - Image1.Height) / 2
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

   Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
   Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
   Call PropBag.WriteProperty("FrameColor", m_FrameColor, m_def_FrameColor)
   Call PropBag.WriteProperty("TipText", m_TipText, m_def_TipText)
   Call PropBag.WriteProperty("TitleText", m_TitleText, m_def_TitleText)
   Call PropBag.WriteProperty("Icon", m_Icon, m_def_Icon)
'   Call PropBag.WriteProperty("Ctrl_hWnd", m_Ctrl_hWnd, m_def_Ctrl_hWnd)
   Call PropBag.WriteProperty("TitleColor", m_TitleColor, m_def_TitleColor)
   Call PropBag.WriteProperty("TipColor", m_TipColor, m_def_TipColor)
   
End Sub

Public Sub ShowTip()
Dim myCurrCurPos As POINTAPI
   
   If m_Ctrl_hWnd = 0 Then
      GetCursorPos myCurrCurPos
      m_Ctrl_hWnd = WindowFromPoint(myCurrCurPos.X, myCurrCurPos.Y)
      CtrlhWnd = m_Ctrl_hWnd
   Else
      GetCursorPos myCurrCurPos
      If m_Ctrl_hWnd = WindowFromPoint(myCurrCurPos.X, myCurrCurPos.Y) Then
         CtrlhWnd = m_Ctrl_hWnd
      Else
         Exit Sub
      End If
   End If
   
   TipFontName = m_Font.Name
   TipFontSize = m_Font.Size
   iIcon = Icon
   BackCol = m_BackColor
   FrameCol = m_FrameColor
   TipStr = m_TipText
   TitleStr = m_TitleText
   TipCol = m_TipColor
   TitleCol = m_TitleColor
   
   Load frmToolTip
   
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get Ctrl_hWnd() As Long
   Ctrl_hWnd = m_Ctrl_hWnd
End Property

Public Property Let Ctrl_hWnd(ByVal New_Ctrl_hWnd As Long)
   m_Ctrl_hWnd = New_Ctrl_hWnd
'   CtrlhWnd = m_Ctrl_hWnd
   PropertyChanged "Ctrl_hWnd"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H0&
Public Property Get TitleColor() As OLE_COLOR
   TitleColor = m_TitleColor
End Property

Public Property Let TitleColor(ByVal New_TitleColor As OLE_COLOR)
   m_TitleColor = New_TitleColor
   PropertyChanged "TitleColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H0&
Public Property Get TipColor() As OLE_COLOR
   TipColor = m_TipColor
End Property

Public Property Let TipColor(ByVal New_TipColor As OLE_COLOR)
   m_TipColor = New_TipColor
   PropertyChanged "TipColor"
End Property