getpixelctrl.ctl

显示鼠标移过的一幅图像和桌面任何位置处的RGB颜色

VERSION 5.00
Begin VB.UserControl GetPixelCtrl 
   ClientHeight    =   1275
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1920
   ScaleHeight     =   1275
   ScaleWidth      =   1920
   ToolboxBitmap   =   "GetPixelCtrl.ctx":0000
   Begin VB.PictureBox Pic 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1215
      Left            =   0
      ScaleHeight     =   1215
      ScaleWidth      =   1935
      TabIndex        =   0
      Top             =   0
      Width           =   1935
      Begin VB.Timer Timer1 
         Interval        =   200
         Left            =   480
         Top             =   480
      End
      Begin VB.PictureBox PicR 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   960
         ScaleHeight     =   375
         ScaleWidth      =   975
         TabIndex        =   3
         Top             =   0
         Width           =   975
      End
      Begin VB.PictureBox PicG 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   960
         ScaleHeight     =   375
         ScaleWidth      =   975
         TabIndex        =   2
         Top             =   360
         Width           =   975
      End
      Begin VB.PictureBox PicB 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   960
         ScaleHeight     =   375
         ScaleWidth      =   975
         TabIndex        =   1
         Top             =   720
         Width           =   975
      End
   End
End
Attribute VB_Name = "GetPixelCtrl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Dim CurrentTick As Long
Dim LastTick As Long
'Default Property Values:
Const m_def_BackStyle = 0
'Property Variables:
Dim m_BackStyle As Integer
'Event Declarations:
Event Click() 'MappingInfo=Pic,Pic,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick() 'MappingInfo=Pic,Pic,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=Pic,Pic,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=Pic,Pic,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=Pic,Pic,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pic,Pic,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pic,Pic,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pic,Pic,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."


Public Sub About()
Attribute About.VB_UserMemId = -552
frmAbout.Show
End Sub

Private Sub UserControl_Initialize()
Timer1.Enabled = False
End Sub

Private Sub UserControl_Resize()
Pic.Width = UserControl.Width

Pic.Height = UserControl.Height
PicR.Move UserControl.Width / 2, 0, UserControl.Width / 2, UserControl.Height / 3
PicG.Move UserControl.Width / 2, PicR.Height, UserControl.Width / 2, UserControl.Height / 3
PicB.Move UserControl.Width / 2, PicR.Height + PicG.Height, UserControl.Width / 2, UserControl.Height / 3
End Sub

Private Sub Pic_Click()
    RaiseEvent Click
'
End Sub

Private Sub FindPixel()
    Dim CursorPos As POINTAPI
    Dim mStr As String
    Dim lColor As Long
    Dim lDC As Long
CurrentTick = GetTickCount()


If CurrentTick - LastTick > 10 Then
Pic.Cls
    lDC = GetWindowDC(0) ' Get Desktop hDC
    Call GetCursorPos(CursorPos)
    lColor = GetPixel(lDC, CursorPos.X, CursorPos.Y)

    PicR.BackColor = Right(lColor, 2)
 PicG.BackColor = IIf(Mid(lColor, 3, 2) = vbNullString, 0, Mid(lColor, 3, 2)) 'Bug here
    PicB.BackColor = Left(lColor, 2)
Debug.Print Right(lColor, 2), Mid(lColor, 3, 2), Left(lColor, 2)

    mStr = Right("000000" & Hex(lColor), 6)
    Pic.Print "R:" & Right(mStr, 2) & vbCrLf & "G:" & Mid(mStr, 3, 2) & vbCrLf & "B:" & Left(mStr, 2)
    LastTick = GetTickCount()
'Uncomment
DoEvents
End If
End Sub

Private Sub Timer1_Timer()
FindPixel
End Sub

Private Sub UserControl_Terminate()
Timer1.Enabled = False
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Pic,Pic,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = Pic.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    Pic.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Pic,Pic,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = Pic.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    Pic.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Timer1,Timer1,-1,Enabled
Public Property Get Enabled() As Boolean
    Enabled = Timer1.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    Timer1.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Pic,Pic,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = Pic.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set Pic.Font = New_Font
    PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "Indicates whether a Label or the background of a Shape is transparent or opaque."
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Pic,Pic,-1,BorderStyle
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
    BorderStyle = Pic.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    Pic.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Pic,Pic,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
    Pic.Refresh
End Sub

Private Sub Pic_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub Pic_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub Pic_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub Pic_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub Pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub Pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub Pic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_BackStyle = m_def_BackStyle
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    Pic.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    Pic.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    Timer1.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Pic.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    Pic.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", Pic.BackColor, &H80000005)
    Call PropBag.WriteProperty("ForeColor", Pic.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Enabled", Timer1.Enabled, True)
    Call PropBag.WriteProperty("Font", Pic.Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", Pic.BorderStyle, 0)
End Sub