Was so excited over this first attempt that I couldn't wait to post it on the Forum. I was then new to PB. This is a ported version of my even older VisualBasic6 code. Wish you much fun with this. Thanks forum for the error check. I have now adjusted to your suggestions. Code is divided in two posts because of the forums size limit.
Code: Select all
;Welcome to use, improve and share this utility. It gives you more control than the standard PB-colorpicker.
; As you might suspect this code is ported from VisualBasic6.
;Use and improve as you like.
EnableExplicit
;***************** CONSTANTS ****************************************
#WIN_WIDTH=492:#WIN_HEIGHT=352
#LMouseButtonDown=32768
#LMouseButtonUp=0
#iHue=0
#iSaturation=1
#iLumination=2
#SC_EVENT_UpKey=5
#SC_EVENT_DownKey=3
#imgColorBoxesY=28
;*************************************************************************
Structure HSL
;Private Type HSL ;IS USED FOR THE HSL FUNCTION FROM THE WEBSITE VBspeed.
Hue.w; As Integer ;FROM 0 To 360.
Saturation.w; As Byte
Luminance.w; As Byte
EndStructure
;**************************************************************************
; D E F I N I T I O N S
;Define Float thus a number with decimal (4 bytes) similar to Vb6 datatype "Single".
;Define udtAngelSaturationBrightness.HSL
Define lFlagMainWinExist.l, lEvent.l,lEventType.l,lEventMenu.l, lMouse.l,lngColor.l
Dim arLongMarkerColorStore.l(11, 11)
Global.f mSngRValue, mSngGValue, mSngBValue
Global blnDrag.b, bteSaturationMax255.w, bteBrightnessMax255.w
Global intSystemColorAngleMax1530.f
Global mBlnRecentThinBoxPress.b, mBlnBigBoxReady.b, mBlnCursorRoutineReady.b
Global mLngRValue.l, mLngGValue.l, mLngBValue.l, bChosenOptGadget.b
Global mBlnRecentBigBoxPress.b, Xbox.l, Ybox.l
Global Dim arsPicPath.s(0)
Define RGBToHSL.HSL
Global *HSL.HSL = @RGBToHSL
Enumeration
#WinColorPicker
#imgBigBox;ImgGadget
#imgThinBox
#imgTriangel
#imgMarker
#BIGBOX_MEDIA;The picture inside the very image gadget.
#THINBOX_MEDIA
#TriangelBox_MEDIA
#imgMarker_MEDIA
#optH
#optS
#optLuma
#optR
#optG
#optBlue
#optLabL
#optLABa
#optLABb
#optImage
#TextH
#TextS
#TextBright
#TextR
#TextG
#TextBlue
#TextLabL
#TextLABa
#TextLABb
#TextHex
#lblHex
#lblNewColor
#lblOldColor
#lblBorder
#lblPicPath
#Combo1
EndEnumeration
;*******************************************************************
;PB makes no discrimination between procedures versus "functions".
;The compilator has to scan all the code BEFORE it starts to execute the code fore a trial run.
;If this scan encounters a call to a procedure "further down" then it won't recognise it and will interupt and raise an error.
;An exception to this is if you use the command DECLARE SomeCrappyProcedure().
;In that case you can make jumps to code further down the code listing.
Procedure InStrRev(string$,match$)
Define pos.b, a.b
pos=1 : Repeat : a=FindString(string$,match$,pos) : If a<>0 : pos=a+1 : EndIf : Until a=0
ProcedureReturn pos-1
EndProcedure
;===================================================================
Procedure cmdHelp_Click()
Define sAppPath.s, strPathStripC.s, strFusionPath.s, btePosEndLetter.w, sTest.s
Define bteErrCtr.w, strAppPath.s
Define strAPIpath.s, CSIDL_PERSONAL.w;fill pidl with the specified folder item.
;strAPIpath = Space$(260)
;IT IS PROBLEMATIC IF THE APPLICATION IS CONTAINED IN MyDocuments WHICH IS A FAKE FOLDER PATH - THE REAL FOLDER IS CONTAINED SOMEWHERE IN WINDOWS SYSTEM FOLDER.
;ALSO THE FOLDER MyDocuments MAY BE RENAMED BY THE USER. I THINK THERE IS A FOOL PROOF SOLUTION FOR THIS IN THE NEXT GENERATION VB.
;MY DIRTY SOLUTION IS TO FIRST TRUST THE app.path. IN CASE OF ERROR I RETRY WITH THE WINDOWS FOLDER WHICH PATH WE GET FROM THE SPECIAL API ROUTINE.
OnErrorGoto(?ErrorHandler)
strAppPath = GetCurrentDirectory(); App.Path
If InStrRev(strAppPath, "\") <> Len(strAppPath)
strAppPath + "\" ;Good windows-programming-virtue.
EndIf
RunProgram(strAppPath + "ColorpickerHelp\ColorPickerHelp.html")
;Exit
ErrorHandler:
MessageRequester("MsgBox MsgRequester","There was an error while trying to open the helpfile!")
;k = Err.Number Error 53 = File not found.
;MsgBox "Tries to find the helpfile in windows directory. " & Err.Number & Err.Description
bteErrCtr + 1 ;COUNTING THE NUMBER OF TIMES THAT THE shell-funktion HAS FAILED.
strPathStripC = Mid(strAppPath, 4, Len(strAppPath) - 3) ;SHOULD GET EITHER THE PATH My documents\ OR Mina dokument\
Select bteErrCtr
Case 1
;CHECKING THE REAL PATH FOR MYDOCUMENTS
MessageRequester("MsgBox MsgRequester","Failed to find the location for My documents - sending you down to case2! "): bteErrCtr = 2
Case 2
MessageRequester("MsgBox MsgRequester","Failed in finding the helpfile ColorpickerHelp.html which should recide in the same folder as the programme ColorPicker. Would you like to browse for it manually?")
EndSelect
;Call Shell("C:\Test\ColorPickerHelp.html")
;App.Path & "\ColorpickerHelp\ColorPickerHelp.html", 0&, 0&, 0&)
EndProcedure
;=======================================================================================
Procedure MoveHexBox()
Define Ctr.l
;MsgBox "Move HexBox"
For Ctr = 336 To 286 Step -1
;txtHexColor.Move Ctr, 281, 56, 20
StringGadget(#TextHex, Ctr, 281, 56, 19, "A5ECA4", #PB_String_UpperCase)
;Combo1.Move Ctr + 70, 281, 70 + 336 - Ctr ;Height-property in ComboBoxes is readonly.
ComboBoxGadget(#Combo1, Ctr + 70, 281, 70 + 336 - Ctr,200)
Next Ctr
EndProcedure
;=======================================================================================
Procedure.b ExecuteIniFile();Chooses the latest mode of optRadioButton.
Define bteFileHandle.b, Ctr.b, lTempChosenOptGadget.l, lNumberOfPaths.l
Define lColor.l, strFilename.s, Answer.s, Result.l, sFile.s, strAppPath.s, s.s
;Interna bilder to add to combo box:
AddGadgetItem(#Combo1, -1, "Winterlake.jpg");Combo1.AddItem "Winterlake.jpg"
AddGadgetItem(#Combo1, -1, "50;s Colormap.jpg");Combo1.AddItem "50;s Colormap.jpg"
;To remove from a combo box:
;RemoveGadgetItem(#Gadget, Position); Vb6 Combo1.RemoveItem Index (0 based)
;Opens too read from the ini-file of the form.
If OpenPreferences("ColorPicker.prefs") = #False
MessageRequester("Welcome", "Welcome to the ColorPicker you FirstTimeUser!" + Chr(13) + "(If not a FirstTimeUser then the Preferences file was lost. I will try to create a new one!")
EndIf
PreferenceGroup("Window")
lColor = ReadPreferenceLong ("lColor", 0)
SetGadgetColor(#lblOldColor,#PB_Gadget_BackColor,lColor)
lTempChosenOptGadget = ReadPreferenceLong ("lTempChosenOptGadget", #optH)
lNumberOfPaths = ReadPreferenceLong("lNumberOfPaths", 0)
ClosePreferences()
ReDim arsPicPath(lNumberOfPaths)
If lNumberOfPaths = 0
ReDim arsPicPath(1): arsPicPath(1) = "" ;A flag of the save routine.
Else
For Ctr = 1 To lNumberOfPaths
;Line Input #bteFileHandle, arsPicPath(Ctr): arsPicPath(Ctr) = Mid(arsPicPath(Ctr), 2, Len(arsPicPath(Ctr)) - 2) ;Removing the citation marks - the Trim command wasn;t sufficient. Line Input #bteFileHandle, arsPicPath(Ctr): arsPicPath(Ctr) = Mid(arsPicPath(Ctr), 2, Len(arsPicPath(Ctr)) - 2) ;Removing the citation marks - the Trim command wasn;t sufficient.
arsPicPath(ctr)=ReadPreferenceString("arsPicPath"+ Str(Ctr), "Empty")
;Combo1.AddItem Mid(arsPicPath(Ctr), InStrRev(arsPicPath(Ctr), "\") + 1) ;Extracting the file name from the pathen.
s=Mid(arsPicPath(Ctr), InStrRev(arsPicPath(Ctr), "\") + 1)
AddGadgetItem(#Combo1, -1, s);Extracting the file name from the pathen.
Next Ctr
EndIf
ProcedureReturn lTempChosenOptGadget;bChosenOptGadget = lTempChosenOptGadget;There is a number between #optH and #optImage, Vb6 0-9.
SetGadgetState(lTempChosenOptGadget,#True);TEst
EndProcedure
;===================================================================================
Procedure.l HSLToRGB(intLocalColorAngle.l, Saturation.l, Luminance.l, blnUpdateTextBoxes.b); As Long
Define R.l, G.l, B.l, lMax.l, lMid.l, lMin.l, q.f
lMax = Luminance
lMin = (255 - Saturation) * lMax / 255 ;255 - (Saturation * lMax / 255)
q = (lMax - lMin) / 255
Select intLocalColorAngle
Case 0 To 255
lMid = (intLocalColorAngle - 0) * q + lMin
R = lMax: G = lMid: B = lMin
Case 256 To 510 ;This period surpasses the node border with one unit - over to gren color. CHECK by F8.
lMid = -(intLocalColorAngle - 255) * q + lMax ;-(intLocalColorAngle - 256) * q + lMin
R = lMid: G = lMax: B = lMin
Case 511 To 765
lMid = (intLocalColorAngle - 510) * q + lMin
R = lMin: G = lMax: B = lMid
Case 766 To 1020
lMid = -(intLocalColorAngle - 765) * q + lMax
R = lMin: G = lMid: B = lMax
Case 1021 To 1275
lMid = (intLocalColorAngle - 1020) * q + lMin
R = lMid: G = lMin: B = lMax
Case 1276 To 1530
lMid = -(intLocalColorAngle - 1275) * q + lMax
R = lMax: G = lMin: B = lMid
Default
MessageRequester("Msg","Error occured in HSLToRGB. intSystemColorAngleMax1530= " + Str(intLocalColorAngle))
EndSelect
;--- OPTIONAL UPDATE TEXTBOXES ------------------------------------
If blnUpdateTextBoxes = #True ;Then the calling routine is not any of the complex automatic routines for fading etc.
;Since this is a single time called session I can safely update my system constants and convert my hifgh resolution system constants to textbox dito.
mSngRValue = R: mSngGValue = G: mSngBValue = B ;Updating the system variables automatically. Perhaps must exclude this to give them protection.
SetGadgetText(#TextH, Str(Round(intLocalColorAngle / 255 / 6 * 360,#PB_Round_Nearest)));Text1(0) = Round(intLocalColorAngle / 255 / 6 * 360)
SetGadgetText(#TextS,Str(Round(Saturation / 255 * 100,#PB_Round_Nearest)));Text1(1) = Round(Saturation / 255 * 100)
SetGadgetText(#TextBright,Str(Round(Luminance / 255 * 100,#PB_Round_Nearest)));Text1(2) = Round(Luminance / 255 * 100)
SetGadgetText(#TextR,Str(mSngRValue));Text1(3) = mSngRValue
SetGadgetText(#TextG,Str(mSngGValue));Text1(4) = mSngGValue
SetGadgetText(#TextBlue, Str(mSngBValue));Text1(5) = mSngBValue
;txtHexColor = Hex$(mSngRValue * 65536 + mSngGValue * 256 + mSngBValue): txtHexColor.Refresh ;Applies To internetstandard<>VBstandard
If mSngRValue < 16;&H10
;txtHexColor = Right$("00000" & Hex$(mSngRValue * 65536 + mSngGValue * 256 + mSngBValue), 6) ;Padding with zeroletters to the left.
SetGadgetText(#TextHex,Right("00000" + Hex(mSngRValue * 65536 + mSngGValue * 256 + mSngBValue), 6))
Else
;txtHexColor = Hex$(mSngRValue * 65536 + mSngGValue * 256 + mSngBValue)
SetGadgetText(#TextHex,Hex(mSngRValue * 65536 + mSngGValue * 256 + mSngBValue))
EndIf
;txtHexColor.Refresh ;End of the Hexabox routine.
SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,RGB(R,G,B));lblNewColor.BackColor = HSLToRGB
;UPDATING SYSTEM VARIABLES
intSystemColorAngleMax1530 = intLocalColorAngle ;Sometimes there is only a mouse Y coordinate that is delivered from the calling routine.
bteSaturationMax255 = Saturation
bteBrightnessMax255 = Luminance
EndIf
ProcedureReturn RGB(R,G,B);HSLToRGB = RGB(R,G,B) ;Delivers lngColor in VB-format.
EndProcedure
;===================================================================================================
Procedure RGBToHSL201(RGBValue.l, bUpdateTextBoxes.b);, RGBToHSL.HSL); As HSL
Define R.l, G.l, B.l
Define lMax.l, lMin.l, lDiff.l, lSum.l
;Define udtAngelSaturationBrightness.HSL
;Define RGBToHSL.HSL
R = Red(RGBValue)
G = Green(RGBValue)
B = Blue(RGBValue)
If R > G
lMax = R: lMin = G
Else
lMax = G: lMin = R ;Finds the Superior and inferior components.
EndIf
If B > lMax
lMax = B
Else
If B < lMin
lMin = B
EndIf
EndIf
lDiff = lMax - lMin
lSum = lMax + lMin
;Luminance, thus brightness; Adobe photoshop uses the logic that the site VBspeed regards (regarded) As too primitive = superior decides the level of brightness.
*HSL\Luminance = lMax / 255 * 100
;Saturation******
If lMax <> 0;Protecting from the impossible operation of division by zero.
*HSL\Saturation = 100 * lDiff / lMax ;The logic of Adobe Photoshops is this simple.
Else
*HSL\Saturation = 0
EndIf
;Hue ************** R is situated at the angel of 360 or zero degrees; G vid 120 degrees; B vid 240 degrees. intSystemColorAngleMax1530
Define q.f;float.
If lDiff = 0
q = 0
Else
q = 60 / lDiff ;Protecting from the impossible operation of division by zero.
EndIf
Select lMax
Case R
If G < B
*HSL\Hue = 360 + q * (G - B)
intSystemColorAngleMax1530 = (360 + q * (G - B)) * 4.25 ;Converting from degrees to my resolution of detail.
Else
*HSL\Hue = q * (G - B)
intSystemColorAngleMax1530 = (q * (G - B)) * 4.25
EndIf
Case G
*HSL\Hue = 120 + q * (B - R) ; (R - G)
intSystemColorAngleMax1530 = (120 + q * (B - R)) * 4.25
Case B
*HSL\Hue = 240 + q * (R - G)
intSystemColorAngleMax1530 = (240 + q * (R - G)) * 4.25
EndSelect ;The case of B was missing.
;---- OPTIONAL UPDATING TEXTBOXES! -------------------
If bUpdateTextBoxes = #True
;txtHexColor = Hex$(R * 65536 + G * 256 + B): txtHexColor.Refresh ;Applying To internetstandard<>VBstandard
If R < 16;&H10
;txtHexColor = Right$("00000" & Hex$(R * 65536 + G * 256 + B), 6) ;Adds letters of zero to the left which is a necessary so called padding.
SetGadgetText(#TextHex, Right("00000" + Hex(R * 65536 + G * 256 + B), 6))
Else
;txtHexColor = Hex$(R * 65536 + G * 256 + B)
SetGadgetText(#TextHex,Hex(R * 65536 + G * 256 + B))
EndIf
;txtHexColor.Refresh ;End of hexabox routine.
;Text1(0) = Round(intSystemColorAngleMax1530 / 1530 * 360)
SetGadgetText(#TextH,Str(Round((intSystemColorAngleMax1530 / 1530 * 360),#PB_Round_Nearest)))
If lMax = 0
bteSaturationMax255 = 0 ;Protecting from the impossible operation of division by zero.
Else
bteSaturationMax255 = 255 * lDiff / lMax
SetGadgetText(#TextS, Str(*HSL\Saturation)) ;= saturation both 0 To 255 and 0 To 100%.
EndIf
bteBrightnessMax255 = lMax: SetGadgetText(#TextBright, Str(*HSL\Luminance)) ;=Brightness both 0 To 255 and 0 To 100%.
EndIf
EndProcedure
;============================================================================================
Procedure PaintMarker(X.l, Y.l)
Define lColor.l
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
lcolor=Point(X,Y)
StopDrawing()
EndIf
; If bteBrightnessMax255 < 200 Then ;White marker if the surroundings are grey.
; picBigBox.Circle (X, Y), 5, vbWhite
; Exit Sub
; EndIf
;
; If Text1(0) < 26 Or Text1(0) > 200 Then ;Shades of blue.
; If bteSaturationMax255 > 70 Then ; And bteSaturationMax255 < 150 Then ;White marker If the surroundings are grey..
; picBigBox.Circle (X, Y), 5, vbWhite
; Exit Sub
; EndIf
; EndIf
;******* Creating strong contrast color for the circle imgMarker. **************
RGBToHSL201(lcolor,#False);Convert RGB to HSL.
*HSL\Saturation=255;Strong colored marker.
If *HSL\Hue < 180 : *HSL\Hue + 180
Else
*HSL\Hue-180;Inverting the Hue
EndIf
If *HSL\Luminance < 128 : *HSL\Luminance =255
Else
*HSL\Luminance = 0;Strong Contrast
EndIf
lColor=HSLToRGB(*HSL\Hue ,*HSL\Saturation ,*HSL\Luminance ,#False)
If StartDrawing(ImageOutput(#imgMarker_MEDIA))
Circle(5,5,10,lColor)
StopDrawing()
EndIf
ResizeGadget(#imgMarker,X - 5, Y - 5,#PB_Ignore,#PB_Ignore)
EndProcedure
Procedure SplitlblNewColorToRGBboxes() ;Updating the system constants and textboxes regarding to RGB.
mSngRValue = Red(GetGadgetColor(#lblNewColor, #PB_Gadget_BackColor))
SetGadgetText(#TextR, Str(mSngRValue))
mSngGValue = Green(GetGadgetColor(#lblNewColor, #PB_Gadget_BackColor))
SetGadgetText(#TextG, Str(mSngGValue))
mSngBValue = Blue(GetGadgetColor(#lblNewColor, #PB_Gadget_BackColor))
SetGadgetText(#TextBlue, Str(mSngBValue))
EndProcedure
;============================================================================================
Procedure FadeThinBoxToGrey()
Define sng255saturation.f, sngLokalBrightness.f, X.l, Y.l ;, YCtr As Integer
;MessageRequester("","Procedure FadeThinBoxToGrey()");TEst
;*** Starting values *****
sng255saturation = 255: sngLokalBrightness = bteBrightnessMax255
If CreateImage(#THINBOX_MEDIA, 20, 256)
If StartDrawing(ImageOutput(#THINBOX_MEDIA))
For Y = 0 To 255 ;Interesting if there would raise an error, thus a leap directly to EndSub.
;SetPixelV picThinBox.hDC, X, Y, HSLToRGB(ByVal intSystemColorAngleMax1530, ByVal Round(sng255saturation - sng255saturation * Y / 255), ByVal sngLokalBrightness, False)
LineXY(0, Y, 19, Y, HSLToRGB(intSystemColorAngleMax1530, Round(sng255saturation - sng255saturation * Y / 255,#PB_Round_Nearest), sngLokalBrightness, #False))
Next Y ;Because Y gets to big when the loop has finished.
StopDrawing()
ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
Procedure FadeThinBoxToBlack()
Define sngR256delToBlack.f, sngG256delToBlack.f, sngB256delToBlack.f
Define R.f, G.f, B.f, lColor.l, X.l, Y.l, sngLokalSaturation.l,sngLokalBrightness.l
;*** Starting values *****
sngLokalSaturation=bteSaturationMax255: sngLokalBrightness = 255
If CreateImage(#THINBOX_MEDIA, 20, 256)
If StartDrawing(ImageOutput(#THINBOX_MEDIA))
;For X = 0 To 19
lColor=HSLToRGB(intSystemColorAngleMax1530,sngLokalSaturation,sngLokalBrightness,#False) ;Reads the uppermost pixel MAX LIGHT which is to be faded.
R = Red(lColor)
G = Green(lColor)
B = Blue(lColor)
sngR256delToBlack = R / 255 ;Fractions which leads down to black.
sngG256delToBlack = G / 255
sngB256delToBlack = B / 255
;If blnVertical =#True Then R = Ro: G = Go: B = Bo ;If Vertical line then the original color will be reset For a new round.
For Y = 0 To 255
LineXY(0, Y, 19, Y, RGB(R, G, B))
R = R - sngR256delToBlack ;Darkening the shade of one 256th.
G = G - sngG256delToBlack
B = B - sngB256delToBlack
Next Y
StopDrawing()
ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
Procedure RainBowBigbox(blnFadeToGrey, blnFadeToBlack) ;Is used by both radiobutton 1 & 2.
Define Ctr.l, blnUpdateTextBoxes.b, bteK4243.l
Define Saturation.f, Luminance.f
Static intNODE.l, YCtr.l, XCtr.l, intRainbowAngle.l
;MessageRequester("","RainBowBigbox")
;There is no risk for getting dull shades since I use the native principal by adding/subtracting values against at constant FF-component.
;The algoritm gives med decimal values which increases the importance for mathematical models for choosing color, not pic.point.
;XCtr = X
If CreateImage(#BIGBOX_MEDIA, 256, 256)
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
intRainbowAngle = 0 ;Protects the systemcolorangel
If blnFadeToGrey = #True And blnFadeToBlack = #False
Saturation = 255
Luminance = bteBrightnessMax255 ;Starting value fully saturated. Brightness is to be the same for the whole of bigbox.
Else
Saturation = bteSaturationMax255
Luminance = 255 ;Fading from fully bright.
EndIf
;For intRainbowAngle = 0 To 1529
bteK4243 = 42 ;Has to alternate between 42 and 43 pixels per colorfield to make even at 256 pixels.
;For intNODE = 0 To 1275 Step 255
XCtr = 0 ;To255
For YCtr = 0 To 255
Repeat ;X loopen 0 To 255.
;1 Red in in direction towards yellow. Green is counting up.
For Ctr = 1 To bteK4243 ;Has to alternate between 42 and 43 pixels per colorfield to make even at 256 pixels.
If blnFadeToBlack
Luminance = 255 - YCtr ;Round(bteBrightnessMax255 - (bteBrightnessMax255 / 255 * YCtr))
EndIf
If blnFadeToGrey
Saturation = 255 - YCtr ;Round(bteSaturationMax255 - (bteSaturationMax255 / 255 * YCtr))
EndIf
intRainbowAngle = intNODE + ((254 * (Ctr - 1)) / (bteK4243 - 1)) ;Wonderful solution: this logic about going from zero to the full value (here 254) I have been seeking for a long time.
;SetPixelV picBigBox.hDC, XCtr, YCtr, HSLToRGB(ByVal intRainbowAngle, ByVal Saturation, ByVal Luminance, False)
Plot(XCtr, YCtr, HSLToRGB(intRainbowAngle, Saturation, Luminance, #False))
XCtr + 1
Next Ctr ;
If bteK4243 = 43
bteK4243 = 42
Else
bteK4243 = 43
EndIf
intNODE = intNODE + 255 ;Bistabile switch.
Until XCtr > 254
intRainbowAngle = 0 ;Painting the last fully red which lies outside the logic.
;picBigBox.PSet (XCtr, YCtr), HSLToRGB(ByVal intRainbowAngle, ByVal Saturation, ByVal Luminance, blnUpdateTextBoxes)
LineXY(XCtr, YCtr,XCtr, YCtr, HSLToRGB(intRainbowAngle, Saturation, Luminance, blnUpdateTextBoxes))
intNODE = 0: XCtr = 0
Next YCtr
StopDrawing()
ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
Procedure lblComplementaryColor_Click(Index.b)
;If Text1(0) < 180 Then Text1(0) = Text1(0) + 180 Else Text1(0) = Text1(0) - 180
;Call Text1_LostFocus(0) ;Noll stands for Hue.
EndProcedure
;==========================================================================================
Procedure imgArrowsModeDepending()
Define bFailure.b, Y.l
;PROVA ATT PLUSSA Y MED +28. AdjustingJusterar imgArrows depending on current mode.
Select #True
Case GetGadgetState(#optH)
;TriangelMove(255 - (intSystemColorAngleMax1530 / 1530 * 255)) ;Animating the triangel.
Y = 255 - (intSystemColorAngleMax1530 / 1530 * 255)
Case GetGadgetState(#optH+1)
Y=255 - Val(GetGadgetText(#optH+1)) * 2.55;Animating the triangel.
Case GetGadgetState(#optH+2)
Y=255 - Val(GetGadgetText(#optH+2)) * 2.55;Animating the triangel.
Case GetGadgetState(#optH+3)
;TriangelMove(255 - Text1(3)) ;Animating the triangel.
Y=255 - Val(GetGadgetText(#optH+3))
Case GetGadgetState(#optImage)
;linTriang1Vert.Visible = False: linTriang1Rising.Visible = False: linTriang1Falling.Visible = False ;Top = 255 - (Text1(2) * 2.55) + 28 ;Animating the triangel.
ResizeGadget(#imgTriangel,0,0,0,0)
Default
bFailure=#True
MessageRequester("Error","No optionGadget is selected in Procedure picBigBox_Colorize()!")
EndSelect
If bFailure=#False
ResizeGadget(#imgTriangel,#PB_Ignore,Y,#PB_Ignore,#PB_Ignore)
EndIf
EndProcedure
Procedure Bigbox3D()
Define sngLokalSaturation.f, sngLokalBrightness.f, YRADNOLL.l
Define sngR256delToBlack.f, sngG256delToBlack.f, sngB256delToBlack.f
Define R.f, G.f, B.f, lColor.l, Y.l, X.l
;MessageRequester("","Procedure Bigbox3D()");TEst
sngLokalSaturation = 255: sngLokalBrightness = 255 ;There is a need for intense start color.
;********* Firstly a single fade from saturated to grey on the uppermost row.
If CreateImage(#BIGBOX_MEDIA, 256, 256)
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
Circle(0, 0, 19, RGB(35, 158, 70));Test
For X = 0 To 255
;SetPixelV picBigBox.hDC, X, YRADNOLL, HSLToRGB(ByVal intSystemColorAngleMax1530, ByVal Round(sngLokalSaturation * X / 255), ByVal sngLokalBrightness, False)
Plot(X, YRADNOLL, HSLToRGB(intSystemColorAngleMax1530, Round(sngLokalSaturation * X / 255,#PB_Round_Nearest), sngLokalBrightness, #False))
;StopDrawing()
Next X ;Resets Y for a new row.
;********* Here will be an FADE TO BLACK for all columns ********
For X = 255 To 0 Step -1
;If blnVertical =#True Then R = Ro: G = Go: B = Bo ; If line is vertical the reset For a new round.
lColor = Point(X, 0) ;Reading the uppermost pixel which is to be faded.
R = Red(lColor)
G = Green(lColor)
B = Blue(lColor)
sngR256delToBlack = R / 255 ;The fraction blocks which lead down to black.
sngG256delToBlack = G / 255
sngB256delToBlack = B / 255
For Y = 0 To 255 ;Interesting if there would raise an error, thus a leap back to EndSub.
;objAnyPictureBox.PSet (X, Y), RGB(R, G, B)
;SetPixelV picBigBox.hDC, X, Y, RGB(R, G, B) ;Painting with API.
Plot(X, Y, RGB(R, G, B))
R = R - sngR256delToBlack ;Darkening the shade one of a 256:th.
G = G - sngG256delToBlack
B = B - sngB256delToBlack
Next Y
Y - 1 ;Because that Y gets too big when the loop is completed.
Next X
StopDrawing()
ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
;============================================================================================
Procedure opt3RedPaintPicBigBox()
Define R.l, G.l, B.l
;Paint the picBigBox
If CreateImage(#BIGBOX_MEDIA, 256, 256)
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
R = Val(GetGadgetText(#TextR));Text1(3) ;Red
For B = 255 To 0 Step -1
For G = 255 To 0 Step -1 ;Interesting if there is an error, thus a jump directly to EndSub.
;SetPixelV picBigBox.hDC, B, 255 - G, RGB(R, G, B) ;Painting by API.
Plot(B, 255 - G, RGB(R, G, B))
Next G
;G = G - 1 ;Because that G becomes too big when the loop has finishes.
Next B
StopDrawing()
ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
Procedure opt4GreenPaintPicBigBox()
Define R.l, G.l, B.l
;Paint picBigBox
If CreateImage(#BIGBOX_MEDIA, 256, 256)
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
G = Val(GetGadgetText(#TextG));Text1(4) ;Green
For B = 255 To 0 Step -1
For R = 255 To 0 Step -1 ;Interesting if there is an error, thus a jump directly to EndSub.
;SetPixelV picBigBox.hDC, B, 255 - R, RGB(R, G, B) ;Painting by API.
Plot(B, 255 - R, RGB(R, G, B))
Next R
R = R - 1 ;Because that R becomes too big when the loop has finishes.
Next B
StopDrawing()
ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
Procedure opt5BluePaintPicBigBox()
Define R.l, G.l, B.l
;Paint picBigBox
If CreateImage(#BIGBOX_MEDIA, 256, 256)
If StartDrawing(ImageOutput(#BIGBOX_MEDIA))
B = Val(GetGadgetText(#TextBlue));Text1(5) ;Blue
For R = 255 To 0 Step -1
For G = 255 To 0 Step -1 ;Interesting if there is an error, thus a jump directly to EndSub.
;SetPixelV picBigBox.hDC, R, 255 - G, RGB(R, G, B) ;Ritar medelst API.
Plot(R, 255 - G, RGB(R, G, B))
Next G
G = G - 1 ;Because that G becomes too big when the loop has finishes..
Next R
StopDrawing()
ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA))
EndIf
EndIf
EndProcedure
;============================================================================================
;============================================================================================
Procedure picBigBox_Colorize()
Define blnFadeToGrey.b, R,f, G.f, B.f
;If objOption(9) Then Exit Sub ;IN CASE Option(9) THE bigbox SHALL BE LEFT ALONE.
If GetGadgetState(#optImage)=#False;THEN******************
;***** ******** ********** **********
Select #True
Case GetGadgetState(#optH) ;IN CASE Option(0) WE SHALL FETCH a fully saturated version of color AND MAKE A 3-D FADE.;
Bigbox3D() ;NEW VERSION
Case GetGadgetState(#optH+1)
RainBowBigbox(#False, #True) ;FadeToGrey=False & FadeToBlack=True
Case GetGadgetState(#optH+2)
RainBowBigbox(#True, #False) ;FadeToGrey=#True & FadeToBlack=false
Case GetGadgetState(#optH+3)
opt3RedPaintPicBigBox()
Case GetGadgetState(#optH+4)
opt4GreenPaintPicBigBox()
Case GetGadgetState(#optH+5)
opt5BluePaintPicBigBox()
Default
MessageRequester("Error","No optionGadget is selected in Procedure picBigBox_Colorize()!")
EndSelect
EndIf
EndProcedure
;============================================================================================
Procedure Text1To9_LostFocus(Index.l);Text1_LostFocus(Index As Integer)
Define lColor.l, s.s;udtAngelSaturationBrightness As HSL, ;Has to take care of intSystemColorAngleMax1530 0 To 1529.
;If mBlnBigBoxReady = False Then Exit Sub ;Even the computers own enters are giving undesired calls To this routine.
mBlnBigBoxReady = #False ;Gives me fresh coordinates, but only in the RBG-model at this stage.
;blnNotFirstTimeMarker = #False ;-"-
;HAVE TO ADD THE FUNCTIONALITY: img.Pilars position is totally dependent of the actual mode.
Select Index
Case #TextH ;The user adjusted Hue so RGB will be aproximately calculated.
s=GetGadgetText(#TextH)
If Val(s) > 360
MessageRequester ("Colorpicker","An integer between 0 And 360 i required. Closest value inserted!")
s="360"
SetGadgetText(#TextH,s) ;Checking both the precense of decimals and numbers greater than 360.
EndIf
;If Text1(0) < 0 Then MsgBox "An integer between 0 and 360 i required. Closest value inserted!", vbCritical, "Color Picker": Text1(0) = 0 ;Checking both the precense of decimals And numbers greater than 360.
If Val(s) <> Round(Val(s),#PB_Round_Down)
MessageRequester ("Colorpicker","An integer between 0 And 360 i required. Closest value inserted!")
SetGadgetText(#TextH, Str(Round(Val(s),#PB_Round_Down)));Checking both the precense of decimals and numbers greater than 360.
EndIf
lColor = HSLToRGB(ValF(s) / 360 * 255 * 6, bteSaturationMax255, bteBrightnessMax255, #True)
;imgArrows.Top = 255 - (intSystemColorAngleMax1530 / 1530 * 255) + 28 ;Animating imgArrows
Case #TextS ;The user adjusted Saturation so RGB will be aproximately calculated.
s=GetGadgetText(#TextS)
If Val(s) > 100
MessageRequester ("Colorpicker","An integer between 0 And 100 is required. Closest value inserted!")
s="100"
SetGadgetText(#TextS, s);Checking both the precense of decimals and numbers greater than 360.
EndIf
If Val(s) < 0
MessageRequester ("Colorpicker","An integer between 0 And 100 is required. Closest value inserted!")
s="0"
SetGadgetText(#TextS, s) ;Checking both the precense of decimals and numbers greater than 360.
EndIf
lColor = HSLToRGB(intSystemColorAngleMax1530, ValF(s) / 100 * 255, bteBrightnessMax255, #True)
Case #TextBright ;The user adjusted Luminance so RGB will be aproximately calculated.
s=GetGadgetText(#TextBright)
If Val(s) > 100
MessageRequester ("Colorpicker","An integer between 0 And 100 is required. Closest value inserted!")
s="100"
SetGadgetText(#TextBright, s);Checking both the precense of decimals and numbers greater than 360.
EndIf
If Val(s) < 0
MessageRequester ("Colorpicker","An integer between 0 And 100 is required. Closest value inserted!")
s="0"
SetGadgetText(#TextBright, s);Checking both the precense of decimals and numbers greater than 360.
EndIf
lColor = HSLToRGB(intSystemColorAngleMax1530, bteSaturationMax255, ValF(s) / 100 * 255, #True)
EndSelect
;ByVal RGBValue As Long, ByVal blnUpdateTextBoxes As Boolean
If Index >= #TextR And Index <= #TextBlue;The user adjusted RGB so HSL is To be calculated aproximately.
lColor = RGB(Val(GetGadgetText(#TextR)), Val(GetGadgetText(#TextG)), Val(GetGadgetText(#TextBlue)))
;udtAngelSaturationBrightness = RGBToHSL201(lColor, #True)
RGBToHSL201(lColor,#True)
EndIf
;Adjust imgArrows depending on modus.
;If objOption(0) Then imgArrows.Top = 255 - (intSystemColorAngleMax1530 / 1530 * 255) + 28 ;Flyttar imgArrows
;If objOption(1) Then imgArrows.Top = 255 - (Text1(1) * 2.55) + 28 ;Flyttar imgArrows
;If objOption(2) Then imgArrows.Top = 255 - (Text1(2) * 2.55) + 28 ;Flyttar imgArrows
imgArrowsModeDepending()
picBigBox_Colorize();(mSngRValue, mSngGValue, mSngBValue);Redrawing BigBox
EndProcedure
Procedure txtHexColor_LostFocus()
;Dim udtAngelSaturationBrightness As HSL, lngColor As Long ;Must take care of intSystemColorAngleMax1530 0 To 1529.
Define sShift.s ;OBS! Must shift RGB into BGR to fit vb-standard.
sShift = GetGadgetText(#TextHex)
sShift = Mid(sShift, 5) + Mid(sShift, 3, 2) + Mid(sShift, 1, 2) ;Shifting RGB to BGR.
;SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor)
SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,Val("$" + sShift));lblNewColor.BackColor = ("&H" + sShift) ;OBS! Must shift RGB into BGR to fit vb-standard.
SplitlblNewColorToRGBboxes() ;Automatic update of the RGB textboxes.
Text1To9_LostFocus(3) ;Simulating that the user adjusted the RGBtxtboxes->Total update. 3 means that the RedTextbox has been adjusted.
EndProcedure
;==========================================================================================