frmtip.frm

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

VERSION 5.00
Begin VB.Form frmToolTip 
   Appearance      =   0  'Flat
   BackColor       =   &H00E0E0E0&
   BorderStyle     =   0  'None
   ClientHeight    =   870
   ClientLeft      =   -4995
   ClientTop       =   -4995
   ClientWidth     =   1095
   ControlBox      =   0   'False
   Enabled         =   0   'False
   ForeColor       =   &H00808000&
   Icon            =   "frmTip.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   870
   ScaleWidth      =   1095
   ShowInTaskbar   =   0   'False
   Begin VB.Timer tmrToolTip 
      Enabled         =   0   'False
      Interval        =   300
      Left            =   3885
      Top             =   75
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H00FFFFFF&
      BorderColor     =   &H000000C0&
      DrawMode        =   1  'Blackness
      FillColor       =   &H008080FF&
      Height          =   870
      Left            =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   1080
   End
   Begin VB.Label lblTitle 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   180
      Left            =   555
      TabIndex        =   1
      Top             =   105
      Width           =   45
   End
   Begin VB.Label lblTip 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   180
      Left            =   120
      TabIndex        =   0
      Top             =   450
      UseMnemonic     =   0   'False
      Width           =   45
   End
   Begin VB.Image imgIcon 
      Height          =   240
      Left            =   600
      Top             =   135
      Width           =   240
   End
   Begin VB.Image imageIcon 
      Height          =   240
      Index           =   0
      Left            =   1950
      Picture         =   "frmTip.frx":030A
      Top             =   105
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imageIcon 
      Height          =   240
      Index           =   1
      Left            =   1950
      Picture         =   "frmTip.frx":0894
      Top             =   360
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imageIcon 
      Height          =   240
      Index           =   2
      Left            =   1950
      Picture         =   "frmTip.frx":0E1E
      Top             =   645
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imageIcon 
      Height          =   240
      Index           =   3
      Left            =   1950
      Picture         =   "frmTip.frx":13A8
      Top             =   900
      Visible         =   0   'False
      Width           =   240
   End
End
Attribute VB_Name = "frmToolTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim isExecuted As Boolean, PhWnd As Long
Dim myRect As RECT

Private Sub doToolTip()
Dim X As Long, Y As Long
Dim typRect As POINTAPI
Dim myRgn As Long, myRgn2 As Long

   GetCursorPos typRect
   X = (typRect.X * Screen.TwipsPerPixelX) - 450
   Y = (typRect.Y * Screen.TwipsPerPixelY) + 300
   
   iFlag = 0
   
   With Me
   
      If Screen.Width < X + .Width + 250 Then
         myP(0).X = Shape1.Width / 15 - 35
         myP(1).X = Shape1.Width / 15 - 25
         myP(2).X = Shape1.Width / 15 - 20
         myP(3).X = Shape1.Width / 15 - 35
      End If
      
      If Y - .Height - 350 < 0 Then
         iFlag = 15
         lblTitle.Top = lblTitle.Top + iFlag * 15
         imgIcon.Top = imgIcon.Top + iFlag * 15
         lblTip.Top = lblTip.Top + iFlag * 15
         myP(0).Y = iFlag
         myP(1).Y = iFlag
         myP(2).Y = 0
         myP(3).Y = iFlag
      End If
      
   End With
   
   myRgn = CreateRoundRectRgn(0, iFlag, (Shape1.Width + 15) / 15, (Shape1.Height + 15) / 15 + iFlag, 13, 13)
   myRgn2 = CreatePolygonRgn(myP(0), 4, 1)
   CombineRgn myRgn, myRgn2, myRgn, 2
   
   SetWindowRgn Me.hWnd, myRgn, False

   Load frmShadow
   
   On Error GoTo errHandler
   
   With Me
      .Move X - 10 * 15 + myP(2).X * 15, Y - myP(2).Y * 15 - 25 * 15 + iFlag * 10
      If Screen.Width < X + .Width + 250 Then
         .Move .Left - myP(2).X * 15 - (Me.Width) + 60 * 15
      End If
      
      frmShadow.Move .Left + 30, .Top + 30
      SetWindowPos .hWnd, -1, 0, 0, 0, 0, &H10 Or &H2 Or &H1 Or &H40 Or &H200
   End With
   
   DeleteObject myRgn
   DeleteObject myRgn2
   
   Exit Sub

errHandler:

   Unload Me

End Sub

