Ultimate colour requestor

Share your advanced PureBasic knowledge/code with the community.
XCoder
User
User
Posts: 68
Joined: Tue Dec 31, 2013 9:18 pm

Ultimate colour requestor

Post by XCoder »

Recently I needed a colour requestor for a program I was developing. I needed to be able to load and save user defined colours and to store the currently selected colour. The program used several different colour palettes so I needed to be able to store the data for each palettes independently.

I decided to create a class that would achieve this purpose [I am using the term 'class' to refer to a template that defines a set of methods and variables. I will use the term object to refer to an instance of a class]. The code for the class is shown below.

Code: Select all

; To use this object in another PB file, use:

; XIncludeFile "PaletteObj.pbi"
; UseModule JC_ClassColourPalette

; Copyright (C) 2020 John Crew

; Redistribution and use in source and binary forms, with or without modification, for commercial and non-commercial
; purposes are permitted provided that the following conditions are met:

; 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

; 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
; disclaimer in the documentation and/or other materials provided with the distribution.

; 3. Neither the name of the copyright holder nor contributors may be used to endorse or promote products derived
; from this software.

; 4. The source code, and any derived source code, must be made available to users of this software and any software
; derived from this source code.

; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
; THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


DeclareModule JC_ModColourPalette
  #Edge = 10 ;Distance from the inner edge of the palette window to the first colour square
  #Border = 2 ; 
  #Separation=5 ;Distance between coloured squares
  #OSq = 15 ; Length of each side of the coloured squares
  #Rows=5 ;Number of rows of coloured squares
  #Columns=8 ;Number of columns of coloured squares 
  
  ;CLASS INTERFACE
  
  Interface JC_ClassColourPalette
    PutUserDefinedColours(Array Colours(1))
    GetUserDefinedColours(Array Colours(1))
    PaletteWindowEvents()
    BalloonInfo()
    OriginalProcessButtonMsg()
    MoreColoursClicked()
    GetSelectedColour()
    SquareClicked()
    DrawBorder(index)
    GetColouredSquare()
    ShowPalette(xpos, ypos)     ;Call this method to show the palette. xpos and ypos are screen co-ords that determine where to position the palette window
    KillFocus(hwnd)
    MouseLeave()
    SaveUserColours()
    LoadUserColours()
    Free()            ;Call this method to free the palette object
  EndInterface   
  
  Declare.i InitColourPalette(initColour = $0000FF)
  
EndDeclareModule

Module JC_ModColourPalette
  EnableExplicit
  
  Enumeration;{
    #btnMoreColours
  EndEnumeration

;Constants for the tooltip
#TTF_ABSOLUTE = $0080
#TTF_TRACK = $0020
;}

;{ Structures for the palette

;The structure COLORREF is used to store user defined colours from the Color common dialog box.

   Structure COLORREF ; Used by Colour requestor
    RGB.l[16]
    EndStructure 
  CompilerIf  #PB_Compiler_Processor = #PB_Processor_x86
    
  ;A set of PALETTE structures are stored in a list within the Structure Class_Palette
  ;Each element in the list represents one of the coloured squares in the palette
  
   Structure PALETTE
    index.w   ;Index for the coloured square - starts at 0
    color.l   ;A property that represents the colour of the square
    colName.s ;The name of the colour
    rc.RECT   ;The co-ords of the rectangle containing the coloured square
  EndStructure 
  
    ;-CLASS TEMPLATE
  Structure Class_Palette
      VirtualTable.i    ;This table contains a set of addresses for the functions in the class. MUST be first item in the structure
      rcPrev.Rect       ;These are data associated with the class
      CurrentIndex.i    ;Index of the currently selected element in the palette list
      hTooltip.l        ;Windows handle for the tooltip
      List palette.PALETTE()  ;List of PALETTE structures for each coloured square in the object
      CurrentColour.l 
      IDPaletteWindow.l ;PB ID of the Palette window
      hwndPalette.l     ;Windows handle of the Palette window
      IDBtnMoreCols.l   ;PB ID of the 'More colours' button
      hwndBtnMoreCols.l ;Windows handle of the 'More colours' button
      oldButtonProc.l   ;Pointer to original message processing proc for the 'More colours' button
      ColourRef.COLORREF;Used for getting more colours
      PaleteFile.s      ;Stores name of the file containing details of user defined colours
  EndStructure   
  
  ;========================================================
  CompilerElse  ;RGB.i[16] for x64

  ;A set of PALETTE structures are stored in a list within the Structure Class_Palette
  ;Each element in the list represents one of the coloured squares in the palette
  
   Structure PALETTE
    index.w   ;Index for the coloured square - starts at 0
    color.i   ;A property  that represents the colour of the square
    colName.s ;The name of the colour
    rc.RECT   ;The co-ords of the rectangle containing the coloured square
  EndStructure 
  
    ;-CLASS TEMPLATE
  Structure Class_Palette
      VirtualTable.i    ;This table contains a set of addresses for the functions in the class. MUST be first item in the structure
      rcPrev.Rect       ;These are data associated with the class
      CurrentIndex.i    ;Index of the currently selected element in the palette list
      hTooltip.i        ;Windows handle for the tooltip
      List palette.PALETTE()  ;List of PALETTE structures for each coloured square in the object
      CurrentColour.i
      IDPaletteWindow.i ;PB ID of the Palette window
      hwndPalette.i     ;Windows handle of the Palette window
      IDBtnMoreCols.i   ;PB ID of the 'More colours' button
      hwndBtnMoreCols.i ;Windows handle of the 'More colours' button
      oldButtonProc.i   ;Pointer to original message processing proc for the 'More colours' button
      ColourRef.COLORREF;Used for getting more colours
      PaleteFile.s      ;Stores name of the file containing details of user defined colours
  EndStructure 
  
CompilerEndIf


 ;}

