Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Color Dropper...

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin Color Dropper...

    Nothing special, just a tiny utility to use for grabbing colors under pouse pointer anywhere on screen. Compiles fine with both PBWin 9 and 10. This is all I needed for own use right now, but maybe can be useful as part of a larger program with complete color maps etc? Please feel free to do whatever you want with it. PS, eventual discussions here - https://forum.powerbasic.com/forum/u...per-discussion
    Click image for larger version  Name:	ColorDropper.jpg Views:	0 Size:	14.5 KB ID:	806203
    '
    Code:
    ' ColorDropper.bas - Public Domain by Borje Hagsten Mars 2021
    ' Just a little utility to grab color anywhere on screen under mouse.
    ' Program uses desktop DC and presents formatted RGB + Hex values in
    ' a TextBox for simple copy & paste action. Included is a simple zoom
    ' label (DrawZoom code) and a color example label. Comments explain.
    
    #COMPILE EXE
    #DIM ALL
    #INCLUDE "WIN32API.INC"
    '--------------------------------------------------------------------
    %IDC_LBL_START = 101
    %IDC_LBL_SHOW  = 102
    %IDC_LBL_ZOOM  = 103
    %IDC_TEXTBOX1  = 131
    
    '====================================================================
    FUNCTION PBMAIN () AS LONG
      LOCAL hDlg AS DWORD, sTxt AS STRING
    
      DIALOG NEW 0, "Color Dropper",,, 140, 73, %WS_CAPTION OR %WS_SYSMENU OR _
                                                %WS_MINIMIZEBOX, 0 TO hDlg
      DIALOG SET COLOR hDlg, -1, %LTGRAY
    
     '------------------------------------------------------------------
      sTxt = "Click here to start" + $CRLF + _
             "Move cursor to target" + $CRLF + _
             "Release mouse on target"
      CONTROL ADD LABEL, hDlg, %IDC_LBL_START, sTxt, 4, 5, 90, 30, _
                         %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER OR %SS_NOTIFY OR %SS_SUNKEN
      CONTROL SET COLOR hDlg, %IDC_LBL_START, %BLUE,  RGB(250, 235, 166)
      CONTROL ADD LABEL, hDlg, %IDC_LBL_ZOOM, "", 100, 5, 35, 30, _
                         %WS_CHILD OR %WS_VISIBLE OR %SS_NOTIFY OR %SS_SUNKEN
    
      CONTROL ADD LABEL, hDlg, %IDC_LBL_SHOW, "", 100, 39, 35, 30, _
                         %WS_CHILD OR %WS_VISIBLE OR %SS_NOTIFY OR %SS_SUNKEN
      CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "", 4, 39, 90, 30, _
                           %WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE, %WS_EX_CLIENTEDGE
    
      '-------------------------------------------------------------------
      DIALOG SHOW MODAL hDlg, CALL DlgProc
    
    END FUNCTION
    
    '====================================================================
    CALLBACK FUNCTION DlgProc() AS LONG
      LOCAL r, g, b AS BYTE, sTxt AS STRING, pt AS POINTAPI
      STATIC hDC AS DWORD, iCol, StartDrag AS LONG
    
      SELECT CASE CB.MSG
      CASE %WM_INITDIALOG  ' do we want it to be topmost all the time? I do...
          SetWindowPos CB.HNDL, %HWND_TOPMOST, 0, 0, 0, 0, %SWP_NOMOVE OR %SWP_NOSIZE
    '----------------------------------------------------------
          ' this is a "hack" for Win7 looks in Win10
          STATIC iNcPaint AS LONG
          iNcPaint = 1  ' no NcPaint at this stage
          PostMessage CB.HNDL, %WM_USER, 0, 0
    
      CASE %WM_USER
          iNcPaint = 0  ' now let's do %WM_NCPAINT
          PostMessage CB.HNDL, %WM_NCACTIVATE, %TRUE, 0
    
      CASE %WM_NCPAINT : FUNCTION = iNcPaint
        ' end of Win10 hack
    '----------------------------------------------------------
    
      CASE %WM_COMMAND
          SELECT CASE CB.CTL
          CASE %IDC_LBL_START
             IF CBCTLMSG = %STN_CLICKED THEN
                 hDC = GetDC(0)  ' use entire desktop's dc
                 SetCapture CB.HNDL
                 StartDrag = 1
                 MOUSEPTR 5
                 SendMessage CB.HNDL, %WM_MOUSEMOVE, 0, 0 'trigger an initial one..
                 GOSUB DrawZoom
             END IF
          END SELECT
    
      CASE %WM_MOUSEMOVE
         IF StartDrag THEN
             GOSUB DrawZoom
             GetCursorPos pt
             IF iCol <> GetPixel(hDC, pt.x, pt.y) THEN
                 iCol = GetPixel(hDC, pt.x, pt.y)
                 GOSUB DoColors
             END IF
         END IF
    
      CASE %WM_LBUTTONUP
         IF StartDrag = 0 THEN EXIT FUNCTION
         GetCursorPos pt
         iCol = GetPixel(hDC, pt.x, pt.y)
         ReleaseDc(0, hDC)
         ReleaseCapture
         StartDrag = 0
         MOUSEPTR 0
         GOSUB DoColors
    
      END SELECT
    
    EXIT FUNCTION
    
    '----------------------------------------------------------
    DoColors:
      r = GetRValue(iCol) : g = GetGValue(iCol) : b = GetBValue(iCol)
      sTxt = " RGB(" + FORMAT$(r) + ", " + _
                       FORMAT$(g) + ", " + _
                       FORMAT$(b) + ")"  + $CRLF + _       ' <- RGB colors here
             " BGR  &H" + HEX$(b, 2) + HEX$(g, 2) + HEX$(r, 2)  ' <- BGR colors here
      CONTROL SET TEXT CB.HNDL, %IDC_TEXTBOX1, sTxt
      CONTROL REDRAW CB.HNDL, %IDC_TEXTBOX1
      CONTROL SET COLOR CB.HNDL, %IDC_LBL_SHOW, -1, iCol
      CONTROL REDRAW CB.HNDL, %IDC_LBL_SHOW
    RETURN
    
    '----------------------------------------------------------
    DrawZoom:  ' draw a zoom viewport in label %IDC_LBL_ZOOM
      LOCAL hDC2, hBrush, hPen, hZoom, x, y AS LONG, rc AS RECT
    
      hZoom = GetDlgItem(CB.HNDL, %IDC_LBL_ZOOM)
      GetClientRect hZoom, rc
      GetCursorPos pt
    
      hDC2 = GetDC(hZoom)
         StretchBlt hDC2, 0, 0, rc.nRight, rc.nBottom, _  ' zoom 3x3 around mouse
                    hDC, pt.x-1, pt.y-1, 3, 3, %SRCCOPY
    
         x = rc.nRight / 2
         y = rc.nBottom / 2
    
         hPen = CreatePen(%PS_SOLID, 1, RGB(255,255,255)) ' draw white rect
         hPen = SelectObject(hDC2, hPen)
         hBrush = SelectObject(hDC2, GetStockObject(%HOLLOW_BRUSH))
         Rectangle hDC2, x - 8, y - 8, x + 8, y + 8
         DeleteObject SelectObject(hDC2, hPen)
    
         hPen = CreatePen(%PS_SOLID, 1, RGB(0,0,0)) ' draw smaller black rect
         hPen = SelectObject(hDC2, hPen)
         Rectangle hDC2, x - 7, y - 7, x + 7, y + 7
         hBrush = SelectObject(hDC2, hBrush)
         DeleteObject SelectObject(hDC2, hPen)
    
      ReleaseDc hZoom, hDC2
    RETURN
    
    END FUNCTION
    '

  • #2
    Great Borje! As usual
    Francesco

    Comment

    Working...
    X