formdemo.frm

工具条演示程序 工具条演示程序

      Index           =   0
      Left            =   5160
      TabIndex        =   8
      Top             =   8640
      Width           =   2355
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2006/11/04
'描    述：多风格气球式信息提示 Ver 1.0
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit


Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Const DefaultFont = "Arial"  '//-- 默认示例字体

Private C        As ExToolTip        '//-- 声明 ExTooltip 类
Private MDown    As Boolean          '//-- Flag Used in ColorPicker for MouseDown Capture
Private MMove    As Boolean          '//-- Flag Used in ColorPicker for MouseMove Capture


Private Sub Form_Initialize()
InitCommonControls                   '//-- Registers and initializes the common control window classes.
End Sub

Private Sub Form_Terminate()
Set C = Nothing                      '//-- Release all the system and memory resources associated with Class.
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If MMove Then MMove = False
End Sub

Private Sub Form_Load()
Dim enumFonts    As Long

For enumFonts = 0 To VB.Screen.FontCount - 1                                    '//--Enumerate All System Fonts
    CboFont.AddItem Screen.Fonts(enumFonts)                                     '//--Add Each Font To ComboBox
    If Screen.Fonts(enumFonts) = DefaultFont Then CboFont.ListIndex = enumFonts '//--Demo Default Font as 1st Item in ComboList.
Next enumFonts
 
Set C = New ExToolTip             '//-- Creates a new instance of theclass.

cboStyle.ListIndex = 0            '//-- Combo 1st Item = Solid
CboImageSize.ListIndex = 3        '//-- Combo 1st Item = TTIcon48
OptionBack_Click 0                '//-- Assign Demo Image as ExTooltip BackGround Picture

End Sub

Private Sub CboFont_Change()
C.Font.Name = CboFont.List(CboFont.ListIndex)
End Sub

Private Sub CheckBalloon_Click()
C.ToolTipStyle = IIf(CheckBalloon.Value = 1, 1, 0)
End Sub

Private Sub cboStyle_Click()
C.BackStyle = cboStyle.ListIndex + 1
End Sub


Private Sub SliderTT_Click()
C.DelayTime = SliderTT.Value
End Sub

Private Sub SliderTTT_Click()
C.KillTime = SliderTTT.Value
End Sub

Private Sub CheckShadow_Click()
C.Shadow = IIf(CheckShadow.Value = 1, True, False)
End Sub

Private Sub OptionBack_Click(Index As Integer)
Set C.Picture = PictureBack(Index)
End Sub

Private Sub ApplyDemoValues() '//--Default Values used in Demo
               
        '//-- Remember each time a new Tooltip is created if the
        '     user doesn't specify any parameters values like this ones,
        '     the default values are going to be the Extooltip default values.(See ExTooltip Class_Initialize).
        
        C.DelayTime = SliderTT.Value
        C.KillTime = SliderTTT.Value
        C.BackColor = TBackcolor.BackColor
        C.TextColor = TTextColor.BackColor
        C.GradientColorStart = TGSColor.BackColor
        C.GradientColorEnd = TGEColor.BackColor
        C.BackStyle = cboStyle.ListIndex + 1
        C.Font.Name = CboFont.List(CboFont.ListIndex)
        C.Shadow = IIf(CheckShadow.Value = 1, True, False)
        C.ToolTipStyle = IIf(CheckBalloon.Value = 1, 1, 0)

End Sub


'==============================================================================
'A Picker Color Function that enables the user to extract a color from a Bitmap
'==============================================================================

Private Sub ColorPicker_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim R      As Integer
Dim G      As Integer
Dim B      As Integer
Dim PixCol As Long

'Assign Color
PixCol = GetPixel(ColorPicker.hdc, X, Y)

'Convert to RGB
R = PixCol Mod 256
B = Int(PixCol / 65536)
G = (PixCol - (B * 65536) - R) / 256

'Sanity Checks
If R < 0 Then R = 0
If G < 0 Then G = 0
If B < 0 Then B = 0

'Visual Color Table
ShapeColor.BackColor = RGB(R, G, B)

