frmin.frm

新手学习vb语言的实用资料于其对计算机语言做出相应了解的教材

VERSION 5.00
Begin VB.Form frmIn 
   AutoRedraw      =   -1  'True
   Caption         =   "渐变背景"
   ClientHeight    =   3195
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   4680
   Icon            =   "frmIn.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "均匀"
      Height          =   495
      Index           =   3
      Left            =   1440
      TabIndex        =   3
      Top             =   2400
      Width           =   1455
   End
   Begin VB.CommandButton Command1 
      Caption         =   "垂直渐变"
      Height          =   495
      Index           =   2
      Left            =   1440
      TabIndex        =   2
      Top             =   1680
      Width           =   1455
   End
   Begin VB.CommandButton Command1 
      Caption         =   "水平渐变"
      Height          =   495
      Index           =   1
      Left            =   1440
      TabIndex        =   1
      Top             =   960
      Width           =   1455
   End
   Begin VB.CommandButton Command1 
      Caption         =   "对角线渐变"
      Height          =   495
      Index           =   0
      Left            =   1440
      TabIndex        =   0
      Top             =   240
      Width           =   1455
   End
End
Attribute VB_Name = "frmIn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim fadeStyle As Integer
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 o.
     '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
        
    prevScaleMode = frmIn.ScaleMode    'save the current scalemode
    frmIn.ScaleMode = 3                'set to pixel
    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 that 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



Private Sub Command1_Click(Index As Integer)
'track the current selection
Static prevStyle As Integer
   'uncheck the last selection

   'set the variable indicating the style
   fadeStyle = Index
   'draw the new style
   FadeForm Me, fadeStyle
   'update the current selection
 
    prevStyle = fadeStyle
End Sub

Private Sub Form_Load()
fadeStyle = 0

End Sub



Private Sub Form_Resize()
If WindowState <> 1 Then
FadeForm Me, fadeStyle
End If
End Sub