创建背景为渐近色的表单
（作者： 2000年05月17日 18:39）
[程序语言] Microsoft Visual Basic 4.0,5.0,6.0
[运行平台] WINDOWS
[源码来源]http://www.mvps.org/vbnet/code/neet/gradientform.htm
[功能描述]
该程序演示了如何使用API，创建背景为渐近色的表单，并且在表单的背景中创建若干个控制按钮，而又不影响渐近色的背景的外观效果。该例子使用了从蓝色到黑色的渐近效果。
BAS模块代码
把下列API 说明代码加入道bas模块的通用说明区域，如果使用的是VB4-32 或VB5，这就是一个一个表单的工程文件，说明应放在表单的通用说明部分，并所有的Public指引改为Private。
--------------------------------------------------------------------------------
Option Explicit
Public Const PLANES As Long = 14 'Number of planes
Public Const BITSPIXEL As Long= 12 'Number of bits per pixel
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Public Declare Function FillRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long
'--end block--'
表单代码
添加表单到工程文件中。表单不需要任何控制，但要创建一个菜单，用名称'mnuStyle'命名菜单数组项，并且添加四个渐近选项(对角线方向作为index 0, 水平方向作为index 1, 垂直方法作为index 2 以及实体作为index 3)。end命令是可选的。 把表单的AutoRedraw 和ClipControls属性设置为True。加入下列代码：
--------------------------------------------------------------------------------
Option Explicit
Dim fadeStyle As Integer
Private Sub Form_Load()
fadeStyle = 0
mnuStyle(fadeStyle).Checked = True
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Substitute the name of the parent menu item below.
'I prefer to prefix unused menus with Z to keep them
'at the bottom of the form object list.
If Button = 2 Then PopupMenu zmnuStyle
End Sub
Private Sub Form_Resize()
'avoid an error by checking the
'windowstate before redrawing
If WindowState <> 1 Then FadeForm Me, fadeStyle
End Sub
Private Sub mnuStyle_Click(Index As Integer)
'track the current selection
Static prevStyle As Integer
'uncheck the last selection
mnuStyle(prevStyle).Checked = False
'set the variable indicating the style
fadeStyle = Index
'draw the new style
FadeForm Me, fadeStyle
'update the current selection
mnuStyle(fadeStyle).Checked = True
prevStyle = fadeStyle
End Sub
Private Sub cmdEnd_Click()
'if you added an end button, add this code
Unload Me
End Sub
Private Sub mnuEnd_Click(Index As Integer)
'if you added an end menu command, add this code
Unload Me
End Sub
Private Sub FadeForm(frmIn As Form, fadeStyle As Integer)
'fadeStyle = 0 produces diagonal gradient
'fadeStyle = 1 produces vertical gradient
'fadeStyle = 2 produces horizontal gradient
'any other value produces solid medium-blue background
Static ColorBits As Long
Static RgnCnt As Integer
Dim NbrPlanes As Long
Dim BitsPerPixel As Long
Dim AreaHeight As Long
Dim AreaWidth As Long
Dim BlueLevel As Long
Dim prevScaleMode As Integer
Dim IntervalY As Long
Dim IntervalX As Long
Dim i As Integer
Dim r As Long
Dim ColorVal As Long
Dim FillArea As RECT
Dim hBrush As Long
'init code - performed only on the
'first pass through this routine.
If ColorBits = 0 Then
'determine number of color bits supported.
BitsPerPixel = GetDeviceCaps(frmIn.hDC, BITSPIXEL)
NbrPlanes = GetDeviceCaps(frmIn.hDC, PLANES)
ColorBits = (BitsPerPixel * NbrPlanes)
'Calculate the number of regions that the
'screen will be divided into. This is optimized
'for the current display's color depth. Why
'waste time rendering 256 shades if you can
'only discern 32 or 64 of them?
Select Case ColorBits
Case 32: RgnCnt = 256 '16M colors: 8 bits for blue
Case 24: RgnCnt = 256 '16M colors: 8 bits for blue
Case 16: RgnCnt = 256 '64K colors: 5 bits for blue
Case 15: RgnCnt = 32 '32K colors: 5 bits for blue
Case 8: RgnCnt = 64 '256 colors: 64 dithered blues
Case 4: RgnCnt = 64 '16 colors : 64 dithered blues
Case Else: ColorBits = 4
RgnCnt = 64 '16 colors assumed: 64 dithered blues
End Select
End If
'if solid then set and bail out
If fadeStyle = 3 Then
frmIn.BackColor = &H7F0000 ' med blue
Exit Sub
End If
'save the current scalemode
'and set to pixel
prevScaleMode = frmIn.ScaleMode
frmIn.ScaleMode = 3
AreaHeight = frmIn.ScaleHeight
'calculate sizes
AreaWidth = frmIn.ScaleWidth
frmIn.ScaleMode = prevScaleMode
'reset to saved value
ColorVal = 256 / RgnCnt
'color diff between regions
IntervalY = AreaHeight / RgnCnt
'# vert pixels per region
IntervalX = AreaWidth / RgnCnt
'# horz pixels per region
'fill the client area from bottom/right
'to top/left except for top/left region
FillArea.Left = 0
FillArea.Top = 0
FillArea.Right = AreaWidth
FillArea.Bottom = AreaHeight
BlueLevel = 0
For i = 0 To RgnCnt - 1
'create a brush of the appropriate blue colour
hBrush = CreateSolidBrush(RGB(0, 0, BlueLevel))
If fadeStyle = 0 Then
'diagonal gradient
FillArea.Top = FillArea.Bottom - IntervalY
FillArea.Left = 0
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Top = 0
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
FillArea.Right = FillArea.Right - IntervalX
ElseIf fadeStyle = 1 Then
'horizontal gradient
FillArea.Top = FillArea.Bottom - IntervalY
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
Else
'vertical gradient
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Right = FillArea.Right - IntervalX
End If
'done with the brush, so delete
r = DeleteObject(hBrush)
'increment the value by the appropriate
'steps for the display colour depth
BlueLevel = BlueLevel + ColorVal
Next
'Fill any the remaining top/left holes of the
'client area with solid blue
FillArea.Top = 0
FillArea.Left = 0
hBrush = CreateSolidBrush(RGB(0, 0, 255))
r = FillRect(frmIn.hDC, FillArea, hBrush)
r = DeleteObject(hBrush)
Me.Refresh
End Sub
'--end block--'
|
当前页面位置: