frmgradtitle.frm

实现闪烁的标题栏

VERSION 5.00
Begin VB.Form frmGradTitle 
   BorderStyle     =   0  'None
   Caption         =   "Gradient TitleBar"
   ClientHeight    =   5715
   ClientLeft      =   2130
   ClientTop       =   2355
   ClientWidth     =   6630
   Icon            =   "frmGradTitle.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5715
   ScaleWidth      =   6630
   Begin VB.PictureBox picTitleBar 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   280
      Left            =   20
      ScaleHeight     =   285
      ScaleWidth      =   6480
      TabIndex        =   1
      Top             =   20
      Width           =   6480
      Begin VB.Image imgMaximize 
         Height          =   210
         Left            =   5880
         Picture         =   "frmGradTitle.frx":0442
         Top             =   30
         Width           =   240
      End
      Begin VB.Image imgMinimize 
         Height          =   210
         Left            =   5640
         Picture         =   "frmGradTitle.frx":0724
         Top             =   30
         Width           =   240
      End
      Begin VB.Image imgCloseForm 
         Height          =   210
         Left            =   6240
         Picture         =   "frmGradTitle.frx":0A06
         Top             =   30
         Width           =   240
      End
      Begin VB.Image imgFormIcon 
         Height          =   240
         Left            =   60
         Stretch         =   -1  'True
         Top             =   20
         Width           =   240
      End
      Begin VB.Label lblFormCaption 
         BackStyle       =   0  'Transparent
         Caption         =   "Form Caption"
         ForeColor       =   &H00FFFFFF&
         Height          =   255
         Left            =   360
         TabIndex        =   2
         Top             =   30
         Width           =   3975
      End
   End
   Begin VB.CommandButton cmdDummy 
      Caption         =   "Command1"
      Height          =   195
      Left            =   2880
      TabIndex        =   0
      Top             =   60
      Width           =   75
   End
   Begin VB.Line lineBorder1 
      X1              =   0
      X2              =   0
      Y1              =   0
      Y2              =   5640
   End
   Begin VB.Line lineBorder2 
      X1              =   0
      X2              =   6600
      Y1              =   0
      Y2              =   0
   End
   Begin VB.Line lineBorder3 
      X1              =   6600
      X2              =   6600
      Y1              =   5640
      Y2              =   0
   End
   Begin VB.Line lineBorder4 
      X1              =   0
      X2              =   6600
      Y1              =   5640
      Y2              =   5640
   End
   Begin VB.Image imgMaximizeButton 
      Height          =   210
      Left            =   3360
      Picture         =   "frmGradTitle.frx":0CE8
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgNormalizeButton 
      Height          =   210
      Left            =   3600
      Picture         =   "frmGradTitle.frx":0FCA
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgCloseFormButton 
      Height          =   210
      Left            =   3840
      Picture         =   "frmGradTitle.frx":12AC
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgCloseFormButtonDown 
      Height          =   210
      Left            =   4800
      Picture         =   "frmGradTitle.frx":158E
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgNormalizeButtonDown 
      Height          =   210
      Left            =   4560
      Picture         =   "frmGradTitle.frx":1870
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgMaximizeButtonDown 
      Height          =   210
      Left            =   4320
      Picture         =   "frmGradTitle.frx":1B52
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgMinimizeButtonDown 
      Height          =   210
      Left            =   4080
      Picture         =   "frmGradTitle.frx":1E34
      Top             =   60
      Width           =   240
   End
   Begin VB.Image imgMinimizeButton 
      Height          =   210
      Left            =   3120
      Picture         =   "frmGradTitle.frx":2116
      Top             =   60
      Width           =   240
   End
End
Attribute VB_Name = "frmGradTitle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'一个渐变的标题框，在此例中我们可以看到绘图的应用技巧
'尤其是实现渐变的方法，很值得我们借鉴
'另外也涉及了拖动无标题窗口的技巧
Option Explicit
Private IsMaximized As Boolean
Private IsMinimized As Boolean
Private ButtonsCount As Integer

