VB代码-颜色渐变的标题栏

'一个渐变的标题框，在此例中我们可以看到绘图的应用技巧
'尤其是实现渐变的方法，很值得我们借鉴
'另外也涉及了拖动无标题窗口的技巧
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



模块

Option Explicit

Public Const GT_HOW = "LtoR"
'Public Const GT_HOW = "TtoB"

' Values for GT_HOW are:
' TtoB Is Specified Color to Black Going Down
' BlueLtoR is fading Left to Right Select Color
' to Black
' Just Uncomment the one you want and
' Comment the other


' Color values for the Title Bar, They are
' RGB so each is 0 to 255
Public Const GT_RED = 0 ' The Red Value
Public Const GT_GREEN = 0 ' The Green Value
Public Const GT_BLUE = 255 ' The Blue Value


' Don't Comment Out any of the lines below here!!!!!
Public Const GT_SPACERVAL = 40

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Type POINTAPI
x As Long
y As Long
End Type

Public Const COLOR_ACTIVECAPTION = 2
Public Const SM_CXDLGFRAME = 7
Public Const SM_CYDLGFRAME = 8
Public Const PLANES = 14 ' Number of planes
Public Const BITSPIXEL = 12 ' Number of bits per pixel


Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Public Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Public Declare Function DrawFocusRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT) As Long

Public Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Public Declare Function GetDC Lib "u

ser32" _
(ByVal hwnd As Long) As Long

Public Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long


Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Declare Function FillRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long


Public tpoint As POINTAPI
Public temp As POINTAPI
Public dpoint As POINTAPI
Public fbox As RECT
Public tbox As RECT
Public oldbox As RECT
Public TwipsPerPixelX
Public TwipsPerPixelY


Public Sub MakeGrad(PicBoxName As PictureBox, Orientation%, RStart%, GStart%, BStart%, RInc%, GInc%, BInc%)
Dim x As Integer, y As Integer, z As Integer, Cycles As Integer
Dim R%, G%, B%
R% = RStart%: G% = GStart%: B% = BStart%
If Orientation% = 0 Then
Cycles = PicBoxName.ScaleHeight \ 100
Else
Cycles = PicBoxName.ScaleWidth \ 100
End If

For z = 1 To 100
x = x + 1
Select Case Orientation
Case 0: 'Top to Bottom
If x > PicBoxName.ScaleHeight Then Exit For
PicBoxName.Line (0, x)-(PicBoxName.Width, x + Cycles - 1), RGB(R%, G%, B%), BF
Case 1: 'Left to Right
If x > PicBoxName.ScaleWidth Then Exit For
PicBoxName.Line (x, 0)-(x + Cycles - 1, PicBoxName.Height), RGB(R%, G%, B%), BF
End Select
x = x + Cycles
R% = R% + RInc%: G% = G% + GInc%: B% = B% + BInc%
If R% > 255 Then R% = 255
If R% < 0 Then R% = 0
If G% > 255 Then G% = 255
If G% < 0 Then G% = 0
If B% > 255 Then B% = 255
If B% < 0 Then B% = 0
Next z
End Sub