调色拾色器.frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Picture2 
      BackColor       =   &H00FFFFFF&
      Height          =   825
      Left            =   135
      ScaleHeight     =   765
      ScaleWidth      =   990
      TabIndex        =   8
      Top             =   135
      Width           =   1050
   End
   Begin VB.PictureBox Picture1 
      BackColor       =   &H00FFFFFF&
      Height          =   555
      Left            =   1395
      MouseIcon       =   "调色拾色器.frx":0000
      Picture         =   "调色拾色器.frx":030A
      ScaleHeight     =   495
      ScaleWidth      =   495
      TabIndex        =   7
      Top             =   135
      Width           =   555
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   2250
      TabIndex        =   6
      Text            =   "#FFFFFF"
      Top             =   720
      Width           =   1770
   End
   Begin MSComctlLib.Slider sliBlue 
      Height          =   285
      Left            =   1163
      TabIndex        =   3
      Top             =   2655
      Width           =   3120
      _ExtentX        =   5503
      _ExtentY        =   503
      _Version        =   393216
      TickStyle       =   3
   End
   Begin MSComctlLib.Slider sliGreen 
      Height          =   285
      Left            =   1163
      TabIndex        =   2
      Top             =   2040
      Width           =   3120
      _ExtentX        =   5503
      _ExtentY        =   503
      _Version        =   393216
      TickStyle       =   3
   End
   Begin MSComctlLib.Slider sliRed 
      Height          =   285
      Left            =   1163
      TabIndex        =   1
      Top             =   1440
      Width           =   3120
      _ExtentX        =   5503
      _ExtentY        =   503
      _Version        =   393216
      TickStyle       =   3
   End
   Begin VB.Label lblBlue 
      Caption         =   "B: 255"
      Height          =   195
      Left            =   398
      TabIndex        =   5
      Top             =   2655
      Width           =   735
   End
   Begin VB.Label lblGreen 
      Caption         =   "G: 255"
      Height          =   195
      Left            =   398
      TabIndex        =   4
      Top             =   2070
      Width           =   735
   End
   Begin VB.Label lblRed 
      Caption         =   "R: 255"
      Height          =   195
      Left            =   398
      TabIndex        =   0
      Top             =   1440
      Width           =   735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Type POINTAPI
        x As Long
        y As Long
End Type
Dim blnPaint As Boolean

Private Sub Form_Load()
    SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE
    sliRed.Max = 255: sliGreen.Max = 255: sliBlue.Max = 255
    sliRed.LargeChange = 10: sliGreen.LargeChange = 10: sliBlue.LargeChange = 10
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Picture1.MousePointer = 99
    Call ColorChange_Pallet(x, y)
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
        Call ColorChange_Pallet(x, y)
    Else
        Picture1.MousePointer = 0
    End If
End Sub

Private Sub sliBlue_Change()
    Text_Change
    ColorChange_Sli
End Sub

Private Sub sliBlue_Scroll()
    Text_Change
    ColorChange_Sli
End Sub

Private Sub sliGreen_Change()
    Text_Change
    ColorChange_Sli
End Sub
Private Sub sliGreen_Scroll()
    Text_Change
    ColorChange_Sli
End Sub
Private Sub sliRed_Change()
    Text_Change
    ColorChange_Sli
End Sub
Private Sub sliRed_Scroll()
    Text_Change
    ColorChange_Sli
End Sub
Private Sub Text_Change()
    Dim strRedV As String
    Dim strGreenV As String
    Dim strBlueV As String
    lblRed.Caption = "R: " & sliRed.Value
    lblGreen.Caption = "G: " & sliGreen.Value
    lblBlue.Caption = "B: " & sliBlue.Value
    strRedV = Hex(sliRed.Value)
    strGreenV = Hex(sliGreen.Value)
    strBlueV = Hex(sliBlue.Value)
    Text1.Text = "#" & strRedV & strGreenV & strBlueV
End Sub
Private Sub ColorChange_Sli()
    Picture2.BackColor = RGB(sliRed.Value, sliGreen.Value, sliBlue.Value)
End Sub
Private Sub ColorChange_Pallet(x As Single, y As Single)
    On Local Error Resume Next
    Dim lngHwnd As Long, lngHd As Long
    Dim lngX As Long, lngY As Long
    Dim R As Long, G As Long, B As Long
    Dim point As POINTAPI, lngRGB As Long
    If Picture1.MousePointer = 99 Then
        GetCursorPos point
        If point.x = lngX And point.y = lngY Then Exit Sub
        lngX = point.x: lngY = point.y
        lngHwnd = WindowFromPoint(point.x, point.y)
        lngHd = GetDC(lngHwnd)
        ScreenToClient lngHwnd, point
        x = point.x: y = point.y
        lngRGB = GetPixel(lngHd, x, y)  '获取剪贴区的颜色
        If lngRGB = -1 Then
            BitBlt Picture2.hdc, 0, 0, 1, 1, lngHd, point.x, point.y, vbSrcCopy
            lngRGB = Picture2.point(0, 0)   '将颜色区域拷贝过来再取色
        End If
        R = lngRGB Mod 256
        G = (lngRGB And 65280) \ 256
        B = (lngRGB And &HFF0000) \ 65536
        sliRed.Value = R
        sliGreen.Value = G
        sliBlue.Value = B
    End If
End Sub