Procedure MAKELONG(low, high)
  ProcedureReturn low | (high<<16)
EndProcedure

Procedure PutUserDefinedColours(*This.Class_Palette, Array Colours(1))
; This procedure will get user defined colours from the array that is passed as a parameter and store them in the object
  Protected j
  For j=0 To 15
    *This\ColourRef\RGB[j]  = Colours(j)
  Next j
EndProcedure

Procedure GetUserDefinedColours(*This.Class_Palette, Array Colours(1))
; This procedure will copy user defined colours from the object to the array that is passed as a parameter
  Protected j
  For j=0 To 15
    Colours(j) = *This\ColourRef\RGB[j]
  Next j
EndProcedure

Procedure PaletteWindowEvents(*This.Class_Palette) 
; When another module calls ShowPalette(), control is immediately passed back to the other module before a colour can be selected.
; So if the other module tries to get a selected colour immediately after the palette window opens by calling GetSelectedColour()
; then as a colour has not been selected the old colour is returned.
; To prevent this, the object uses its own WaitWindowEvent() in this procedure.
; The effect of the WaitWindowEvent() in this procedure is that it suspends events from being processed by the WaitWindowEvent()
; of the other module as events are passed to this procedure.
; When the palette window closes [using PostMessage_(*This\hwndPalette,#WM_SYSCOMMAND,#SC_CLOSE,0)] the WaitWindowEvent() in
; the other module takes over event processing.
; IMPORTANT The palette window must be closed by calling PostMessage_(*This\hwndPalette,#WM_SYSCOMMAND,#SC_CLOSE,0)
; If the palette window is closed using any other means then then WaitWindowEvent() in this procedure will continue to process
; events and the main window will not receive them. This will freeze the main window

  Protected QuitPaletteWindow
      Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          If EventWindow() = *This\IDPaletteWindow
            QuitPaletteWindow = #True
            CloseWindow(*This\IDPaletteWindow)
          EndIf
      EndSelect
    Until QuitPaletteWindow
EndProcedure

Procedure Free(*This.Class_Palette)
    ClearStructure(*This, Class_Palette)
    FreeStructure(*This)
EndProcedure

Procedure BalloonInfo(*This.Class_Palette, PosX, PosY, MaxWidth)
  Protected hToolTip
  Protected Balloon.TOOLINFO
  Protected null.w
  
  hToolTip=CreateWindowEx_(#WS_EX_TOPMOST,#TOOLTIPS_CLASS,#Null,#WS_POPUP | #TTS_NOPREFIX | #TTS_ALWAYSTIP | #TTS_BALLOON | #TTS_CLOSE,0,0,0,0,*This\hwndPalette,0,GetModuleHandle_(0),0)
  SetWindowTheme_(hToolTip, @null, @null); Required for the colours below
  SendMessage_(hToolTip,#TTM_SETTIPTEXTCOLOR,$0202FD,0)
  SendMessage_(hToolTip,#TTM_SETTIPBKCOLOR,$DCFFFF,0)
  SendMessage_(hToolTip,#TTM_SETMAXTIPWIDTH,0,MaxWidth) ;Set as a multiline tooltip with wordwrap
  SendMessage_(hToolTip, #TTM_TRACKPOSITION, 0, MAKELONG(PosX,PosY))
  
  Balloon.TOOLINFO\cbSize=SizeOf(TOOLINFO)
  Balloon\uFlags=#TTF_IDISHWND | #TTF_TRACK | #TTF_ABSOLUTE
  Balloon\hwnd=*This\hwndPalette
  Balloon\uId=*This\hwndPalette
  Balloon\lpszText= @*This\palette()\colName
  Balloon\hinst = GetModuleHandle_(0)
  
  GetWindowRect_(*This\hwndPalette, @Balloon\rect)
  
  SendMessage_(hToolTip, #TTM_ADDTOOL, 0, @Balloon); ;Register tooltip with the control
  SendMessage_(hToolTip, #TTM_TRACKACTIVATE, 1, @Balloon)
  ProcedureReturn hToolTip
EndProcedure

Procedure SetMouseTracking(hWindow)
  ;This procedure is not a class method
  ;If the mouse leaves the Palette Window rapidly then the tooltip over the coloured squares may stay on show.
  ;Also, the border around a non-selected colour square may show if the mouse moves rapidly outside this window.
  ;To prevent this, the Palette Window must respond to the #WM_MOUSELEAVE message to destroy the tooltip and
  ;remove the unwanted border
  ;To allow the Palette Window to respond to the #WM_MOUSELEAVE message the Window's
  ;function TrackMouseEvent() must be called
  ;As Windows cancels the tracking function whenever the #WM_MOUSELEAVE message fires, it
  ;is necessary to call the TrackMouseEvent() again when the mouse returns to the Palette Window.
  ;This procedure sets up the TRACKMOUSEEVENT structure and calls TrackMouseEvent()
  
  Protected TrackMouse.TRACKMOUSEEVENT
  TrackMouse\cbSize =SizeOf(TrackMouse)
  TrackMouse\dwFlags = #TME_LEAVE
  TrackMouse\hwndTrack = hWindow
  TrackMouseEvent_(@TrackMouse)
EndProcedure

Procedure MoreColoursClicked(*This.Class_Palette) 
  ;This procedure opens the  Color common dialog box that enables the user to select a color.
  ;It is called when the user clicks the button 'More colours'
  Protected ChooseColour.CHOOSECOLOR, hwnd, I
  ChooseColour\rgbResult = *This\CurrentColour
  ChooseColour\lpCustColors = *This\ColourRef
  ChooseColour\flags = #CC_ANYCOLOR | #CC_RGBINIT   ;if required, use #CC_FULLOPEN to display the additional controls
  ChooseColour\lStructSize = SizeOf(CHOOSECOLOR)
  ChooseColour\hwndOwner = *This\hwndPalette
  ChooseColour\rgbResult = *This\CurrentColour
  ChooseColour\lpCustColors = *This\ColourRef
  ChooseColour\flags = #CC_ANYCOLOR | #CC_RGBINIT ;| #CC_FULLOPEN ;To display custom colour controls too | #CC_ENABLEHOOK 
  
  If ChooseColor_(@ChooseColour)  ;Open a Color dialog box; @ChooseColour points to a CHOOSECOLOR structure that contains information used to initialize the dialog box. When ChooseColor returns, this structure contains information about the user's color selection.
     *This\CurrentColour = ChooseColour\rgbResult
  EndIf

  PostMessage_(*This\hwndPalette,#WM_SYSCOMMAND,#SC_CLOSE,0)  
EndProcedure

Procedure OriginalProcessButtonMsg(*This.Class_Palette)
  ProcedureReturn *This\oldButtonProc
EndProcedure

Procedure BtnGadgetProc(hwnd, msg, wparam, lparam)
  Protected *This.JC_ClassColourPalette = GetWindowLongPtr_(hwnd, #GWLP_USERDATA)
  Select msg
    Case #WM_LBUTTONDOWN
      *This\MoreColoursClicked()  
      ProcedureReturn 1
  EndSelect
  
  ProcedureReturn CallWindowProc_(*This\OriginalProcessButtonMsg(), hwnd, msg, wparam, lparam)
EndProcedure

Procedure DrawBorder(*This.Class_Palette, index)
  ;This procedure is called as the mouse moves over the palette window
  ;Index is the index number of the coloured square that the mouse is over (-1 if it is not over a coloured square)
  ;This procedure draws a border around the square with the specified index.
  ;It also shows the name of the colour in a tooltip
  ;It removes the border if the index is -1 and destroys the tooltip
  Protected rc.Rect, BorderCol, BorderInvCol
  Protected rcPalette.RECT

  BorderCol = RGB(0,0,0)
  BorderInvCol = GetSysColor_(#COLOR_BTNFACE)   ;Need to use the normal window background colour for this...
  
  If (index >-1) And index < ((#Rows*#Columns)) ;Latter needed as index goes above #Rows*#Columns if more colours dialog shows
    SelectElement(*This\palette(), index)       ;Get the structure for the selected coloured square
    rc=*This\palette()\rc                       ;Get the rectangular co=ords for the current colour
    InflateRect_(@rc, #Border, #Border)         ;and increase its size for drawing its border

    If StartDrawing(WindowOutput(*This\IDPaletteWindow))
        ;Remove the border from the previously selected colour square
        Line(*This\rcPrev\left, *This\rcPrev\top, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
        Line(*This\rcPrev\right, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
        Line(*This\rcPrev\left, *This\rcPrev\bottom, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
        Line(*This\rcPrev\left, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
        
        If (*This\CurrentIndex <> index) ;Do not remove the border from the square showing the current colour
        *This\rcPrev = rc ;Store the current expanded rectangle pointed to by the mouse if it is not the current colour
        ; so that its border can be erased when the mouse moves over a different colour
      EndIf
      
      ;Draw a rectangle around the selected coloured square
      Line(rc\left, rc\top, rc\right-rc\left, 1, BorderCol)
      Line(rc\right, rc\top, 1, rc\bottom-rc\top, BorderCol)
      Line(rc\left, rc\bottom, rc\right-rc\left, 1, BorderCol)
      Line(rc\left, rc\top, 1, rc\bottom-rc\top, BorderCol)
      
    StopDrawing()
  EndIf

  ;Now show tooltip
  If *This\hToolTip = #Null
    GetClientRect_(*This\hwndPalette, @rcPalette)         ; Get client co-ords for Palette window
    MapWindowPoints_(*This\hwndPalette, 0, @rcPalette, 2) ; Convert rcPalette co-ords to screen coords
    ;Screen coords are needed for positioning the tooltip
    *This\hToolTip = BalloonInfo(*This.Class_Palette, rc\right+rcPalette\left, rcPalette\top+rc\bottom, 100)

    ;Tracking is cancelled by Windows when the mouse leaves the palette window so
    ;the procedure SetMouseTracking() must be called again when the mouse is in the palette window
    ;to reset the tracking process
    
    SetMouseTracking(*This\hwndPalette)
    
  EndIf
  
  ;Else Index is -1; this will occur as the mouse moves between the coloured squares so remove the border
  ;from the highlighted square and detroy the tooltip
  
  Else 
    If StartDrawing(WindowOutput(*This\IDPaletteWindow))
      ;Remove the border from coloured squares when a custom colour is selected 
      Line(*This\rcPrev\left, *This\rcPrev\top, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
      Line(*This\rcPrev\right, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
      Line(*This\rcPrev\left, *This\rcPrev\bottom, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
      Line(*This\rcPrev\left, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
      StopDrawing()
    EndIf
    
    DestroyWindow_(*This\hToolTip)
    *This\hToolTip=#Null
  EndIf
EndProcedure

Procedure GetColouredSquare(*This.Class_Palette)
  ;This procedure determines the index for the square that the mouse is over and then calls DrawBorder() to
  ;draw a border around the coloured square that the mouse occupies and show a tooltip describing the colour
  ;It is called by the Palette window's callback procedure when the message #WM_MOUSEMOVE is sent to the palette window
  ;This code cannot be placed in the callback procedure itself as that can only access functions in the
  ;object and not, for example, access variables such as the list when it needs to be reset as in ResetList(*This\palette()) 
  Protected MousePos.POINT, rc.RECT
  Protected Found=-1
  Protected BorderInvCol = GetSysColor_(#COLOR_BTNFACE)
  
      GetCursorPos_(@MousePos)                          ;Gets cursor position of the mouse in the palette window in screen co-ords
      ScreenToClient_(*This\hwndPalette, @MousePos)     ;converts the screen coordinates of the mouse position to palette window coordinates. 
      ResetList(*This\palette())              	        ; Reset the List To access the first element.
      While NextElement(*This\palette()) And Found=-1   ; Look for the structure for the currently selected square in the palette
        rc=*This\palette()\rc
        If PtInRect_(@rc, MousePos\x | (MousePos\y<<32)) <>0 ;If mouse is on this coloured square then get index of square
          Found= *This\palette()\index
        EndIf
      Wend
      
      DrawBorder(*This.Class_Palette, Found)

 EndProcedure
 
Procedure SquareClicked(*This.Class_Palette)
   ; This is called by paletteWinProc() when the left mouse button is clicked on the palette
   ; window (whether the mouse is on a coloured square or between the coloured squares)
   ; It resets the fields in rcPrev to zero, sets the value of CurrentColour, destroys the tooltip and posts
   ; a message to close the palette window.

  *This\rcPrev\right = 0
  *This\rcPrev\left = 0
  *This\rcPrev\top = 0
  *This\rcPrev\bottom = 0
  *This\CurrentColour=*This\palette()\color
  DestroyWindow_(*This\hToolTip)
  *This\hToolTip=#Null
  PostMessage_(*This\hwndPalette,#WM_SYSCOMMAND,#SC_CLOSE,0) ;Close the palette window using the waitWindowEvent() loop in PaletteWindowEvents(*This.Class_Palette)
EndProcedure

Procedure KillFocus(*This.Class_Palette, wParam)
  ;This procedure is called by paletteWinProc()
  ;Closes the palette window if another window is given the focus except for btnMoreColours 
  ;Do not close the palette window if btnMoreColours has the focus
  ;otherwise the dialog for setting a custom colour is not shown when
  ;btnMoreColours is clicked

  PostMessage_(*This\hwndPalette,#WM_SYSCOMMAND,#SC_CLOSE,0) ;Close the palette window using the waitWindowEvent() loop in PaletteWindowEvents(*This.Class_Palette)  
  DestroyWindow_(*This\hToolTip)
  *This\hToolTip=#Null
EndProcedure

Procedure MouseLeave(*This.Class_Palette)
  ;This procedure is called by paletteWinProc()
  ;It prevents the tooltip from staying on show if the mouse leaves the palette window rapidly when
  ;the palette window receives the message #WM_MOUSELEAVE
  ;It also removes the border around the coloured square that is not selected if the mouse
  ;leaves the palette window too quickly
  ;Requires the procedure SetMouseTracking() to enable the palette window to respond to this message
  ;Tracking is cancelled by Windows when the mouse leaves the window so
  ;the procedure SetMouseTracking() must be called again when the mouse is in the palette window
  Protected BorderInvCol = GetSysColor_(#COLOR_BTNFACE)
  DestroyWindow_(*This\hToolTip)
  *This\hToolTip=#Null
  If StartDrawing(WindowOutput(*This\IDPaletteWindow))
    ;Remove the border from coloured squares
    Line(*This\rcPrev\left, *This\rcPrev\top, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
    Line(*This\rcPrev\right, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
    Line(*This\rcPrev\left, *This\rcPrev\bottom, *This\rcPrev\right-*This\rcPrev\left, 1, BorderInvCol)
    Line(*This\rcPrev\left, *This\rcPrev\top, 1, *This\rcPrev\bottom-*This\rcPrev\top, BorderInvCol)
    StopDrawing()
  EndIf
EndProcedure

Procedure GetSelectedColour(*This.Class_Palette)
  ;This method is called by the parent module to obtain the selected colour
  ProcedureReturn *This\CurrentColour
EndProcedure

Procedure paletteWinProc(hwnd, msg, wparam, lparam)
  ;This is a callback procedure for the colour palette window
  ;When an object is created it is not possible to pass its address to callback methods.
  ;However, it can call object methods.
  ;This callback procedure responds to messages sent to the palette window from the mouse:
  ;It calls GetColouredSquare() when the mouse is over a coloured square to draws a border around
  ;the square that the mouse is over and to show a tooltip naming the selected colour.
  ;When the mouse is between coloured squares the tooltip is removed
  ;It calls SquareClicked() when the left mouse button is clicked.
  
  ; Get the pointer to the object in *This.JC_ClassColourPalette
  Protected *This.JC_ClassColourPalette = GetWindowLongPtr_(hwnd, #GWLP_USERDATA)
  
  Select msg
    Case #WM_MOUSEMOVE
      *This\GetColouredSquare() ;Draw border around coloured square under mouse cursor and show tooltip naming the colour of the square

    Case #WM_LBUTTONDOWN
      *This\SquareClicked()
      
    Case #WM_KILLFOCUS
      If hwnd<>(GetActiveWindow_())
        *This\KillFocus(0)
      EndIf
      ProcedureReturn 0
      
    Case #WM_MOUSELEAVE
      *This\MouseLeave()
      
  EndSelect
  
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

Procedure ShowPalette(*This.Class_Palette,xpos=0, ypos=0)
  ; Draws the palette window and initialises the value of CurrentIndex
  ; Calls DrawBorder() to draw a border around the currently selected colour and
  ; calls PaletteWindowEvents() so that all events are processed by this object instead of
  ; the parent module.
  ; x and y specify the position of the top left hand corner of the colour palette window
  Protected Found=-1
  Protected PaletteWidth= (2* #Edge)+(#Separation*(#Columns-1))+((#Columns) *#OSq)
  Protected PaletteHeight= (2* #Edge)+#Separation*(#Rows-1)+(#Rows*#OSq)
  Protected row, column, index=0
  Protected LeftX = #Edge, TopY = #Edge
  Protected Width = #OSq
  Protected Height = #OSq
  
  PaletteHeight= PaletteHeight + 30 ;Allow space for the button 'More colours'
 
  *This\IDPaletteWindow = OpenWindow(#PB_Any, xpos, ypos, PaletteWidth, PaletteHeight, "",  #PB_Window_BorderLess)
  *This\hwndPalette=WindowID(*This\IDPaletteWindow)
  SetWindowCallback(@paletteWinProc(), *This\IDPaletteWindow) ; Set up a callback procedure for the palette window with ID of IDPaletteWindow
  SetWindowLongPtr_(*This\hwndPalette, #GWLP_USERDATA, *This) ;Enables paletteWinProc() to access the object
  StickyWindow(*This\IDPaletteWindow, #True) ;Set Palette window topmost
  
  *This\IDBtnMoreCols = ButtonGadget(#PB_Any, 10, PaletteHeight-25, 150, 18, "More colours")
  *This\hwndBtnMoreCols = GadgetID(*This\IDBtnMoreCols)

  *This\oldButtonProc = SetWindowLongPtr_(*This\hwndBtnMoreCols, #GWL_WNDPROC, @BtnGadgetProc())
  SetWindowLongPtr_(*This\hwndBtnMoreCols, #GWLP_USERDATA, *This) ;Enables the callback BtnGadgetProc() to access the object
  
  ;Draw a coloured square for each element in the list palette()
  FirstElement(*This\palette()) 
  For row = 0 To #Rows-1
    For column = 0 To #Columns-1
      If StartDrawing(WindowOutput(*This\IDPaletteWindow))
        Box(LeftX, TopY, Width, Height, *This\palette()\color)
        StopDrawing()
        *This\palette()\rc\left = LeftX
        *This\palette()\rc\top = TopY
        *This\palette()\rc\right = LeftX + #OSq
        *This\palette()\rc\bottom = TopY + #OSq
        LeftX = LeftX + #OSq + #Separation
      EndIf
      NextElement(*This\palette())
    Next column
    LeftX = #Edge
    TopY = TopY + #OSq + #Separation
  Next Row
  
  ResetList(*This\palette()) ; Reset the list named palette to access the first element.
  While NextElement(*This\palette()) And *This\palette()\color<>*This\CurrentColour ; Find the index of the current colour
    Found= *This\palette()\index
  Wend
    
  Found=Found+1
  *This\CurrentIndex = Found ; store the index for the current colour
  DrawBorder(*This.Class_Palette, Found)
  
  PaletteWindowEvents(*This.Class_Palette)
  
  EndProcedure
  
Procedure SaveUserColours(*This.Class_Palette)
    ;This procedure saves user defined colours to a file that can be specified by the user.
    ;It is more likely that the main program file will get the user defined colours using
    ;GetUserDefinedColours() and store the colours in a generic data file
  Protected Pattern$, Pattern, FileName$, hFile, j, Result

  Pattern$ = "All files (*.*)|*.*"
  Pattern = 0  
  FileName$ = SaveFileRequester("Please name the file to save", *This\PaleteFile, Pattern$, Pattern)
  If FileName$
    hFile = CreateFile(#PB_Any, FileName$)
    
    If hFile <> 0
      For j=0 To 15
        Result = WriteInteger(hFile, *This\ColourRef\RGB[j])
      Next j
      CloseFile(hFile)
    Else
      MessageRequester("Information", "File error", 0) 
    EndIf
    
  Else
    MessageRequester("Information", "The file was not saved", 0) 
  EndIf
EndProcedure
  
Procedure LoadUserColours(*This.Class_Palette)
    ;This procedure loads user defined colours from a file that can be specified by the user.
    ;It is more likely that the main program file will get the user defined colours
    ;from a generic data file and put the colours in the palette using PutUserDefinedColours()
  Protected Pattern$, Pattern, Filename$, hFile, j
  Pattern$ = "All files (*.*)|*.*"
  Pattern = 0  
  Filename$ = OpenFileRequester("Load file", *This\PaleteFile, Pattern$, Pattern)
  If FileName$
    hFile= ReadFile(#PB_Any, Filename$)
    
    For j=0 To 15
      *This\ColourRef\RGB[j]=ReadInteger(hFile)
    Next j
    
    *This\PaleteFile=Filename$
    CloseFile(hFile)
  Else
    MessageRequester("Information", "The file was not loaded.", 0) 
  EndIf
EndProcedure
  
Procedure.i InitColourPalette(initColour = $0000FF)
  ;This method initialises an instance of the class
  ;It allocates memory for the object using the PB call AllocateStructure(), stores the addresses of 
  ; the methods for the object in the virtual table and initialises values
  ;It returns the address of the object

  Protected *This.Class_Palette, i

  *This = AllocateStructure(Class_Palette)
  *This\VirtualTable = ?VTable_Class_Palette
  *This\CurrentColour = initColour 
  *This\hTooltip = #Null
  
  ;Initialise the rcPrev structure to give a square of zero dimensions
  *This\rcPrev\right = 0
  *This\rcPrev\left = 0
  *This\rcPrev\top = 0
  *This\rcPrev\bottom = 0
  
  ;Read the numerical values of the colours from the data section into the object's list named palette()
  ;and store a zero-based index for each one
    
    Restore cols
    For i = 0 To (#Rows*#Columns)-1
      AddElement(*This\palette())
      Read *This\palette()\color
      *This\palette()\index = i
    Next i
     
    ;Read the names of each colour from the data section and store them in the object's list named palette()
    
    FirstElement(*This\palette()) 
    Restore stringnames
    For i = 0 To (#Rows*#Columns)-1
       Read.s *This\palette()\colName
       NextElement(*This\palette())
    Next i

    ProcedureReturn *This
EndProcedure

DataSection ;{ 
    ;VIRTUAL TABLE
    ;This data block contains the addresses of class functions that will be stored in the VirtualTable for the class
  
    VTable_Class_Palette:
      Data.i @PutUserDefinedColours()
      Data.i @GetUserDefinedColours()
      Data.i @PaletteWindowEvents()
      Data.i @BalloonInfo()
      Data.i @OriginalProcessButtonMsg()
      Data.i @MoreColoursClicked()
      Data.i @GetSelectedColour()
      Data.i @SquareClicked()
      Data.i @DrawBorder()
      Data.i @GetColouredSquare()
      Data.i @ShowPalette()
      Data.i @KillFocus()
      Data.i @MouseLeave()
      Data.i @SaveUserColours()
      Data.i @LoadUserColours()
      Data.i @Free()
    
    ;This is the data for the colours that are displayed in the colour palette with their names
    cols:
      Data.i $000000,$003399,$003333,$003300,$663300,$800000,$993333,$333333          
      Data.i $000080,$0066FF,$008080,$008000,$808000,$FF0000,$996666,$808080          
      Data.i $0000FF,$0099FF,$00CC99,$669933,$CCCC33,$FF6633,$800080,$999999          
      Data.i $FF00FF,$00CCFF,$00FFFF,$00FF00,$FFFF00,$FFCC00,$663399,$C0C0C0         
      Data.i $CC99FF,$99CCFF,$99FFFF,$CCFFCC,$FFFFCC,$FFCC99,$FF99CC,$FFFFFF   
      
    stringnames:
      Data.s "Black","Brown","Dark Olive Green","Dark Green","Dark Teal","Dark blue","Indigo","Dark grey"  
      Data.s "Dark red","Orange","Olive","Green","Teal","Blue","Blue-grey","Grey - 40"
      Data.s "Red","Light orange","Lime","Sea green","Aqua","Light blue","Violet","Grey - 50"
      Data.s "Pink","Gold","Yellow","Bright green","Turquoise","Skyblue","Plum","Light grey"
      Data.s "Rose","Tan","Light yellow","Pale green","Pale turquoise","Pale blue","Lavender","White"
  EndDataSection
;}
  
EndModule


How to use the module PaletteObj.pbi
===============================================
Insert the following code in the module that will use the palette code:

XIncludeFile "PaletteObj.pbi"
UseModule JC_ModColourPalette

Declare a global value for the object:

Global ColourPalette1.JC_ClassColourPalette

Set up an instance of the class for the palette object:

ColourPalette1.JC_ModColourPalette::JC_ClassColourPalette = JC_ModColourPalette::Init(0) ;Create an instance for the class with initial colour Black (0)

Initialise the object:
Global ColourPalette1.JC_ClassColourPalette = InitColourPalette(0) ;Create an instance of the class with initial colour Black (0)

The parameter passed to the object is the colour that is to be highlighted when the palette window opens.

Alternatively the object can be initialised when it is declared:
Global ColourPalette1.JC_ClassColourPalette = InitColourPalette(0) ;Create an instance of the class with initial colour Black (0)

Each object stores the currently selected colour and any customised colours that you may have set up (discussed later). If you are writing an Editor then the palette instance that has been created may be for the font colour. You may need to set up another instance of the object for the background colour and call this ColourPalette2, eg:

Global ColourPalette2.JC_ClassColourPalette = InitColourPalette() ;Create an instance of the class for the second object

To show the first palette use:

ColourPalette1\ShowPalette(610, 250) ;the parameters are the x and y (screen) coordinates for the top left corner of the colour palette.

This will open a palette window and draw a black border around the currently selected colour. If none of the squares have this border then a custom colour is in use and this colour may be accessed by clicking the button marked More colours.

While the palette window is open, window events are sent to the palette window; events will not be processed by the parent window. When the user clicks on a colour in the palette window the palette window closes and parent window will process any events that now occur.

User defined colours are available from the main palette window by clicking the button marked More colours. This will open the Color common dialog box in Windows. The user may select one of the colours shown under Basic colours or click the button Define Custom Colours>> to define their own colour(s). Defined colours can be stored by clicking the button "Add to Custom Colours". When the user clicks the OK button the object stores the Custom colour so that it is available for selection later on.

After closing the Palette window, the user may retrieve the selected colour number using the object's function GetSelectedColour(), eg:

ColourPalette1\GetSelectedColour()

The user defined colours may be copied into an array in the parent module from the object by calling the method GetUserDefinedColours(). This must include a parameter that is a 1-dimensional array of 16 elements. This enables the colours to be stored in a file using a procedure in the parent module.

Example code that gets user defined colours into the array UserDefinedColours()

Dim UserDefinedColours(16)
ColourPalette1\GetUserDefinedColours(UserDefinedColours()) ;'1' indicates a 1-dimensional array
For j = 0 To 15
Debug Str(j)+ " "+ Str(UserDefinedColours(j)) ;Shows the values of the stored colours
Next j

The object may be initialilsed with a set of user defined colours. The user defined colours must be stored in an array with 16 elements; this is the maximum number of custom colours that can be defined. For example:

Dim UserDefinedColours(16)

The default value of each colour in this array is 0 coresponding the colour black.
Colours need not be put in this array in sequence eg you could put custom colours in the first and last element of the array.

UserDefinedColours(0) = 255
UserDefinedColours(15) = RGB(0, 0, 255)

To transfer the values in this array to the object use the method PutUserDefinedColours():

ColourPalette1\PutUserDefinedColours(UserDefinedColours())

When the palette Window is no longer required, the object must be freed using the Free() method:

ColourPalette1\Free()

The following program demonstrates the Ultimate Colour Requestor:

Code: Select all

; This module demonstrates my ultimate colour palette window object

; Copyright (C) 2020 John Crew

; Redistribution and use in source and binary forms, with or without modification, for commercial and non-commercial
; purposes are permitted provided that the following conditions are met:

; 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

; 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
; disclaimer in the documentation and/or other materials provided with the distribution.

; 3. Neither the name of the copyright holder nor contributors may be used to endorse or promote products derived
; from this software.

; 4. The source code, and any derived source code, must be made available to users of this software and any software
; derived from this source code.

; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
; THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

EnableExplicit

XIncludeFile "PaletteObj.pbi"
UseModule JC_ModColourPalette

Enumeration;{
  #MainWindow=10
  #Editor
  #Button1
  #Button2
  #Button3
EndEnumeration
;}

Global j, Quit=#False
Global colPalette1.JC_ClassColourPalette = InitColourPalette(0)  ;Create an instance for the class with initial selected colour Black (0)
Global colPalette2.JC_ClassColourPalette = InitColourPalette()   ;Create another instance for the class with default colour selected

Dim UserDefinedColours(16) ;This stores user defined colours

OpenWindow(#MainWindow, 0, 0, 512, 470, "Colour palette demo", #PB_Window_ScreenCentered | #PB_Window_SystemMenu)
EditorGadget(#Editor, 10, 10, 512-20, 384-30-22)
ButtonGadget(#Button1, 10, 350, 100, 22, "Show palette 1")
ButtonGadget(#Button2, 120, 350, 100, 22, "Show palette 2")
ButtonGadget(#Button3, 230, 350, 260, 22, "Show user defined colour refs for Palette1")

;Set two user defined colours
UserDefinedColours(0) = 255 ;Red
UserDefinedColours(15) = RGB(0, 0, 255) ;Blue

;Put these user defined colours in colPalette1
colPalette1\PutUserDefinedColours(UserDefinedColours())

Repeat ;{
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      If EventWindow() = #MainWindow
        Quit=#True
     EndIf
     
    Case #PB_Event_Gadget
      Select EventGadget()
        Case #Button1
          colPalette1\ShowPalette(610, 250) ;Co-ords for the palette window are passed as arguments
          Debug "Curently selected colour reference for colPalette1 is: "+Str(colPalette1\GetSelectedColour())
        Case #Button2
          colPalette2\ShowPalette(610,250)
          Debug "Curently selected colour reference for colPalette2 is: "+Str(colPalette2\GetSelectedColour())
        Case #Button3
          Debug #CRLF$ +"User defined colour references for colPalette1 are:"+ #CRLF$
          colPalette1\GetUserDefinedColours(UserDefinedColours())
          For j = 0 To 15
            Debug Str(j)+ " "+ Str(UserDefinedColours(j))
          Next j
          Debug #CRLF$ +"========================================"+ #CRLF$
      EndSelect
      
  EndSelect
Until Quit=#True
colPalette1\Free()
colPalette2\Free();}
Last edited by XCoder on Sat Sep 26, 2020 11:13 am, edited 1 time in total.
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Ultimate colour requestor

Post by Kwai chang caine »

Works apparently here, thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
Mr.L
Enthusiast
Enthusiast
Posts: 104
Joined: Sun Oct 09, 2011 7:39 am

Re: Ultimate colour requestor

Post by Mr.L »

when i press on "show palette 1" or "show palette 2"
I get an IMA in line 251

Code: Select all

ProcedureReturn CallWindowProc_(*This\OriginalProcessButtonMsg(), hwnd, msg, wparam, lparam)
XCoder
User
User
Posts: 68
Joined: Tue Dec 31, 2013 9:18 pm

Re: Ultimate colour requestor

Post by XCoder »

I have updated the code in the first post of this thread to correct an error identified by Mr.L
Post Reply