8-2.frm

vb6.0编程实例详解,很详细的介绍,对学习VB有帮助

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "调色板应用"
   ClientHeight    =   3630
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5565
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   3630
   ScaleWidth      =   5565
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Pic2 
      Height          =   735
      Left            =   240
      ScaleHeight     =   45
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   93
      TabIndex        =   4
      Top             =   360
      Width           =   1455
   End
   Begin VB.VScrollBar Colour 
      Height          =   1500
      Index           =   2
      LargeChange     =   10
      Left            =   255
      Max             =   0
      Min             =   255
      TabIndex        =   3
      Top             =   1800
      Value           =   255
      Width           =   255
   End
   Begin VB.VScrollBar Colour 
      Height          =   1500
      Index           =   1
      LargeChange     =   10
      Left            =   840
      Max             =   0
      Min             =   255
      TabIndex        =   2
      Top             =   1800
      Value           =   255
      Width           =   255
   End
   Begin VB.VScrollBar Colour 
      Height          =   1500
      Index           =   0
      LargeChange     =   10
      Left            =   1440
      Max             =   0
      Min             =   255
      TabIndex        =   1
      Top             =   1800
      Value           =   255
      Width           =   255
   End
   Begin VB.PictureBox Pic1 
      Height          =   2940
      Left            =   2040
      ScaleHeight     =   192
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   208
      TabIndex        =   0
      Top             =   360
      Width           =   3180
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "255"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000FF&
      Height          =   255
      Index           =   0
      Left            =   1320
      TabIndex        =   10
      Top             =   1560
      Width           =   375
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "255"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00008000&
      Height          =   255
      Index           =   1
      Left            =   720
      TabIndex        =   9
      Top             =   1560
      Width           =   375
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "255"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   255
      Index           =   2
      Left            =   120
      TabIndex        =   8
      Top             =   1560
      Width           =   375
   End
   Begin VB.Label Label1 
      Caption         =   "蓝"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   255
      Index           =   2
      Left            =   240
      TabIndex        =   7
      Top             =   1290
      Width           =   255
   End
   Begin VB.Label Label1 
      Caption         =   "绿"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00008000&
      Height          =   255
      Index           =   1
      Left            =   840
      TabIndex        =   6
      Top             =   1290
      Width           =   255
   End
   Begin VB.Label Label1 
      Caption         =   "红"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000FF&
      Height          =   255
      Index           =   0
      Left            =   1440
      TabIndex        =   5
      Top             =   1290
      Width           =   255
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const DEFAULT_PALETTE As Integer = 15
Const BLACK_BRUSH As Integer = 4
Const PC_RESERVED As Integer = &H1&

Private Type PALETTEENTRY
        peRed As Byte
        peGreen As Byte
        peBlue As Byte
        peFlags As Byte
End Type

Private Type LOGPALETTE
        palVersion As Integer
        palNumEntries As Integer
        palPalEntry(256) As PALETTEENTRY
End Type

Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function SetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function AnimatePalette Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteColors As PALETTEENTRY) As Long

Dim hSystemPalette As Long
Dim hCurrentPalette As Long
Dim Block As Long
Dim ColorSelected As Integer
Dim SelectingColor As Boolean


Private Sub ColorChange(index As Integer)
'修改颜色设置
    Dim Dummy As Long
    Dim NewPaletteEntry As PALETTEENTRY
    
    If ColorSelected > -1 Then
        NewPaletteEntry.peRed = Colour(0).Value
        NewPaletteEntry.peGreen = Colour(1).Value
        NewPaletteEntry.peBlue = Colour(2).Value
        NewPaletteEntry.peFlags = PC_RESERVED
        
        Dummy = AnimatePalette(hCurrentPalette, ColorSelected, 1, NewPaletteEntry)
        
        '修改Pic2中的颜色
        Pic2_Paint
     End If
End Sub

