Color Picker (Windows only)

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
axipher
Posts: 891
Joined: Dec 27, 2005 16:37
Location: Sudbury,Ontario
Contact:

Color Picker (Windows only)

Postby axipher » Dec 24, 2006 19:43

Hey yall, here's a little holiday gift from me. It's a simple color picker that draws colors based on HSL where you mouse's y position is the luminosity factor. When you click it pauses until you click again and pastes the HEX version of that point in RGB to the clipboard, just the number, bu prefix. So this can be used for just about anything from programming to web design or just for fun.

Code: Select all

#include once "windows.bi"
Declare Function CopyToClipboard(Byref x As String) As Integer

Function HSLtoRGB(hh As Integer,ss As Integer,ll As Integer) As Integer
  Dim As Double v,fract, vsf, mid1, mid2,m,sv
  Dim As Double h,s,l,r,g,b
  Dim As Integer sextant
 
  h = hh / 255
  s = ss / 255
  l = ll / 255
 
  v = iif((l <= 0.5),(l * (1.0 + s)),(l + s - l * s))
  If v <= 0 Then
    r = g = b = 0.0
  Else
   
    m = l + l - v
    sv = (v - m ) / v
    h *= 6.0
    sextant = Int(h)
    fract = h - sextant
    vsf = v * sv * fract
    mid1 = m + vsf
    mid2 = v - vsf
    Select Case As Const sextant
      Case 0
        r = v
        g = mid1
        b = m
      Case 1
        r = mid2
        g = v
        b = m
      Case 2
        r = m
        g = v
        b = mid1
      Case 3
        r = m
        g = mid2
        b = v
      Case 4
        r = mid1
        g = m
        b = v
      Case 5
        r = v
        g = m
        b = mid2
    End Select
  End If
  Return rgb(r * 255,g * 255,b * 255)
End Function

screenres 256,264,24,2
screenset 1,0

setmouse 127,127

Dim As Integer mx,my,mb,click,col,r,g,b,x,y

Do
  Cls
  getmouse mx,my,,mb
  If mb = 0 Then click = 0
  For y = 0 To 255
    For x = 0 To 255
      Pset (x,y),HSLtoRGB(x,255-y,iif(my >= 0 And my <= 255,my,127))
    Next
  Next
  col = Point(mx,my)
  r = ((col Shr 16) And &hff)
  g = ((col Shr 8) And &hff)
  b = (col And &hff)
  Draw String (0,256),Str(mx) & " #" & Hex(r) & Hex(g) & Hex(b),HSLtoRGB(mx,127,127)
  screencopy 1,0
  If mb > 0 And click = 0 Then
    click = 1
    CopytoClipBoard(Hex(r) & Hex(g) & Hex(b))
    While mb > 0
      getmouse mx,my,,mb
      If Len(Inkey) Then Exit Do
    Wend
    click = 0
    While mb = 0
      getmouse mx,my,,mb
      If Len(Inkey) Then Exit Do
    Wend
    click = 1
  End If
  Sleep 10
Loop Until Len(Inkey)

System



Function CopyToClipboard(Byref x As String) As Integer
    Function = false
    Dim As HANDLE hText = NULL
    Dim As Ubyte Ptr clipmem = NULL
    Dim As Integer n = Len(x)
    If n > 0 Then
        hText = GlobalAlloc(GMEM_MOVEABLE Or GMEM_DDESHARE, n + 1)
        Sleep 15
        If (hText) Then
            clipmem = GlobalLock(hText)
            If clipmem Then
                CopyMemory(clipmem, Strptr(x), n)
            Else
                hText = NULL
            End If
            If GlobalUnlock(hText) Then
                hText = NULL
            End If
        End If
        If (hText) Then
            If OpenClipboard(NULL) Then
                Sleep 15
                If EmptyClipboard() Then
                    Sleep 15
                    If SetClipboardData(CF_TEXT, hText) Then
                        Sleep 15
                        Function = True
                    End If
                End If
                CloseClipboard()
            End If
        End If
    End If
End Function


Feedback is welcome. :)
Last edited by axipher on Dec 25, 2006 3:22, edited 1 time in total.
badmrbox
Posts: 663
Joined: Oct 27, 2005 14:40
Location: Sweden
Contact:

Postby badmrbox » Dec 24, 2006 21:45

I guess the CVS version is needed to run this?
axipher
Posts: 891
Joined: Dec 27, 2005 16:37
Location: Sudbury,Ontario
Contact:

Postby axipher » Dec 25, 2006 3:24

Hmm, ya, I was using "FOR y as integer = 0 to 255". I changed that in the first post. Is there anything else that needs CVS, I only have CVS version so I can't test in old.
badmrbox
Posts: 663
Joined: Oct 27, 2005 14:40
Location: Sweden
Contact:

Postby badmrbox » Dec 26, 2006 17:33

Nah, now it works great for me.
bcohio2001
Posts: 556
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

A few tweeks......

Postby bcohio2001 » Sep 19, 2008 16:48

Added the variable m for mode.

When it sends the data to the clipboard if one of the r,g,b is less than 16, it only sends one character. Most people like 2, or at least I do.

Right now only 2 modes, HTML and Freebasic. But anyone can add more if they like. The only changes are in the do loop.

Code: Select all

Dim As Integer mx,my,mb,click,col,r,g,b,x,y,m

Do
   Cls
   GetMouse mx,my,,mb
   If mb And my > 256 Then
      m += 1
      If m > 1 Then
         m = 0
      EndIf
      mb = 0 'clear out mb
   EndIf
   If mb = 0 Then
      click = 0
   EndIf
   For y = 0 To 255
      For x = 0 To 255
         PSet (x,y),HSLtoRGB(x,255-y,IIf(my >= 0 And my <= 255,my,127))
      Next
   Next
   col = Point(mx,my)
   r = ((col Shr 16) And &hff)
   g = ((col Shr 8) And &hff)
   b = (col And &hff)
   Draw String (0,256),Str(mx) & " #" & Hex(r,2) & Hex(g,2) & Hex(b,2),HSLtoRGB(mx,127,127)
   If m = 0 Then
      Draw String (200,256),"HTML",HSLtoRGB(mx,127,127)
   EndIf
   If m = 1 Then
      Draw String (200,256),"Freebasic",HSLtoRGB(mx,127,127)
   EndIf
   ScreenCopy 1,0
   If mb > 0 And click = 0 Then
      click = 1
      If m = 0 Then 'html mode
         CopyToClipboard("#" & Hex(r,2) & Hex(g,2) & Hex(b,2))
      EndIf
      If m = 1 Then 'freebasic mode
         CopyToClipboard("RGB(" & Str(r) & "," & Str(g) & "," & Str(b) & ")")
      EndIf
      While mb > 0
         GetMouse mx,my,,mb
         If Len(Inkey) Then
            Exit Do
         EndIf
      Wend
      click = 0
      While mb = 0
         GetMouse mx,my,,mb
         If Len(Inkey) Then
            Exit Do
         EndIf
      Wend
      click = 1
   EndIf
   Sleep 10
Loop Until Len(Inkey)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 7 guests