Private Sub Form_Paint()
    ReSize
    EndFRDrag Me.Top, Me.Left
End Sub

Private Sub imgCloseForm_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    imgCloseForm.Picture = imgCloseFormButtonDown.Picture
End Sub

Private Sub imgCloseForm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' Unload All of the Forms
  Dim frm As Form
    imgCloseForm.Picture = imgCloseFormButton.Picture
    For Each frm In Forms
        Unload frm
    Next frm
    End
End Sub

Private Sub imgMaximize_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If IsMaximized = True Then
        imgMaximize.Picture = imgNormalizeButtonDown.Picture
    Else
        imgMaximize.Picture = imgMaximizeButtonDown.Picture
    End If
End Sub

Private Sub imgMaximize_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If IsMaximized = False Then
        Me.WindowState = 2
        IsMaximized = True
        Form_Resize
        imgMaximize.Picture = imgNormalizeButton.Picture
    Else
        Me.WindowState = 0
        IsMaximized = False
        Form_Resize
        imgMaximize.Picture = imgMaximizeButton.Picture
    End If
End Sub

Private Sub imgMinimize_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    imgMinimize.Picture = imgMinimizeButtonDown.Picture
End Sub

Private Sub imgMinimize_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If IsMinimized = False Then
        Me.WindowState = 1
        IsMinimized = True
        Form_Resize
        imgMinimize.Picture = imgMinimizeButton.Picture
    Else
        Me.WindowState = 0
        IsMinimized = False
        Form_Resize
        imgMinimize.Picture = imgMinimizeButton.Picture
    End If
End Sub

Private Sub Form_Activate()
    IsMinimized = False
End Sub

Private Sub Form_Load()
  Dim frameHeight As Long
  Dim frameWidth As Long
    Me.ScaleMode = 3
       '     'compute the width of the left and right dialog frame
    frameHeight = GetSystemMetrics(SM_CYDLGFRAME) * 2
       '     'compute the width of the top and bottom dialog frame
    frameWidth = GetSystemMetrics(SM_CXDLGFRAME) * 2
       
    Me.ScaleMode = 1
    
    ButtonsCount = 0
    If Me.MaxButton = True Then ButtonsCount = ButtonsCount + 1
    If Me.MinButton = True Then ButtonsCount = ButtonsCount + 2
    
    Select Case ButtonsCount
        Case 0
            imgMaximize.Visible = False
            imgMinimize.Visible = False
        Case 1
            imgMinimize.Visible = False
        Case 2
            imgMaximize.Visible = False
    End Select
    
    ReSize

    DrawCaption Me.Caption
    imgFormIcon.Picture = Me.Icon
End Sub

Private Sub Form_Resize()
    ReSize
End Sub


Private Sub picTitleBar_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    BeginFRDrag x, y
End Sub
Private Sub picTitleBar_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then DoFRDrag x, y
End Sub
Private Sub picTitleBar_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    EndFRDrag x, y
End Sub

Private Sub lblFormCaption_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    BeginFRDrag x, y
End Sub
Private Sub lblFormCaption_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then DoFRDrag x, y
End Sub
Private Sub lblFormCaption_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    EndFRDrag x, y
End Sub


Private Sub BeginFRDrag(x As Single, y As Single)
    If IsMaximized = True Then Exit Sub
    If IsMinimized = True Then Exit Sub
    
       Dim tDc As Long
       Dim sDc As Long
       Dim d As Long
       '     'convert points to POINTAPI struct
       dpoint.x = x
       dpoint.y = y
       '     'get screen area of Me
       GetWindowRect Me.hwnd, fbox 'screen Rect of Me
       TwipsPerPixelX = Screen.TwipsPerPixelX
       TwipsPerPixelY = Screen.TwipsPerPixelY
       '     'get point of mousedown in screen coordinates
       temp = dpoint
       ClientToScreen Me.hwnd, temp
       sDc = GetDC(ByVal 0)
       DrawFocusRect sDc, tbox
       d = ReleaseDC(0, sDc)
       oldbox = tbox