Private Sub Colour_GotFocus(index As Integer)
    SelectingColor = False
End Sub

Private Sub Colour_Scroll(index As Integer)
'颜色滚动条滚动
    If Not SelectingColor Then
        Call ColorChange(index)
    End If
        
    Label2(index).Caption = Right(Str(Colour(index).Value), 3)
    ChangeColor index
End Sub

Private Sub Colour_Change(index As Integer)
'颜色滚动条数值变化
    If Not SelectingColor Then
        Call ColorChange(index)
        
        '修改Pic1中的颜色
        Call PaintSubBlock
    End If
    
    Label2(index).Caption = Right(Str(Colour(index).Value), 3)
    ChangeColor index
End Sub

Private Sub Form_Load()
    Dim LogicalPalette As LOGPALETTE
    Dim ColorIndex As Integer
    Dim r As Integer, g As Integer, b As Integer
    Dim i As Integer, j As Integer
    
    Block = 16 '每行16块
    ColorSelected = -1 '未选择颜色
    
    '设置自定义调色板值
    LogicalPalette.palVersion = &H300
    LogicalPalette.palNumEntries = 256
    '设置调色板颜色值
    For i = 0 To 15
    For j = 0 To 15
        LogicalPalette.palPalEntry(i * 16 + j).peRed = i * 17
        LogicalPalette.palPalEntry(i * 16 + j).peGreen = j * 17
        LogicalPalette.palPalEntry(i * 16 + j).peBlue = i * j / (i + j + 0.01) * 34
        LogicalPalette.palPalEntry(i * 16 + j).peFlags = PC_RESERVED
    Next j, i
    
    '创建调色板
    hCurrentPalette = CreatePalette(LogicalPalette)
    Call Pic1_Paint '绘显示区
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim Dummy As Integer
    Dim hSystemPalette As Long
    Dim hDummyPalette As Long
    
    hSystemPalette = GetStockObject(DEFAULT_PALETTE) '取得系统缺省调色板
    hDummyPalette = SelectPalette(Pic1.hdc, hSystemPalette, 0) '恢复缺省调色板
    hDummyPalette = SelectPalette(Pic2.hdc, hSystemPalette, 0)
    Dummy = DeleteObject(hCurrentPalette) '删除自定义调色板
End Sub

Private Sub Pic1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim BoxHeight As Integer
    Dim BoxWidth As Integer
    Dim Row As Integer
    Dim Column As Integer
    Dim Dummy As Integer
    Dim CurrentPaletteEntry As PALETTEENTRY
    
    '设置选择颜色标志
    SelectingColor = True
    
    BoxHeight = Pic1.ScaleHeight \ Block
    BoxWidth = Pic1.ScaleWidth \ Block
    
    Row = Y \ BoxHeight
    Column = X \ BoxWidth
    
    If Row < Block And Column < Block Then
    '选择了颜色块
        ColorSelected = Row * Block + Column
        Dummy = GetPaletteEntries(hCurrentPalette, ColorSelected, 1, _
                        CurrentPaletteEntry)
        Colour(0).Value = CurrentPaletteEntry.peRed
        Colour(1).Value = CurrentPaletteEntry.peGreen
        Colour(2).Value = CurrentPaletteEntry.peBlue
        
        Pic1_Paint '重绘颜色显示
        Pic2_Paint
    End If
End Sub