If Option1.Value = True Then
    C.TextColor = ShapeColor.BackColor
    TTextColor.BackColor = ShapeColor.BackColor
ElseIf Option2.Value = True Then
    C.BackColor = ShapeColor.BackColor
    TBackcolor.BackColor = ShapeColor.BackColor
ElseIf Option3.Value = True Then
    C.GradientColorStart = ShapeColor.BackColor
    TGSColor.BackColor = ShapeColor.BackColor
ElseIf Option4.Value = True Then
    C.GradientColorEnd = ShapeColor.BackColor
    TGEColor.BackColor = ShapeColor.BackColor
End If

MDown = True

End Sub

Private Sub ColorPicker_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MDown Then ColorPicker_MouseDown Button, Shift, X, Y
End Sub

Private Sub ColorPicker_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
MDown = False
End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = TTIcon72
          C.BackColor = &H8000&
          C.TextColor = &HFF00&
          C.Font.Name = "宋体"
          C.Font.Size = 9
          C.ShowToolTip Command1.hwnd, "退出示例", _
          "欢迎再次访问枕善居 http:/mndsoft.com." _
          , ImageListC.ListImages(9).Picture, SliderT.Value
    End If
        
End Sub

Private Sub CboImageSize_DropDown()
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = 16
          C.ShowToolTip CboImageSize.hwnd, "Warning!", _
          "Using diferent Image size can change Image Aspect." _
          , ImageListC.ListImages(2).Picture, SliderT.Value
    End If
End Sub

Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = Choose(CboImageSize.ListIndex + 1, 16, 24, 32, 48, 72)
          C.ShowToolTip Picture2.hwnd, "Microsoft Access", _
          "Microsoft Access is a powerful program to create and manage your databases." & _
          vbCrLf & "It has many built in features to assist you in manage and viewing your information." _
          , Picture2.Picture, SliderT.Value
    End If
End Sub

Private Sub Picture3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = Choose(CboImageSize.ListIndex + 1, 16, 24, 32, 48, 72)
          C.ShowToolTip Picture3.hwnd, "这个提示气泡真漂亮", "是啊，真漂亮", Picture3.Picture, SliderT.Value
    End If
End Sub

Private Sub Picture4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = Choose(CboImageSize.ListIndex + 1, 16, 24, 32, 48, 72)
          C.ShowToolTip Picture4.hwnd, "Microsoft PowerPoint", _
          "Microsoft PowerPoint is a powerful tool to create professional looking presentations and slide shows." & _
          vbCrLf & "PowerPoint allows you to build presentations from scratch or by using the easy to use wizard." _
          , Picture4.Picture, SliderT.Value
    End If
End Sub

Private Sub Picture5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = Choose(CboImageSize.ListIndex + 1, 16, 24, 32, 48, 72)
          C.ShowToolTip Picture5.hwnd, "Microsoft Word", _
          "Microsoft Word is a powerful tool to create professional looking documents." _
          , Picture5.Picture, SliderT.Value
    End If
End Sub

Private Sub Picture6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = Choose(CboImageSize.ListIndex + 1, 16, 24, 32, 48, 72)
          C.ShowToolTip Picture6.hwnd, "Microsoft Publisher", _
          "Microsoft Publisher helps you easily create," & vbCrLf & _
          "customize and publish materials such as newsletters," & vbCrLf & _
          "brochures, flyers, catalogs, and Web sites." _
          , Picture6.Picture, SliderT.Value
    End If
End Sub

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.ShowToolTip Text1.hwnd, "Caps Lock is On ", _
          "Having Caps Lock on may cause you to enter your password" & _
          vbCrLf & "incorrectly." & _
          vbCrLf & _
          vbCrLf & "You should press Caps Lock to turn it off before entering your" & _
          vbCrLf & "password.", TTI_WARNING, SliderT.Value
      End If
End Sub

Private Sub Text2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.ShowToolTip Text2.hwnd, "Did you forget your password?", _
          "You can click the ? button to see your password hint." & _
          vbCrLf & _
          vbCrLf & "Please type your password again." & _
          vbCrLf & "Be sure yo use the correct uppercase and lowercase letters." _
          , TTI_ERROR, SliderT.Value
      End If
