VERSION 5.00
Begin VB.Form frmMain
   AutoRedraw      =   -1  'True
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Color"
   ClientHeight    =   1185
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   3120
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1185
   ScaleWidth      =   3120
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame Frame1
      Height          =   1260
      Left            =   0
      TabIndex        =   0
      Top             =   -75
      Width           =   3120
      Begin VB.TextBox Text1
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         Height          =   195
         Index           =   0
         Left            =   105
         MaxLength       =   3
         TabIndex        =   7
         Text            =   "0"
         Top             =   480
         Width           =   375
      End
      Begin VB.TextBox Text1
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         Height          =   195
         Index           =   1
         Left            =   105
         MaxLength       =   3
         TabIndex        =   6
         Text            =   "0"
         Top             =   705
         Width           =   375
      End
      Begin VB.TextBox Text1
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         Height          =   195
         Index           =   2
         Left            =   105
         MaxLength       =   3
         TabIndex        =   5
         Text            =   "0"
         Top             =   930
         Width           =   375
      End
      Begin VB.TextBox Text1
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         Height          =   195
         Index           =   3
         Left            =   585
         MaxLength       =   8
         TabIndex        =   4
         Text            =   "&H000000"
         Top             =   480
         Width           =   915
      End
      Begin VB.PictureBox Picture1
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H00000000&
         rawMode        =   6  'Mask Pen Not
         ForeColor       =   &H80000008&
         Height          =   390
         Left            =   585
         ScaleHeight     =   24
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   58
         TabIndex        =   3
         Top             =   750
         Width           =   900
         Begin VB.Timer Timer1
            Enabled         =   0   'False
            Interval        =   50
            Left            =   135
            Top             =   105
         End
      End
      Begin VB.CommandButton Command1
         Caption         =   "Выбрать..."
         Height          =   360
         Left            =   1560
         TabIndex        =   2
         Top             =   495
         Width           =   1395
      End
      Begin VB.CheckBox Check1
         Appearance      =   0  'Flat
         Caption         =   "С экрана"
         ForeColor       =   &H80000008&
         Height          =   195
         Left            =   1575
         TabIndex        =   1
         Top             =   945
         Width           =   1395
      End
      Begin VB.Label Label1
         AutoSize        =   -1  'True
         Caption         =   "RGB:"
         Height          =   195
         Index           =   0
         Left            =   105
         TabIndex        =   9
         Top             =   240
         Width           =   390
      End
      Begin VB.Label Label1
         AutoSize        =   -1  'True
         Caption         =   "Statist"
         Height          =   195
         Index           =   1
         Left            =   780
         TabIndex        =   8
         Top             =   240
         Width           =   435
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Type CHOOSECOLOR
    lStructSize         As Long
    hwndOwner           As Long
    hInstance           As Long
    RGBResult           As Long
    lpCustColors        As String
    flags               As Long
    lCustData           As Long
    lpfnHook            As Long
    lpTemplateName      As String
End Type
Private Type DEVMODE
    dmDeviceName As String * 32
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * 32
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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 CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) 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

Dim hDisp As Long
Dim dM As DEVMODE
Dim curPos As POINTAPI

Private Function VBGetLastError(ByVal ID As Long) As String
    Dim lStr As Long
    VBGetLastError = Space(512)
    lStr = FormatMessage(&H1000, 0&, ID, 0&, VBGetLastError, Len(VBGetLastError), 0&
    VBGetLastError = Left(VBGetLastError, lStr)
End Function

Private Sub Check1_Click()
    Timer1.Enabled = CBool(Check1.Value)
    If Not CBool(Check1.Value) Then Picture1.BackColor = Text1(3).Text
End Sub

Private Sub Command1_Click()
    Text1(3).Text = "&H" & Hex(ShowColor(Me.hwnd, Picture1.BackColor))
    Text1(0).Text = Text1(3).Text And &HFF&
    Text1(1).Text = (Text1(3).Text And &HFF00& \ &H100&
    Text1(2).Text = (Text1(3).Text And &HFF0000) \ &H10000
End Sub

Private Sub Form_Load()
    hDisp = CreateDC("ISPLAY", 0, 0, dM)
    SetWindowPos Me.hwnd, -1, Me.Left, Me.Top, Me.ScaleWidth, Me.ScaleHeight, 3
End Sub

Private Sub Text1_Change(Index As Integer)
    On Error Resume Next
    If Not Index = 3 Then
        Text1(3).Text = "&H" & Hex(RGB(IIf(Len(Text1(0).Text), Text1(0).Text, 0), _
                                       IIf(Len(Text1(1).Text), Text1(1).Text, 0), _
                                       IIf(Len(Text1(2).Text), Text1(2).Text, 0)))
    End If
    If Check1.Value = 0 Then Picture1.BackColor = CLng(Text1(3).Text)
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0: Text1(Index).SelLength = Len(Text1(Index).Text)
End Sub

Private Function ShowColor(hOwner As Long, InOutColor As Long) As Long
  Dim i As Integer
  Dim CC As CHOOSECOLOR
  Dim CustomColors(0 To 16 * 4 - 1) As Byte
  For i = 0 To UBound(CustomColors)
     CustomColors(i) = 255
  Next
  With CC
       .lStructSize = Len(CC)
       .hwndOwner = hOwner
       .hInstance = App.hInstance
       .lpCustColors = StrConv(CustomColors, vbUnicode)
       .flags = &H1 Or &H2 Or &H4 Or &H8
       .RGBResult = InOutColor
       If ChooseColorAPI(CC) Then InOutColor = .RGBResult: ShowColor = .RGBResult
  End With
End Function

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    '
End Sub

Private Sub Timer1_Timer()
    Picture1.Cls
    GetCursorPos curPos
    Call BitBlt(Picture1.hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, hDisp, curPos.x - Picture1.ScaleWidth / 2, curPos.y - Picture1.ScaleHeight / 2, vbSrcCopy)
    
    Dim Color As Long
    Color = Picture1.Point(Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2)
    Text1(0).Text = Color And &HFF&
    Text1(1).Text = (Color And &HFF00& \ &H100&
    Text1(2).Text = (Color And &HFF0000) \ &H10000
    
    Picture1.Line (Picture1.ScaleWidth / 2, 0)-(Picture1.ScaleWidth / 2, Picture1.ScaleHeight)
    Picture1.Line (0, Picture1.ScaleHeight / 2)-(Picture1.ScaleWidth, Picture1.ScaleHeight / 2)
End Sub