Private Sub Pic1_Paint()
    Dim Row As Integer
    Dim Column As Integer
    Dim BoxHeight As Integer
    Dim BoxWidth As Integer
    Dim Color As Long
    Dim ColorIndex As Long
    Dim hBrush As Long
    Dim Dummy As Integer
    
    '应用自定义调色板
    hSystemPalette = SelectPalette(Pic1.hdc, hCurrentPalette, 0)
    Dummy = RealizePalette(Pic1.hdc) '确认调色板
    
    '计算各颜色块大小
    BoxWidth = Pic1.ScaleWidth \ Block
    BoxHeight = Pic1.ScaleHeight \ Block
    
    '绘制各颜色块
    For ColorIndex = 0 To Block * Block - 1
        Row = ColorIndex \ Block + 1 '计算行位置（从1开始）
        Column = ColorIndex Mod Block + 1 '计算列位置
        hBrush = CreateSolidBrush(&H1000000 Or ColorIndex) '以指定调色板创建画刷
        Dummy = SelectObject(Pic1.hdc, hBrush) '应用画刷
        Dummy = Rectangle(Pic1.hdc, (Column - 1) * BoxWidth, (Row - 1) * BoxHeight, _
                        Column * BoxWidth, Row * BoxHeight) '绘制矩形
        Dummy = SelectObject(Pic1.hdc, GetStockObject(BLACK_BRUSH)) '恢复缺省画刷
        Dummy = DeleteObject(hBrush) '删除自创建画刷
    Next ColorIndex
    
    '绘制突出显示颜色块
    PaintSubBlock
End Sub

Private Sub PaintSubBlock()
'该函数用于绘制突出显示颜色块
'各函数使用同 Pic1_Paint 中
    Dim Row As Integer
    Dim Column As Integer
    Dim BoxHeight As Integer
    Dim BoxWidth As Integer
    Dim Color As Long
    Dim ColorIndex As Long
    Dim hBrush As Long
    Dim Dummy As Integer
    
    
    BoxWidth = Pic1.ScaleWidth \ Block
    BoxHeight = Pic1.ScaleHeight \ Block
    
    If ColorSelected > -1 Then
    '选择了颜色块
        Row = ColorSelected \ Block + 1
        Column = ColorSelected Mod Block + 1
        hBrush = CreateSolidBrush(&H1000000 Or ColorSelected)
        Dummy = SelectObject(Pic1.hdc, hBrush)
        Dummy = Rectangle(Pic1.hdc, MaxVal((Column - 1.5) * BoxWidth, 0), _
                        MaxVal((Row - 1.5) * BoxHeight, 0), MinVal((Column + 0.5), Block) * BoxWidth, _
                        MinVal((Row + 0.5), Block) * BoxHeight)
        Dummy = SelectObject(Pic1.hdc, GetStockObject(BLACK_BRUSH))
        Dummy = DeleteObject(hBrush)
    End If
End Sub

Private Sub Pic2_Paint()
'该函数用于绘制颜色显示块（Pic2 控件）
    Dim hBrush As Long
    Dim Dummy As Long
    
    hSystemPalette = SelectPalette(Pic2.hdc, hCurrentPalette, 0)
    Dummy = RealizePalette(Pic2.hdc)
    hBrush = CreateSolidBrush(&H1000000 Or ColorSelected)
    Dummy = SelectObject(Pic2.hdc, hBrush)
    Dummy = Rectangle(Pic2.hdc, 0, 0, Pic2.ScaleWidth, Pic2.ScaleHeight)
    Dummy = SelectObject(Pic2.hdc, GetStockObject(BLACK_BRUSH))
    Dummy = DeleteObject(hBrush)
End Sub

Private Function MaxVal(i1, i2) As Single
'计算最大值
    If i1 > i2 Then
        MaxVal = i1
    Else
        MaxVal = i2
    End If
End Function

Private Function MinVal(i1, i2) As Single
'计算最小值
    If i1 < i2 Then
        MinVal = i1
    Else
        MinVal = i2
    End If
End Function

Private Sub ChangeColor(index As Integer)
'修改标签颜色
    Select Case index
        Case 0
            Label2(index).ForeColor = RGB(Colour(index).Value, 0, 0)
        Case 1
            Label2(index).ForeColor = RGB(0, Colour(index).Value, 0)
        Case 2
            Label2(index).ForeColor = RGB(0, 0, Colour(index).Value)
    End Select
End Sub