End Sub

Private Sub Text3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.ShowToolTip Text3.hwnd, "密码提示:", _
          "Visual Basic 版本的多风格气球式信息提示 Ver 1.0" _
          , TTI_INFO, SliderT.Value
      End If
End Sub

Private Sub Text4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
       If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.IconSize = 72
          C.ShowToolTip Text4.hwnd, "枕善居欢迎您", "多风格气球式信息提示 Ver 1.0 " & _
          vbCrLf & "一个很漂亮的程序" _
          , ImageListC.ListImages(4).Picture, SliderT.Value
       End If
End Sub

Private Sub Text5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.BackColor = vbWhite
          C.TextColor = vbBlack
          C.IconSize = 72
          C.ShowToolTip Text5.hwnd, "多风格气球式信息提示 Ver 1.0", "枕善居 http://www.mndsoft.com", ImageListC.ListImages(5).Picture, SliderT.Value
    End If
End Sub

Private Sub Text6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.BackColor = &H40C0&
          C.TextColor = &H80FF&
          C.IconSize = 16
          C.ShowToolTip Text6.hwnd, "WinZip压缩软件", "访问 www.winzip.com", ImageListC.ListImages(6).Picture, 70
    End If
End Sub

Private Sub Text7_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.BackColor = &HC8&
          C.TextColor = vbWhite
          C.IconSize = 72
          C.ShowToolTip Text7.hwnd, "我喜欢可口可乐", "访问 www.cocacola.com", ImageListC.ListImages(7).Picture, SliderT.Value
    End If
End Sub

Private Sub Text8_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.Font.Name = "Verdana"
          C.Font.Size = 7
          C.IconSize = 72
          C.BackColor = &HC00000
          C.TextColor = &HFFFF00
          C.ShowToolTip Text8.hwnd, "给本站发送邮件", _
          "[e-mail]", ImageListC.ListImages(8).Picture, SliderT.Value
      End If
End Sub

Private Sub Text9_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.Font.Size = 10
          C.Font.Italic = True
          C.ShowToolTip Text9.hwnd, "多风格气球式信息提示 Ver 1.0", _
          "   您可以自定义气球式信息提示" & _
          vbCrLf & "   1.自定义信息样式" & _
          vbCrLf & "   2.是否使用透明模式" & _
          vbCrLf & "   3.支持多行文本显示" & _
          vbCrLf & "   4.你可以使用任意系统字体" & _
          vbCrLf & "   5.适用于 Windows NT,98,ME,2000,2003,XP ", 0, SliderT.Value
      End If
End Sub

Private Sub Text10_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
           C.ShowToolTip Text10.hwnd, "您是否很喜欢自定义图标?", _
          "在气泡提示中显示自定义图标.", _
          ImageListC.ListImages(1).Picture, SliderT.Value
      End If
End Sub

Private Sub Text11_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.ShowToolTip Text11.hwnd, "您是否很喜欢自定义图标?", _
          "在气泡提示中显示自定义图标.", _
          ImageListC.ListImages(3).Picture, SliderT.Value
      End If
End Sub

Private Sub Text12_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
           C.ShowToolTip Text12.hwnd, "您是否很喜欢自定义图标?", _
          "在气泡提示中显示自定义图标.", _
          ImageListC.ListImages(2).Picture, SliderT.Value
      End If
End Sub

Private Sub Textwelcome_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      If Not MMove Or C.Alive = False Then
          MMove = True
          ApplyDemoValues
          C.ShowToolTip Textwelcome.hwnd, "多风格气球式信息提示 Ver 1.0", _
          "   您可以自定义气球式信息提示" & _
          vbCrLf & "   1.自定义信息样式" & _
          vbCrLf & "   2.是否使用透明模式" & _
          vbCrLf & "   3.支持多行文本显示" & _
          vbCrLf & "   4.你可以使用任意系统字体" & _
          vbCrLf & "   5.适用于 Windows NT,98,ME,2000,2003,XP ", 0, SliderT.Value
      End If
End Sub