Private Sub Form_Load()

   Me.BackColor = BackCol
   Me.ForeColor = FrameCol
   
   lblTip.FontSize = TipFontSize
   lblTip.FontName = TipFontName
   lblTip.ForeColor = TipCol
   lblTip.Caption = TipStr
   lblTip.Left = 150
   lblTip.Refresh
   
   lblTitle.FontSize = TipFontSize
   lblTitle.FontName = TipFontName
   lblTitle.ForeColor = TitleCol
   lblTitle.Caption = TitleStr
   lblTitle.Left = 460
   lblTitle.Refresh
   
   imgIcon.Picture = imageIcon(iIcon).Picture
   imgIcon.Top = 90
   imgIcon.Left = 120
   
   lblTitle.Top = ((imgIcon.Height - lblTitle.Height) / 2) + imgIcon.Top
   
   Shape1.Width = lblTip.Width + 150 + 150
   Shape1.Height = lblTip.Top + lblTip.Height + 120
   Me.Width = Shape1.Width
   Me.Height = Shape1.Height + 30 * 15
   
   myP(0).X = 35: myP(0).Y = Shape1.Height / 15 - 1
   myP(1).X = 25: myP(1).Y = Shape1.Height / 15 - 1
   myP(2).X = 20: myP(2).Y = Shape1.Height / 15 + 15
   myP(3).X = 35: myP(3).Y = Shape1.Height / 15 - 1
    
   tmrToolTip.Enabled = True
   
End Sub

Private Sub Form_Paint()
Dim lLine As Long, lColor As Long, lColStep As Long, VarRGB As Integer
Dim theRGB As String, RVal As Integer, GVal As Integer, BVal As Integer
Dim myRgn As Long, myRgn2 As Long, theBrush As Long
On Error Resume Next

   lColStep = 155 / ((Shape1.Height / 15) / 2)
   VarRGB = lColStep
   
   theRGB = String(6 - Len(Hex(Me.BackColor)), "0") & Hex(Me.BackColor)
   
   RVal = CInt("&H" & Right(theRGB, 2))
   GVal = CInt("&H" & Mid(theRGB, 3, 2))
   BVal = CInt("&H" & Left(theRGB, 2))
   
   lColor = RGB(RVal, GVal, BVal)

   For lLine = 0 To Shape1.Height + (15 * 15) Step 15
      Me.Line (0, lLine)-(Shape1.Width, lLine), lColor

      If VarRGB >= 255 Or VarRGB <= 0 Then
         lColStep = lColStep * -1
      End If

      VarRGB = VarRGB + lColStep
      lColor = RGB(RVal + VarRGB, GVal + VarRGB, BVal + VarRGB)
   Next lLine
   
   myRgn = CreateRoundRectRgn(0, iFlag, (Shape1.Width + 15) / 15, (Shape1.Height + 15) / 15 + iFlag, 13, 13)
   myRgn2 = CreatePolygonRgn(myP(0), 4, 1)
   CombineRgn myRgn, myRgn2, myRgn, 2
   
   theBrush = CreateSolidBrush(vbBlack)
   FrameRgn Me.hDC, myRgn, theBrush, 1, 1
   
   DeleteObject myRgn
   DeleteObject myRgn2
   DeleteObject theBrush
   
   myRect.Left = Me.Left / 15: myRect.Right = (Me.Left + Me.Width) / 15
   myRect.Top = Me.Top / 15: myRect.Bottom = (Me.Top + Me.Height) / 15
   
On Error GoTo 0
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

   InvalidateRect Me.hWnd, myRect, 1&
   Unload frmShadow
   Set frmShadow = Nothing
'   Set frmAbout = Nothing
      
End Sub

Private Sub tmrToolTip_Timer()
Dim CursorPos As POINTAPI
On Error Resume Next

   GetCursorPos CursorPos
   tmrToolTip.Interval = 1

   If WindowFromPoint(CursorPos.X, CursorPos.Y) = CtrlhWnd Then
      If isExecuted = False Then
      
         PhWnd = CtrlhWnd
         isExecuted = True
         doToolTip
         
      End If
      If PhWnd <> CtrlhWnd Then
      
         tmrToolTip.Enabled = False
         isExecuted = False
         Unload Me
         
      Else
      
         If lblTitle <> TitleStr Or lblTip <> TipStr Then
         
            tmrToolTip.Enabled = False
            Unload Me
            Set frmToolTip = Nothing
            
         End If
      End If
   Else
   
      tmrToolTip.Enabled = False
      isExecuted = False
      Unload Me
      Exit Sub
      
   End If

On Error GoTo 0
End Sub