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
===============================================
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();}