;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. ;It's still in alpha stage and will be heavily improved the coming weeks. SiggeSvahn who created this program gives it away for free. 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 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 intterupr 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 ;========================================================================================== Procedure opt3RedPaintPicThinBox(G.l, B.l) Define bteX.l, intCtr.l ;Painting picThinBox (19, 255) If CreateImage(#THINBOX_MEDIA, 20, 256) If StartDrawing(ImageOutput(#THINBOX_MEDIA)) For bteX = 0 To 19 For intCtr = 0 To 255 ;SetPixelV picThinBox.hDC, bteX, intCtr, RGB(255 - intCtr, G, B) ;Painting with API. Plot(bteX,intCtr,RGB(255 - intCtr, G, B)) Next intCtr Next bteX StopDrawing() ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA)) EndIf EndIf EndProcedure ;============================================================================================ Procedure opt4GreenPaintPicThinBox(R.l, B.l) Define bteX.l, intCtr.l ;Painting picThinBox (19, 255) If CreateImage(#THINBOX_MEDIA, 20, 256) If StartDrawing(ImageOutput(#THINBOX_MEDIA)) For bteX = 0 To 19 For intCtr = 0 To 255 Plot(bteX, intCtr, RGB(R, 255 - intCtr, B)) Next intCtr Next bteX StopDrawing() ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA)) EndIf EndIf EndProcedure ;============================================================================================ Procedure opt5BluePaintPicThinBox(R.l, G.l) Define bteX.l, intCtr.l ;Painting picThinBox (19, 255) If CreateImage(#THINBOX_MEDIA, 20, 256) If StartDrawing(ImageOutput(#THINBOX_MEDIA)) For bteX = 0 To 19 For intCtr = 0 To 255 Plot(bteX,intCtr,RGB(R, G, 255 - intCtr)) Next intCtr Next bteX StopDrawing() ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA)) EndIf EndIf EndProcedure ;============================================================================================ Procedure BigBoxOpt3Reaction(X.l, Y.l) Define lColor.l;,udtAngelSaturationBrightness.HSL If StartDrawing(ImageOutput(#BIGBOX_MEDIA)) lColor=Point(X,Y) SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor);lblNewColor.BackColor = picBigBox.Point(X, Y): lblNewColor.Refresh SplitlblNewColorToRGBboxes() ;Updating the module global mSngRValue etc. StopDrawing() opt3RedPaintPicThinBox(mSngGValue, mSngBValue) RGBToHSL201(lColor,#True) Else MessageRequester("Error in BigBoxOpt3Reaction", "Failed StartDrawing(ImageOutput(#BIGBOX_MEDIA)") EndIf EndProcedure ;============================================================================================ Procedure BigBoxOpt4Reaction(X.l, Y.l) Define lColor.l If StartDrawing(ImageOutput(#BIGBOX_MEDIA)) lColor=Point(X,Y) SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor);lblNewColor.BackColor = picBigBox.Point(X, Y): lblNewColor.Refresh SplitlblNewColorToRGBboxes() ;Updating the module global mSngRValue etc. StopDrawing() opt4GreenPaintPicThinBox(mSngRValue, mSngBValue) RGBToHSL201(lColor,#True) Else MessageRequester("Error in BigBoxOpt4Reaction", "Failed StartDrawing(ImageOutput(#BIGBOX_MEDIA)") EndIf EndProcedure ;============================================================================================ Procedure BigBoxOpt5Reaction(X.l, Y.l) Define lColor.l If StartDrawing(ImageOutput(#BIGBOX_MEDIA)) lColor=Point(X,Y) SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor);lblNewColor.BackColor = picBigBox.Point(X, Y): lblNewColor.Refresh SplitlblNewColorToRGBboxes() ;Updating the module global mSngRValue etc. StopDrawing() opt5BluePaintPicThinBox(mSngRValue, mSngGValue) RGBToHSL201(lColor,#True) Else MessageRequester("Error in BigBoxOpt5Reaction", "Failed StartDrawing(ImageOutput(#BIGBOX_MEDIA)") EndIf EndProcedure Procedure RainBowThinBox() ;By swapping the XY-vvalues at the call you can paint either horisontal or vertical. Define Ctr.l, blnUpdateTextBoxes.b, bteK4243.l Define blnHorizontal.b, Saturation.l, Luminance.w Static intNODE.l, YCtr.l, XCtr.l, intRainbowAngle.l ;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. ;MessageRequester("","Procedure RainBowThinBox()") intRainbowAngle = 0 ;Protecting systemcolorangel Saturation = 255: Luminance = 255 ;Fully shining colors. ;If blnFadeToGrey =#True And blnFadeToBlack = False Then Saturation = 255: Luminance = bteBrightnessMax255 ;Starting value is full saturation. Brightness is To be the same For the whole bigbox. ;Horizontal or vertical kan be chosen by intKoordSuperior/intKoordInferior. YCtr = 255;: If XCtr = YCtr Then blnHorizontal =#True ;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 ;ImageGadget(#imgThinBox, 284, 31, 20, 256, #PB_Image_Border) If CreateImage(#THINBOX_MEDIA, 20, 256) If StartDrawing(ImageOutput(#THINBOX_MEDIA)) Circle(0, 0, 19, RGB(35, 158, 70));Test ;Vertical Repeat ;Y loopen 255 To 0. ;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. 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. LineXY(0, YCtr, 19, Yctr, HSLToRGB(intRainbowAngle, Saturation, Luminance, blnUpdateTextBoxes)) YCtr = YCtr - 1 Next Ctr ; If bteK4243 = 43 bteK4243 = 42 Else bteK4243 = 43 EndIf intNODE = intNODE + 255 ;Bistabile switch. Until YCtr < 1 intRainbowAngle = 0 ;Painting the last fully red which is outside the logic of the routine. LineXY(0, YCtr, 19, Yctr, HSLToRGB(intRainbowAngle, Saturation, Luminance, blnUpdateTextBoxes)) StopDrawing() intNODE = 0: YCtr = 255 StopDrawing() ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA)) Else MessageRequester("Error","StartDrawing(ImageOutput(#THINBOX_MEDIA))") EndIf Else MessageRequester("Error","CreateImage(#THINBOX_MEDIA, ,20 256)") EndIf EndProcedure ;============================================================================================ Procedure PaintThinBox(Index.b) Define blnFadeToGrey.b, blnFadeToBlack.b Select Index Case #iHue ;MsgBox "Hue" ;Call RainBowSurface(objAnyPictureBox, ,20 blnFadeToGrey, blnFadeToBlack) RainBowThinBox() Case #iSaturation ;MsgBox "Saturation" ;ColorAngle is now horizontal from left To right. Textboxes are important. FadeThinBoxToGrey() Case #iLumination; "Brightness" ;Crucial to give the thin box maximum lightness as a starting point for the lightness fade. ;picThinBox.BackColor = HSLToRGB(ByVal intSystemColorAngleMax1530, ByVal bteSaturationMax255, ByVal 255, False) ;Delivers a lighter shade of the active color. ;Setting the whole square For easy fading. SetGadgetColor(#imgThinBox,#PB_Gadget_BackColor,HSLToRGB(intSystemColorAngleMax1530, bteSaturationMax255, 255, #False)) FadeThinBoxToBlack() EndSelect ;ImageGadget(#imgThinBox, 284, 31, ,20 256, #PB_Image_Border);picThinBox.Visible =#True EndProcedure ;============================================================================================ Procedure objOption_Click(Index.i) ;Choosing modus. Define Ctr.i If Index <> #optImage And GadgetX(#TextHex) = 286 ; Restore HexBox & Combo1. ;lblPicPath.Visible = False: cmdBrowse.Enabled = False: Combo1.Enabled = False TextGadget(#lblPicPath, 0, 0, 0, 1,"") ;MsgBox "Move HexBox" For Ctr = 286 To 336 StringGadget(#TextHex, Ctr, 281, 56, 20,"") ;Combo1.Move Ctr + 70, 281, 70 + 336 - Ctr ;Height-property in ComboBoxes is readonly. ComboBoxGadget(#Combo1, Ctr + 70, 281, 70 + 336 - Ctr,20) Next Ctr ;DoEvents ;Problems with visual jam. EndIf Select Index Case #optH ;MsgBox "Hue" ;picThinBox.Visible =#True PaintThinBox(#iHue) picBigBox_Colorize() Case #optS ;picThinBox.Visible =#True PaintThinBox(#iSaturation) picBigBox_Colorize ();Speciell design. Case #optLuma ; "Brightness" ;MsgBox "Saturation" ;cOLOR ANGEL IS NOW HORIZONTAL FROM LEFT To RIGHT. TEXTBOXES ARE NOW IMPORTANT. ;picThinBox.Visible =#True PaintThinBox(#iLumination) picBigBox_Colorize() ;Speciell design. Case #optR ; "R" opt3RedPaintPicThinBox(Val(GetGadgetText(#TextG)),Val(GetGadgetText(#TextBlue))) ;(Text1(4), Text1(5)) picBigBox_Colorize() ;Special design. Case #optG ; "G" ;Call PaintMarker(mBteMarkerOldX, mBteMarkerOldY) ;Repainting the Marker again (If there is any). opt4GreenPaintPicThinBox(Val(GetGadgetText(#TextR)),Val(GetGadgetText(#TextBlue)));(Text1(3), Text1(5)) picBigBox_Colorize() ;Special design. Case #optBlue ; "B" ;Call PaintMarker(mBteMarkerOldX, mBteMarkerOldY) ;Repainting the Marker again (If there is any). opt5BluePaintPicThinBox(Val(GetGadgetText(#TextR)), Val(GetGadgetText(#TextG))) picBigBox_Colorize() ;Speciell design. Case #optImage ; "PictureBrowse" ;ImageGadget(#imgThinBox, 284, 31, 0, 256, #PB_Image_Border) MessageRequester("Test","Hiding imgThinBox") ;lblPicPath.Visible = #True: cmdBrowse.Enabled =#True: Combo1.Enabled =#True TextGadget(#lblPicPath,13, #WIN_HEIGHT-24, 133, 14, "Path to pictures.") MoveHexBox() Default MessageRequester("Error", "This version does not yet support the OptionGadget nr " + Str(Index) + " but I have no support yet for that one!") EndSelect ;imgArrowsModeDepending() ;MOVING imgArrows EndProcedure ;============================================================================================ Procedure SplitToRGBboxes(): ;ALSO THE SYSTEM CONSTANTS OF RGB GETS UPDATED. Define lC.l lC=GetGadgetColor(#lblNewColor, #PB_Gadget_BackColor) mLngRValue = Red(lC):SetGadgetText(#TextR,Str(mLngRValue)) mLngGValue = Green(lC):SetGadgetText(#TextG,Str(mLngGValue)) mLngBValue = Blue(lC):SetGadgetText(#TextBlue,Str(mLngBValue)) EndProcedure ;============================================================================================ ; PROCEDURE FORM LOAD ; ;*********** ***************** ; Procedure Form_Load() ;***** DEFINITIONS ********************************* Define x.w, y,w, lWinID.l, lC.l,lImgBoxID.l,lTriangelBoxID ;ReDim Preserve arsPicPath(1) ;arsPicPath NEEDS A FIRST INITIALISATION To ENABLE THE USE OF Ubound LATER. Define Ctr.l, bteExtraWidth.l, bteExtraHeight.l ;STYLING THE FORM. STRANGELY FAILED TO SWITCH THE SCALEMODE TO PIXLES. 1 pixel=20 twips. mBlnRecentThinBoxPress = #True ;TO GET RID OF GREY SQUARES IN THE PICTURE. mBlnCursorRoutineReady = #True ;USED TO AVOID RECURSION CAUSING WHITE CIRCLES IN THE BIGBOX. ;************* *********** ;**************** *************** ;****** SKAPAR MainForm ***** frmColorPicker.ScaleMode = vbPixels ;RESEMBLING PIXELS. ;frmColorPicker.Width = 7380 ;frmColorPicker.Height = 5280 lWinID = OpenWindow(#WinColorPicker, 0, 0, #WIN_WIDTH, #WIN_HEIGHT, "ColorPicker Beta by SiggeSvahn") SmartWindowRefresh(#WinColorPicker,#True);Taking care perhaps of some flicker problems when I.m moving gadgets. ; TEST lImgBoxID=CreateImage(#imgBigBox, 255, 255) lImgBoxID=ImageGadget(#imgBigBox,#PB_Ignore,#PB_Ignore, 256, 256,0,#PB_Image_Border) ;*********** Skapar stora imgBoxen *********** If OpenWindow(#WinColorPicker, 0, 0, #WIN_WIDTH, #WIN_HEIGHT, "ColorPicker Beta by SiggeSvahn", #PB_Window_SystemMenu | #PB_Window_ScreenCentered) If CreateImage(#BIGBOX_MEDIA, 256, 256) If StartDrawing(ImageOutput(#BIGBOX_MEDIA)) For x = 0 To 255 For y = 0 To 255 Plot(x, y, RGB(Random(255), Random(255), Random(255))) Next y Next x StopDrawing() ImageGadget(#imgBigBox, 10, 31, 256, 256, ImageID(#BIGBOX_MEDIA)) EndIf EndIf EndIf ;*********** Create #imgMarker ****************** If CreateImage(#imgMarker_MEDIA, 10, 10) If StartDrawing(ImageOutput(#imgMarker_MEDIA)) Circle(10,31,10,RGB(256,256,256)) ImageGadget(#imgMarker, 284, 31, 20, 256, #PB_Image_Border) StopDrawing() EndIf EndIf ;picThinBox.Move 284, 31, 19 + bteExtraWidth, 256 + bteExtraHeight ;FRAMES ARE 4 UNITS BROAD. CURIOSITY FACT IS THAT TEH FRAMES OF ALL VBCONTROLS EXCEPT FOR forms ARE MEASURED FROM THE FRAME CENTER, SO YOU ACTUALLY GET HALF THE WIDTH, BUT IT WORKS SINCE VB USE THE SAME LOGIC ALL THE WAY. ImageGadget(#imgThinBox, 284, 31, 20, 256, #PB_Image_Border) GadgetToolTip(#imgThinBox,"imgThinBox") ;************** T E S T IMAGE of Random Spots ************************ If CreateImage(#THINBOX_MEDIA, 20, 256) If StartDrawing(ImageOutput(#THINBOX_MEDIA)) For x = 0 To 19 For y = 0 To 255 Plot(x, y, RGB(Random(255), Random(255), Random(255))) Next y Next x StopDrawing() ImageGadget(#imgThinBox, 284, 31, 20, 256, ImageID(#THINBOX_MEDIA)) EndIf EndIf ;lblThinContainer.BackStyle = 0 ;Transparent ;lblThinContainer.Left = 284 - 10: lblThinContainer.Top = picThinBox.Top: lblThinContainer.Width = picThinBox.Width + 20: lblThinContainer.Height = picThinBox.Height ;********* Skapar chbPREVIEW ***************** ;chbPreview.Move 13, 299, 103, 15 ;Left,Top,Width,Height. ;chbPreview.Visible = False ;HIDES IT IN THIS BETAVERSION CAUSE IT DOESN;T YET HAVE A PURPOSE. ;imgMarker.Visible = False ;HIDING TO IMPROVE THE LOOKS. ;********* Skapar RadioKnappar *************** For Ctr = 0 To 2 ;objOption(Ctr).Move 320, 120 + Ctr * 25, 33, 17 OptionGadget(#optH+Ctr, 320, 120 + Ctr * 25, 33, 17, Mid("HSL",ctr+1,1)) GadgetToolTip(#optH+Ctr,StringField("Hue, Saturation, Brightness",ctr+1,",")) Next Ctr For Ctr = 3 To 5 ;objOption(Ctr).Move 320, 198 + (Ctr - 3) * 26, 33, 17 OptionGadget(#optH+Ctr, 320, 198 + (Ctr - 3) * 26, 33, 17, Mid("RGB",ctr-2,1)) GadgetToolTip(#optH+Ctr,StringField("Red, Green, Blue",ctr-2,",")) Next Ctr For Ctr = 6 To 8 ;objOption(Ctr).Move 407, 120 + (Ctr - 6) * 25, 25, 17 OptionGadget(#optH+Ctr, 407, 120 + (Ctr - 6) * 25, 25, 17, Mid("Lab",ctr-5,1)) GadgetToolTip(#optH+Ctr,StringField("LabColors L, LabColors a, LabColors b",ctr-5,",")) Next Ctr OptionGadget(#optImage, 413, 205, 55, 17, "Image") GadgetToolTip(#optImage,"Choose color from any picture!") ;***************** Skapar TextBoxar *************** For Ctr = 0 To 2 ;Text1(Ctr).Move 351, 117 + Ctr * 25, 30, 21 StringGadget(#TextH+Ctr, 354, 120 + Ctr * 25, 30, 20,"",#PB_String_Numeric) Next Ctr For Ctr = 3 To 5 ;Text1(Ctr).Move 350, 196 + (Ctr - 3) * 26, 30, 21 StringGadget(#TextH+Ctr, 354, 196 + (Ctr-3) * 26, 30, 20,"",#PB_String_Numeric) Next Ctr For Ctr = 6 To 8 ;Text1(Ctr).Move 437, 117 + (Ctr - 6) * 26, 34, 21 StringGadget(#TextH+Ctr, 437, 117 + (Ctr-6) * 26, 34, 20,"",#PB_String_Numeric) Next Ctr ;************* ************ ************************************ ;txtHexColor.Move 336, 281, 56, 19 StringGadget(#TextHex, 336, 281, 56, 19, "A5ECA4", #PB_String_UpperCase) GadgetToolTip(#TextHex,"Color in hexadecimal format") ;********** Skapar lilla eticketten med brädgårdstecknet! ******** ;Label1.Move 319, 283, 13, 14 ;tecknet # TextGadget(#lblHex, 319, 283, 13, 14, "#") ;********** Skapar lblNewColor respektive lblOldColor samt desras gemensamma container med en vacker ram. **** TextGadget(#lblNewColor, 322, 33, 58, 33,"");lblNewColor.Move 322, 33, 58, 33 SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,$00FFFF) GadgetToolTip(#lblNewColor,"NewColor") TextGadget(#lblOldColor, 322, 66, 58, 33,"");lblOldColor.Move 322, 66, 58, 33 SetGadgetColor(#lblOldColor,#PB_Gadget_BackColor,$000000) GadgetToolTip(#lblOldColor,"OldColor. Click to reset!") ;lblContainer.Move 321, 32, 60, 68 TextGadget(#lblBorder, 321, 32, 60, 68, "TextGadget Border", #PB_Text_Border) ;****lblOldColor.BackColor = lblNewColor.BackColor ;STARTS AT THE SAME COLOR. ; linTriang1Vert.X1 = 277: linTriang1Vert.X2 = 277: linTriang1Vert.Y1 = 251: linTriang1Vert.Y2 = 261 ; linTriang1Rising.X1 = 277: linTriang1Rising.X2 = 283: linTriang1Rising.Y1 = 261: linTriang1Rising.Y2 = 256 ; linTriang1Falling.X1 = 277: linTriang1Falling.X2 = 283: linTriang1Falling.Y1 = 251: linTriang1Falling.Y2 = 256 lTriangelBoxID=ImageGadget(#imgTriangel,270,251, 13, 13,0,#PB_Image_Border) GadgetToolTip(#imgTriangel,"imgTriangel") If CreateImage(#TriangelBox_MEDIA, 13, 13) If StartDrawing(ImageOutput(#TriangelBox_MEDIA)) ;The next 2D drawing commands draw a triangle ;FillArea(27, 27, $FFFFFF, $FFFFFF) LineXY(0, 0, 0, 13, $FFFFFF);Vertikal linje. LineXY(0, 13, 13, 6, $FFFFFF);Stigande linje LineXY(0, 0, 13, 6, $FFFFFF);Fallande linje StopDrawing() ImageGadget(#imgTriangel,270,251, 13, 13, ImageID(#TriangelBox_MEDIA)) EndIf EndIf ; linTriang2Vert.X1 = 314: linTriang2Vert.X2 = 314: linTriang2Vert.Y1 = 251: linTriang2Vert.Y2 = 261 ; linTriang2Rising.X1 = 309: linTriang2Rising.X2 = 314: linTriang2Rising.Y2 = 261: linTriang2Rising.Y1 = 256 ; linTriang2Falling.X1 = 309: linTriang2Falling.X2 = 314: linTriang2Falling.Y2 = 251: linTriang2Falling.Y1 = 256 TextGadget(#lblPicPath,13, #WIN_HEIGHT-24, 133, 14, "Path to pictures.");lblPicPath.Left = 13: lblPicPath.Width = 460 GadgetToolTip(#lblPicPath,"Path to pictures.") ComboBoxGadget(#Combo1, 406, 279, 69, 21,#PB_ComboBox_Editable);, Börja med ICKE #PB_ComboBox_Editable) AddGadgetItem(#Combo1, -1, "ComboBox editable...") GadgetToolTip(#Combo1,"Choose a picture!") ;objOption(0) =#True ;STATES Hue As Default. ***ATT!!!!! THIS BOOTS THE CLICK ROUTINE To DECORATE ThinBox And BigBox. lC=GetGadgetColor(#lblNewColor, #PB_Gadget_BackColor) SplitToRGBboxes();ALSO THE SYSTEM CONSTANTS OF RGB GETS UPDATED. RGBToHSL201(lC, #True) ;TRUE MEANS THAT HSL IS UPDATING BOTH THE textboxes AND THE systemConstants. EndProcedure ;============================================================================================ Procedure picBigBox_MouseMove(X.l, Y.l) ;PROBLEM: GIF-IMAGES ETC WONT REACT WHEN I SAVE THE OLD IMAGE AS A MATRIX. ON THE OTHER HAND I CAN PAINT OVER GIFS. Define lColor.l;, udtAngelSaturationBrightness As HSL If blnDrag = #True;Baile if mousebutton is not held down. If X > 255 X = 255 ;LIMITER. EndIf If X < 0 X = 0 EndIf If Y > 255 Y = 255 EndIf If Y < 0 Y = 0 EndIf Select #True Case GetGadgetState(#optH);objOption(0) lColor = HSLToRGB(intSystemColorAngleMax1530, X, 255 - Y,#True) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optS);objOption(1) lColor = HSLToRGB(X * 6, bteSaturationMax255, 255 - Y,#True): PaintThinBox(#iSaturation) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optLuma);objOption(2) lColor = HSLToRGB(X * 6, 255 - Y, bteBrightnessMax255,#True): PaintThinBox(#iLumination) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optR);objOption(3) BigBoxOpt3Reaction(X, Y) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optG);objOption(4) BigBoxOpt4Reaction(X, Y) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optBlue);objOption(5) BigBoxOpt5Reaction(X, Y) ;CONVERT AND UPDATE TEXTBOXES. Case GetGadgetState(#optImage);objOption(9) lColor=Point(X, Y) SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor) SplitlblNewColorToRGBboxes:RGBToHSL201(lColor,#True);lblNewColor.BackColor = picBigBox.Point(X, Y): SplitlblNewColorToRGBboxes: udtAngelSaturationBrightness = RGBToHSL201(lblNewColor.BackColor,#True) ;True means that HSL uppdates both the textboxes and the system constants. Default MessageRequester("","Error: No optionbutton is selected! in Procedure picBigBox_MouseMove(X.l, Y.l)") EndSelect mBlnRecentThinBoxPress = #False EndIf EndProcedure Procedure picThinBox_MouseMove(X.l, Y.l) Define lColor.l If blnDrag;--------------------------------------------------- ;If Text1(1) = "Saturation" Then Text1(1) = 100 ;The program har been started recently. If Y < 0 Y = 0 ;LIMITER EndIf If Y > 255 Y = 255 EndIf ;imgArrows.Top = Y + 28 ;Animering ResizeGadget(#imgTriangel,#PB_Ignore,Y+#imgColorBoxesY,#PB_Ignore,#PB_Ignore);TriangelMove(Y) ;ANIMATION Select #True Case GetGadgetState(#optH);objOption(0) lColor = HSLToRGB((255 - Y) * 6, bteSaturationMax255, bteBrightnessMax255, #True); Exit Sub ;Convert And update textboxes. Case GetGadgetState(#optS);objOption(1) lColor = HSLToRGB(intSystemColorAngleMax1530, 255 - Y, bteBrightnessMax255, #True); Exit Sub ;Convert and update textboxes. Case GetGadgetState(#optLuma);objOption(2) lColor = HSLToRGB(intSystemColorAngleMax1530, bteSaturationMax255, 255 - Y, #True) ;Convert and update textboxes. Case GetGadgetState(#optR);objOption(3) mSngRValue=(255 - Y) SetGadgetText(#TextR,Str(mSngRValue)) lColor=RGB(mSngRValue,mSngGValue,mSngBValue) RGBToHSL201(lColor,#True);Convert and update textboxes. SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor) Case GetGadgetState(#optG);objOption(4) mSngGValue=(255 - Y) SetGadgetText(#TextG,Str(mSngGValue)) lColor=RGB(mSngRValue,mSngGValue,mSngBValue) RGBToHSL201(lColor,#True);Convert and update textboxes. SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor) Case GetGadgetState(#optBlue);objOption(5) mSngBValue=(255 - Y) SetGadgetText(#TextBlue,Str(mSngBValue)) lColor=RGB(mSngRValue,mSngGValue,mSngBValue) RGBToHSL201(lColor,#True);Convert and update textboxes. SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,lColor) Default MessageRequester("","Error: No optGadget selected!") EndSelect EndIf EndProcedure ;====================================================================== ;============================================================================================ ;************----------------------------***************** ;******* MAIN LOOP - CHECK FOR ALL EVENTS; MOUSECLICKS ETC ;********************************************************** Form_Load() ;ExecuteIniFile(bChosenOptGadget) ;Chooses the latest mode of optRadioButton. bChosenOptGadget=ExecuteIniFile() SetGadgetState(bChosenOptGadget,#True) objOption_Click(bChosenOptGadget);Aktiverar uppritning av imgBoxMedia. ;------------ Create ShortcutKeys! AddKeyboardShortcut(#WinColorPicker,#PB_Shortcut_Up,#SC_EVENT_UpKey) AddKeyboardShortcut(#WinColorPicker,#PB_Shortcut_Down,#SC_EVENT_DownKey) ;Debug GadgetX(#TextR) ;Debug GadgetY(#TextR) If InitMouse() ;If ExamineMouse() Repeat lEvent = WaitWindowEvent() lEventType=EventType() ;SetWindowTitle(#WinColorPicker, Str(GetAsyncKeyState_(#VK_LBUTTON))) Select lEvent Case #PB_Event_Gadget Select EventGadget() Case #lblNewColor MessageRequester("", "Klick!") ;lblOldColor.BackColor = lblNewColor.BackColor SetGadgetColor(#lblOldColor,#PB_Gadget_BackColor,GetGadgetColor(#lblNewColor,#PB_Gadget_BackColor)) mBlnBigBoxReady = #False ;Delivers fresh coordinates, but only in the HSL-model at this stage. ;blnNotFirstTimeMarker = #False ;-"- ;Call Form_Load ;Call SplitlblNewColorToRGBboxes ;Also the system constants RGB are updated. ;udtAngelSaturationBrightness = RGBToHSL201(lblNewColor.BackColor, True) ;True means that HSL is updating both the textboxes and the system constants. RGBToHSL201(GetGadgetColor(#lblNewColor,#PB_Gadget_BackColor),#True) If GetGadgetState(#optImage) =#False ;Skip if postcard view. ;TriangelMove(255 - (intSystemColorAngleMax1530 / 1530 * 255) + 28) ;Animates the triangeln. ResizeGadget(#imgTriangel,#PB_Ignore,255 - (intSystemColorAngleMax1530 / 1530 * 255) + #imgColorBoxesY,#PB_Ignore,#PB_Ignore) picBigBox_Colorize() ;Redraw BigBox EndIf Case #lblOldColor ;MsgBox "Klick!" SetGadgetColor(#lblNewColor,#PB_Gadget_BackColor,GetGadgetColor(#lblOldColor,#PB_Gadget_BackColor)) mBlnBigBoxReady = #False ;Delivers fresh coordinates, but only in the HSL-model at this stage. ;blnNotFirstTimeMarker = False ;-"- ;Call Form_Load ;Call SplitlblNewColorToRGBboxes ;Also the system constants RGB are updated. ;udtAngelSaturationBrightness = RGBToHSL201(lblNewColor.BackColor, True) ;True means that HSL is updating both the textboxes and the system constants. RGBToHSL201(GetGadgetColor(#lblNewColor,#PB_Gadget_BackColor),#True) ;imgArrows.Top = 255 - (intSystemColorAngleMax1530 / 1530 * 255) + 28 ;Animates imgArrows ;TriangelMove(255 - (intSystemColorAngleMax1530 / 1530 * 255) + 28) ;Animates the triangel. ResizeGadget(#imgTriangel,#PB_Ignore,255 - (intSystemColorAngleMax1530 / 1530 * 255) + #imgColorBoxesY,#PB_Ignore,#PB_Ignore) picBigBox_Colorize();Rita om BigBox Case #optH To #optLABb objOption_Click(EventGadget()) ;Debug Str(EventGadget()) ;Debug Str(#optH) Case #TextH To #TextLABb If lEventType=#PB_EventType_Change;Text has been changed. MessageRequester("","TextBox "+ Str(GetActiveGadget()) +" has been changed.") Text1To9_LostFocus(GetActiveGadget()) EndIf Case #Combo1 Debug "Combo1 was pressed." Case #imgBigBox mBlnRecentBigBoxPress = #True blnDrag = #True lEvent = #WM_MOUSEMOVE;Artificial stimulation of lEvent to kickstart the picThinBox_MouseMove. Case #imgThinBox ;Private Sub picThinBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ;Set flag To start drawing mBlnRecentThinBoxPress = #True blnDrag = #True lEvent = #WM_MOUSEMOVE;Artificial stimulation of lEvent to kickstart the picThinBox_MouseMove. EndSelect EndSelect ;---SENSE MOUSE MOVEMENTS ------------- lMouse = GetAsyncKeyState_(#VK_LBUTTON) ;SetWindowTitle(#WinColorPicker, Str(GetAsyncKeyState_(#VK_LBUTTON))) If blnDrag If lMouse <> #LMouseButtonUp;!Testing for MouseDown gives ambigous results. GetAsyncKeyState_(#VK_LBUTTON). If lEvent = #WM_MOUSEMOVE ;*********** #imgThinBox Sense mouse movement! ******************** Select #True Case mBlnRecentThinBoxPress Xbox=WindowMouseX(#WinColorPicker)-GadgetX(#imgThinBox);Homemade boundaries! Ybox=WindowMouseY(#WinColorPicker)-GadgetY(#imgThinBox) picThinBox_MouseMove(Xbox, Ybox) ;REUSING THE UPDATE ROUTINES. ;*********** #imgBigBox Sense mouse movement! ******************** Case mBlnRecentBigBoxPress Xbox=WindowMouseX(#WinColorPicker)-GadgetX(#imgBigBox);Homemade boundaries! Ybox=WindowMouseY(#WinColorPicker)-GadgetY(#imgBigBox) picBigBox_MouseMove(Xbox, Ybox) ;REUSING THE UPDATE ROUTINES. EndSelect ;-- MOUSE BUTTON RELEASED ON SOME GADGET ! ********************* ;--- #imgThinBox Mouse button is released! //////////////////// EndIf Else; lMouse = #LMouseButtonUp. GetAsyncKeyState_(#VK_LBUTTON). ;MessageRequester("","Mouse up. GetAsyncKeyState") blnDrag = #False mBlnRecentBigBoxPress=#False If mBlnRecentThinBoxPress picBigBox_Colorize();Painting BigBox after being idle. mBlnRecentThinBoxPress=#False EndIf EndIf EndIf ;- SENCE KEYPRESS ********************************************** ;SetWindowTitle(#WinColorPicker, Str(EventMenu()));TEst lEventMenu=EventMenu() If lEventMenu= #SC_EVENT_UpKey Or lEventMenu=#SC_EVENT_DownKey ;MessageRequester("", Str(lEventMenu)) Select #True Case GetGadgetState(#optH) ;1530 levels. The triangels are moving every sixth Step And are lying on the byte level of 1530/6. ;RGBtxtboxes tells the nudge level: ;***** NudgeHueValues goes from ZERO to 1536. intSystemColorAngleMax1530 = intSystemColorAngleMax1530 + lEventMenu-4 ;Calculating the new value of intSystemColorAngleMax1530, thus +1 or -1. If intSystemColorAngleMax1530 > 1530;Dirty limiter. intSystemColorAngleMax1530 = 1530 EndIf If intSystemColorAngleMax1530 < 0 intSystemColorAngleMax1530 = 0 EndIf lngColor = HSLToRGB(intSystemColorAngleMax1530, bteSaturationMax255, bteBrightnessMax255, #True) ;lngColor as a function of HSLToRGB. System constants are being updated at the same time. ;TriangelMove(255 - (intSystemColorAngleMax1530 / 1530 * 255));Moving the triangel. SetWindowTitle(#WinColorPicker, "Y = " + Str(255 - ((intSystemColorAngleMax1530 / 1530 * 255))+#imgColorBoxesY));TEst ResizeGadget(#imgTriangel,#PB_Ignore,(255 - (intSystemColorAngleMax1530 / 1530 * 255))+#imgColorBoxesY,#PB_Ignore,#PB_Ignore) picBigBox_Colorize() Case GetGadgetState(#optS);****** MessageRequester("", "Add code For radio1! Probably just writing in textbox Saturation!") Case GetGadgetState(#optLuma) ;***** MessageRequester("", "Add code for radio2!") EndSelect EndIf Until lEvent = #PB_Event_CloseWindow Else MessageRequester("","Failed to InitMouse()") EndIf End ; IDE Options = PureBasic 4.51 (Windows - x86) ; CursorPosition = 24 ; Folding = ------ ; Markers = 333,713,1362 ; EnableXP ; Watchlist = intSystemColorAngleMax1530