End Sub


Private Sub DoFRDrag(x As Single, y As Single)
    If IsMaximized = True Then Exit Sub
    If IsMinimized = True Then Exit Sub

       Dim tDc As Long
       Dim sDc As Long
       Dim d As Long
       tpoint.x = x
       tpoint.y = y
       ClientToScreen Me.hwnd, tpoint
       tbox.Left = (fbox.Left + tpoint.x / TwipsPerPixelX) - temp.x / TwipsPerPixelX
       tbox.Top = (fbox.Top + tpoint.y / TwipsPerPixelY) - temp.y / TwipsPerPixelY
       tbox.Right = (fbox.Right + tpoint.x / TwipsPerPixelX) - temp.x / TwipsPerPixelX
       tbox.Bottom = (fbox.Bottom + tpoint.y / TwipsPerPixelY) - temp.y / TwipsPerPixelY
       sDc = GetDC(ByVal 0)
       DrawFocusRect sDc, oldbox
       DrawFocusRect sDc, tbox
       d = ReleaseDC(0, sDc)
       oldbox = tbox
End Sub


Private Sub EndFRDrag(x As Single, y As Single)
    If IsMaximized = True Then Exit Sub
    If IsMinimized = True Then Exit Sub

       Dim tDc As Long
       Dim sDc As Long
       Dim d As Long
       Dim newleft As Single
       Dim newtop As Single
       sDc = GetDC(ByVal 0)
       DrawFocusRect sDc, oldbox
       d = ReleaseDC(0, sDc)
       newleft = x + fbox.Left * TwipsPerPixelX - dpoint.x
       newtop = y + fbox.Top * TwipsPerPixelY - dpoint.y
       Me.Move newleft, newtop
       cmdDummy.SetFocus
End Sub

Private Sub DrawCaption(sCaption As String)
    lblFormCaption.Caption = sCaption
End Sub

Private Sub ReSize()
    lineBorder1.BorderColor = vb3DHighlight
    lineBorder2.BorderColor = vb3DHighlight
    lineBorder3.BorderColor = vb3DShadow
    lineBorder4.BorderColor = vb3DShadow
    lineBorder1.Y2 = Me.Height
    lineBorder2.X2 = Me.Width
    lineBorder3.X1 = Me.Width - 10
    lineBorder3.X2 = Me.Width - 10
    lineBorder3.Y1 = 0
    lineBorder3.Y2 = Me.Height
    lineBorder4.X1 = 0
    lineBorder4.X2 = Me.Width - 10
    lineBorder4.Y1 = Me.Height - 10
    lineBorder4.Y2 = Me.Height - 10
    
    picTitleBar.Width = Me.Width - 25
    imgCloseForm.Left = picTitleBar.Width - imgCloseForm.Width - GT_SPACERVAL
    imgMaximize.Left = picTitleBar.Width - imgCloseForm.Width - imgMaximize.Width - GT_SPACERVAL * 2
    
    If ButtonsCount <> 2 Then
        imgMinimize.Left = picTitleBar.Width - imgCloseForm.Width - imgMaximize.Width - imgMinimize.Width - GT_SPACERVAL * 2
    Else
        imgMinimize.Left = picTitleBar.Width - imgCloseForm.Width - imgMinimize.Width - GT_SPACERVAL * 2
    End If
    Select Case GT_HOW
        Case "TtoB"
            MakeGrad picTitleBar, 0, GT_RED, GT_GREEN, GT_BLUE, -3, -3, -3
        Case "LtoR"
            MakeGrad picTitleBar, 1, GT_RED, GT_GREEN, GT_BLUE, -3, -3, -3
        Case Else
            MakeGrad picTitleBar, 1, GT_RED, GT_GREEN, GT_BLUE, -3, -3, -3
    End Select
End Sub