'[Code] 'incorporating code from: 'http://www.powerbasic.com/support/pbforums/showthread.php?t=40672 'http://www.powerbasic.com/support/pbforums/newreply.php?do=newreply&p=316512 ' ' *************************************************************** ' This code can be used Royalty Free and Freely Distributed ! ' *************************************************************** ' 'PBWIN 9.01 - WinApi 05/2008 - XP Pro SP3 #Compile Exe #Register None #Dim All ' These are helpful to prevent errors in coding #Debug Display On '<<<<<<<<<<<<<<< Remember to turn off for production code ' #Include "win32api.inc" ' Must come first before other include files ! #Include "InitCtrl.inc" 'for spinners ' Global g_hCDlg, g_hDlg, g_hContainer, g_hDlg_Help As Long Global g_hDlg_Highlight_Color, g_hDlg_fg_Color, g_hDlg_bg_Color, g_Checkbox_Flag, g_Sort_Flag As Long Global g_Display_Hex_or_Decimal, g_Color_Array_Jumps(), g_Jumps_Psn As Long Global g_Start_Prms As String %Start_Sort_Btn_Ids_at = 1000 %Start_g_CheckBox_Ids_at = 5000 %Start_Color_Btn_Ids_at = 6000 'leave plenty room for color buttons %Bottom_Btn_Exit = 10000 %Bottom_Btn_Help = 10001 %Help_Label_Id = 10002 ' ' ******************************************************* ' Spinner stuff Global pnmud As nm_updown Ptr 'pointer to structure used by spinner Global g_Textbox_BG_Color, g_Textbox_FG_Color As Long Global g_Textbox_bg_Name, g_Textbox_fg_Name As String %Id_Textbox_fg_Color_Spinner = 100 %Id_Textbox_bg_Color_Spinner = 102 %Id_Color_Array_Spinner = 104 %Id_Textbox = 106 'keep consistent style wherever spinners used %spinner_style = %ws_child Or _ %ws_visible Or _ %uds_wrap Or _ %uds_arrowkeys ' ' ' ******************************************************* ' ' 'this next included file needed for button colors can be found here: 'http://www.powerbasic.com/support/pbforums/showthread.php?t=38904 #Include "C:\Only_My_Programs\Include Files\ButtonPlus.bas" ' ' ******************************************************* ' Global g_Textbox_fg_Color_Flag, g_Textbox_bg_Flag As Long ', g_Alt_Text_Color_Flag As Long Type Colors_Array Sort_by As String * 60 'way more than needed for sorting Background_Color As Long Display_Name As String * 30 'for display Actual_Name As String * 30 Hex_Name As String * 30 Decimal_Name As String * 30 Order As Long Weight As Long Text_Color As Long r As Byte g As Byte b As Byte End Type Global ColorArray() As Colors_Array ' Type fg_Clors Actual_Name As String * 10 Color_Value As Long End Type Global fg_Tint() As fg_Clors ' Type Program_Flags Exist As String * 5 Stay_Resident As Byte Decimal_Display As Byte Sort_Flag As Byte '1 to 7? Checkbox_Flag As Byte ' End Type Global t_Start_Flags As Program_Flags ' ' ******************************************************* ' Macro Quick_Show Reset l$ For ctr = 1 To UBound(g_Color_Array_Jumps()) l$ = l$ & Chr$(ctr+64) & Using$(" ## # ", ctr, g_Color_Array_Jumps(ctr)) & $CrLf Next ctr ?l$ End Macro ' ' ******************************************************* ' ' Dave Biggs weighting ***************** Function W_CalcDist(Color1 As Long, Color2 As Long) As Long ' Calculate 'ColorDistance' - Match = 0, Max diff = 756 (Black - White) Dim r&, g&, b&, r1&, g1&, b1&, r2&, g2&, b2&, rmean& r1 = GetRValue( Color1) : r2 = GetRValue( Color2) g1 = GetGValue( Color1) : g2 = GetGValue( Color2) b1 = GetBValue( Color1) : b2 = GetBValue( Color2) rmean = (r1 + r2)/2 r = r1 - r2 g = g1 - g2 b = b1 - b2 Function = Sqr(((2+rmean/256)*r*r) + 4*g*g + ((2+(255-rmean)/256)*b*b)) End Function '------------------/CalcDist ' Macro Exit_Names Control Get Check g_hDlg, %Start_g_CheckBox_Ids_at + 13 To Flag If flag = 1 Then 'decimal fg_disp$ = Using$(" #", fg) bg_disp$ = Using$(" #", bg) Else 'not checked so must be Hex fg_disp$ = " &h" & Hex$(fg, 6) bg_disp$ = " &h" & Hex$(bg, 6) End If Reset flag End Macro ' ' ******************************************************* ' ' compute jumps for Spinner Sub Spinner_Jumps_Setup aa_Common_Locals lb =LBound(ColorArray()) ub = UBound(ColorArray()) ' 'l$ = ColorArray(1).Actual_Name'get first name Select Case g_Sort_Flag ' Case 1 'RGB ' Case 2 'BGR Case 3 'Name order 'Jump by Letter ReDim g_Color_Array_Jumps(1 To 26) 'range of possible ascii values For ctr = LB To UB i = Asc(ColorArray(ctr).Actual_Name) - 64 If g_Color_Array_Jumps(i) < 1 Then 'not used yet g_Color_Array_Jumps(i) = ctr End If Next ctr Array Sort g_Color_Array_Jumps(), Descend ' Quick_Show ' 'now resize array Reset ctr1 For ctr = 1 To 26 If g_Color_Array_Jumps(ctr) = 0 Then Exit For 'end of values Incr ctr1 'good val so incr Next ctr ReDim Preserve g_Color_Array_Jumps(1 To ctr1) Array Sort g_Color_Array_Jumps() ' Quick_Show ' Case 4 'Weight order ' Case 5 'decimal value Case 6 'original pre-sorted order ReDim g_Color_Array_Jumps(1 To 100) '100 is more than generated colors For ctr = LB To UB - 1 l$ = ColorArray(ctr).Actual_Name 'easier i = InStr(l$, " ") 'strip number l$ = Left$(l$, i) l1$ = Left$(ColorArray(ctr + 1).Actual_Name, i) If l$ = l1$ Then 'Match Incr Flag If flag = 1 Then 'first match so set Incr ctr1 g_Color_Array_Jumps(ctr1) = ctr End If Else Reset flag End If If l$ = "Aqua" Then Exit For: 'Aqua last of fabricated colors in code (Sub Generate_Colors) Next ctr ReDim Preserve g_Color_Array_Jumps(1 To ctr1) 'no need of higher ' Case Else 'jump by 10% for 1RGB, 2BGR, 4Weight, 5Decimal ReDim g_Color_Array_Jumps(1 To 10) stp = ub \ 10 Reset i For ctr = LB To UB Step stp Incr i If i <= UBound(g_Color_Array_Jumps()) Then 'JIC g_Color_Array_Jumps(i) = ctr End If Next ctr End Select End Sub ' CallBack Function Help_CB_Processor Select Case CB.Msg Case Else End Select End Function ' Sub z_Generate_Data_Lines aa_common_Locals ' 'now get Help file fn$ = "BC_Help.txt" z_Binary_Get 'send fn$, returns flen, fle$ t$ = fle$ z_T_into_Tmp_Array 'send t$ returns tmp$() Open "Data_Lines.txt" For Output As #1 For ctr = LBound(tmp$()) To UBound(tmp$()) 'If Len(tmp$(ctr)) < 3 Then Print #1, "Data " & Chr$(34) & tmp$(ctr) & " " & Chr$(34)'data lines need something 'End If Next ctr End Sub ' 'create new dialog in same place as container with scroll bars 'use a listbox Sub Help aa_common_Locals Local Longest_Line As Long ' PBMD_Fonts_Colors_Setup Style = %WS_POPUP Style = Style Or %DS_MODALFRAME Style = Style Or %WS_CAPTION Style = Style Or %WS_SYSMENU Style = Style Or %DS_CENTER Wd = 500 '600 'same as main ht = 405 l$ = "Button Colors (version 0.000035.6.3) - Oopserational Authenticated Documentation" Dialog New g_hDlg, Space$(12) & l$, _ 0, 0, Wd, ht + 5, Style&, ExStyle& To g_hDlg_Help Dialog Set Color g_hDlg_Help, %Black, g_hDlg_bg_Color ' 'now add lb to put in docs ht = ht - 20 wd = wd - 20 Row = 1 Col = 1 Style = %WS_HSCROLL Style = Style Or %WS_VSCROLL Longest_Line = 90 Local LBx() As String s$ = Space$(Longest_Line + 20) 'need the extra room for some reason Dim LBx(1 To DataCount * 5)'way too many for now For ctr = 1 To DataCount Incr ctr1 'tmp$() t$ = Read$(ctr) LSet s$ = " " 'clear it If Left$(t$, 2) = "c " Then 'center it s1$ = Trim$(Mid$(t$, 3)) i = (Len(s1$) + Longest_Line) \ 2 'find middle Mid$(s$, i) = s1$ LBx(ctr1) = s$ Iterate For End If ' Shorten_it: If Len(t$) > Longest_Line Then i = InStr(-Longest_Line, t$, " ") 'find space If i > 0 Then lbx(ctr1) = Left$(t$, i) t$ = Trim$(Mid$(t$, i + 1)) Incr ctr1 GoTo Shorten_it End If End If LSet s$ = " " & t$ LBx(ctr1) = s$ Next ctr ReDim Preserve lbx(1 To ctr1) ' 'get longest line for listbox extent Reset i, i1 For ctr = LBound(LBx$()) To UBound(LBx$()) i = Len(LBx$(ctr)) If i > i1 Then i1 = i Next ctr i1 = i1 * 7 ' Control Add ListBox, g_hDlg_Help, %Help_Label_Id, LBx(), _ Col, Row, _ wd, ht, _ Style Control Send g_hDlg_Help, %Help_Label_Id, %LB_SETHORIZONTALEXTENT, i1, 0 ' Control Set Color g_hDlg_Help, %Help_Label_Id, g_hDlg_fg_Color, g_hDlg_bg_Color Control Set Font g_hDlg_Help, %Help_Label_Id, hfont12 ' Row = ((N&-1)*15)+2 Dialog Show Modal g_hDlg_Help, Call Help_CB_Processor Exit Sub '******** 'Data "12345678 112345678 212345678 312345678 412345678 52345678 62345678 72345678 82345678 92345678 012345678 " 'Data "c Button Colors (version 0.000035.6.3) " Data " " Data "c Written with PowerBasic Win 9.02 " Data " " Data "c Programming details at: " Data "http://www.powerbasic.com/support/pbforums/showthread.php?p=316986#post316986 " Data " " Data " " Data " When a color is chosen the foreground and background color value(s) are placed in the Clipboard according to the Clipboard setting checkboxes below.) " Data " " Data "c * Exit on Click * " Data " checked - The program terminates as soon as a Color Button is clicked. " Data " " Data "c * Stay Resident * " Data " checked - The program does not terminate when a Color Button is clicked. " Data " " Data "c * Decimal Display * " Data " checked - Values are sent in Decimal format. " Data " " Data "c * Hex Display * " Data " Values are sent in Hex format " Data " " Data "c * Black Standard * " Data " is a textbox where the the selected Color Button is displayed. On either side are bg/fg Up/Down arrows. bg scrolls the background colors. fg scrolls available foreground colors. " Data " " Data "c * Textbox to Clipboard * " Data " When clicked the textbox colors are placed in the Clipboard. " Data " " Data "c * Sort by RGB * " Data " Display the Color Buttons in Red Blue Green color value order. " Data " " Data "c * Sort by BGR * " Data " Display the Color Buttons in Green Blue Red color value order. " Data " " Data "c * Sort by Name * " Data " Display the Color Buttons in Name order. " Data " " Data "c * Hue, Luminescence and Saturation *" Data " Display the Color Buttons by brightness. " Data " " Data "c *** Put in Clipboard: *** " 'Data " " Data " The default is Foreground, Background " Data " " Data "c * Color Name * " Data " Color_Name FG, BG " Data " Ex. Violet 20, &hFFFFFF, & " Data " " Data "c * ButtonPlus coloring functions * " Data " Btn_Set_Face_Color(Dlg, Id, Color) " Data " Btn_Set_Text_Color(Dlg, Id, Color) " Data " " Data "c * Control Set Color * " Data " Control Set Color dlg, Id, fg, bg " Data " (PBWin command) " Data " " Data "c * Dialog Set Color * " Data " Dialog Set Color Dlg, fg, bg " Data " (PBWin command) " Data " " Data "c * Color = bg * " Data " for HTML coding " Data " " Data "c * Value Added * " data "Stays Resident And adds each Button Click To the ClipBoard. " Data " Just something I needed early on. " Data " " Data " " Data " " End Sub ' ' ******************************************************* ' '******** Sub W_OrderByColorWeight() Dim Color1&, Color2&, ColorDistance&, Test&, i&, o&, c&, ub&, ctr& ub = UBound(ColorArray()) Dim SortedArray(1 To ub) As Colors_array Dim NewIndex&, Nearest&, NearestIndex& For ctr = 1 To ub SortedArray(ctr) = ColorArray(ctr) 'dunno if needed Next ctr Color1 = %Black ' %White ' %Red ' %Orange ' %Yellow ' %Green ' %Blue ' %RGB_Indigo ' %RGB_Violet ' NewIndex = 1 Do Nearest = 800 ' Any ColorDistance should be < 756 ! For i = 1 To UBound(ColorArray()) ' Color2 = ColorArray(i).Background_Color ' Compute ColorDistance for each array color start with Black If Color2 <> -1 Then ' Array member not yet copied to sorted array ColorDistance = W_CalcDist(Color1, Color2) ' Test = Min(ColorDistance, Nearest) ' Look for minimum ColorDistance on this pass If Test = ColorDistance Then ' is it new - either closer or equal to previous Nearest = ColorDistance : NearestIndex = i ' Nearest ~ closest color match so far - save array index End If End If Next ' Copy Nearest to sorted array SortedArray(NewIndex).Actual_Name = ColorArray(NearestIndex).Actual_Name SortedArray(NewIndex).Background_Color = ColorArray(NearestIndex).Background_Color Incr NewIndex If NewIndex > UBound(ColorArray()) Then : WinBeep 800,1 : Exit Loop ColorArray(NearestIndex).Background_Color = -1 ' Don't want to 'find' this array member again! Color1 = SortedArray(NewIndex-1).Background_Color ' Start new search w/ Color1 = previous nearest match Loop ''' Dim sData$ ''' Open "Sorted.txt" For Output As #101 ' file for new Data statements ''' For c = 1 To UBound (SortedArray()) ''' sData = "Data " + Extract$(SortedArray(c).Actual_Name, " ") ''' Print #101, sData ", " SortedArray(c).Background_Color ''' Next ''' Close # 101 'now restore ColorArray with weight added For ctr = 1 To ub ' ColorArray(ctr) = Original_Array(ctr) ColorArray(ctr) = SortedArray(ctr) 'ColorArray(ctr).Weight = SortedArray(c).Background_Color Next ctr End Sub '------------------/OrderByColorWeight ' ' ******************************************************* ' ' Macro font6 = Control Set Font g_hDlg, Id, hfont6 Macro font7 = Control Set Font g_hDlg, Id, hfont7 Macro font8 = Control Set Font g_hDlg, Id, hfont8 Macro font10 = Control Set Font g_hDlg, Id, hfont10 Macro font12 = Control Set Font g_hDlg, Id, hfont12 Macro font14 = Control Set Font g_hDlg, Id, hfont14 Macro font16 = Control Set Font g_hDlg, Id, hfont16 '**************** ' ' ******************************************************* ' Function HSB (hHsb As Byte, sHsb As Byte, bHsb As Byte) As Long Function = RGB(hHsb, sHsb, bHsb) End Function ' ' ******************************************************* ' Sub Generate_Colors_Add_Data aa_common_Locals Local Txt_Color As Long ub = UBound(ColorArray()) ctr = DataCount \ 2 '2 per line ReDim Preserve ColorArray(1 To ub + ctr) 'resize to hold data ' Reset ctr1 For ctr = 1 To DataCount Step 2 Incr ctr1: i = ub + ctr1 'for code below l$ = MCase$(Read$(ctr)) Replace "Grey" With "Gray" In l$ dv = Val(Read$(ctr + 1)) s$ = Hex$(dv, 6) 'get R G B r = Val("&h" & Left$(s$, 2)) g = Val("&h" & Mid$(s$, 3, 2)) b = Val("&h" & Right$(s$, 2)) Txt_Color = %Black Select Case dv 'bg color Case 0 To 100, 197379, 328965, 526344, 657930, 855309, 986895, 1184274, _ 1315860, 1513239, 1710618, 1842204, 2039583, 2171169, 2368548, 2500134, _ 2697513, 2829099, 3026478, 3158064, 3355443, 3552822, 3684408, 3881787, _ 4013373, 4210752, 4342338, 4539717, 4671303, 4868682, 5066061, 5197647, _ 5197647, 5395026, 5526612, 5723991, 5855577, 6052956, 6184542, 6381921, _ 6513507, 6710886, 6908265, 7039851, 7237230, 7368816, 7566195, 7697781, _ 8093067, 9141131, 5197615, 9127773, 9125927, 13459258, 9118312, 7346457, _ 6429835, 1710731, 9116245, 13444733, 14822282, 14822282, 9129488, _ 13464600, 15570276, 15624315, 25600, 8388608, 8519755, 9109504, 9136128, _ 9143808, 35653, 17803, 9611, 9611, 139, 13434880, 15597568, 16711680, _ 16774535, 16773255, 16771975, 16770695, 16769415, 16768135, 16766855, _ 16765575, 16764295, 16763015, 16761735, 5382795, 16776960, 16776965, _ 16776970, 16776975 Txt_Color = %White End Select GoSub Assign_It If i => UBound(ColorArray()) Then Exit For 'JIC Next ctr Exit Sub ' Assign_it: 'in sub Generate_Colors_Add_Data ColorArray(i).Order = i ColorArray(i).Sort_by = Using$("#######", i) ColorArray(i).Background_Color = dv ColorArray(i).Text_Color = Txt_Color ColorArray(i).Actual_Name = l$ ColorArray(i).Decimal_Name = Using$("###,###,### ", dv) & l$ ColorArray(i).Display_Name = _ Hex$(r, 2) & " " & Hex$(g, 2) & " " & Hex$(b, 2) & " - " & _ l$ ColorArray(i).Hex_Name = ColorArray(i).Display_Name ColorArray(i).Weight = RGB_to_HSL(r, g, b) Return Data Black, 0 Data Blue Navy, 8388608 Data Blue Dark, 9109504 Data Blue Medium, 13434880 Data Blue 2, 15597568 Data Blue, 16711680 Data Green Dark , 25600 Data blue Deep sky 4, 9136128 Data Green, 32768 Data Teal, 8421376 Data Turquoise 4, 9143808 Data Green 4, 35584 Data green Spring 4, 4557568 Data Cyan 4, 9145088 Data blue Deep sky 3, 13474304 Data blue Deep sky 2, 15643136 Data Blue Sky Deep, 16760576 Data Turquoise 3, 13485312 Data Green 3, 52480 Data green Spring 3, 6737152 Data Cyan 3, 13487360 Data turquoise Dark, 13749760 Data Turquoise 2, 15656192 Data Green 2, 60928 Data green Spring 2, 7794176 Data Cyan 2, 15658496 Data Turquoise 1, 16774400 Data Green Spring, 10156544 Data Green, 65280 Data Green Early Spring, 8388352 Data Cyan, 16776960 Data Grey 1, 197379 Data Grey 2, 328965 Data Grey 3, 526344 Data Grey 4, 657930 Data Grey 5, 855309 Data Grey 6, 986895 Data Grey 7, 1184274 Data Grey 8, 1315860 Data Grey 9, 1513239 Data Grey 10, 1710618 Data Grey 11, 1842204 Data blue Dodger 4, 9129488 Data blue Dodger 3, 13464600 Data Blue Midnight, 7346457 Data blue Dodger 2, 15631900 Data Blue Dodger, 16748574 Data Green Sea Light, 11186720 Data green Forest, 2263842 Data Grey 12, 2039583 Data Grey 13, 2171169 Data Grey 14, 2368548 Data Grey 15, 2500134 Data Grey 16, 2697513 Data Grey 17, 2829099 Data Grey 18, 3026478 Data blue Royal 4, 9125927 Data Green Sea, 5737262 Data grey Dark slate, 5197615 Data Green Lime, 3329330 Data Grey 19, 3158064 Data Grey 20, 3355443 Data Grey 21, 3552822 Data Grey 22, 3684408 Data Grey 23, 3881787 Data Grey 24, 4013373 Data Grey 25, 4210752 Data blue Steel 4, 9135158 Data blue Royal3, 13459258 Data Green Medium Sea, 7451452 Data Turquoise, 13688896 Data Blue Royal, 14772545 Data blue Royal 2, 15625795 Data green Sea 3, 8441155 Data Grey 26, 4342338 Data Grey 27, 4539717 Data Grey 28, 4671303 Data Chartreuse 4, 35653 Data Aquamarine 4, 7637829 Data Blue Steel, 11829830 Data Slateblue 4, 9124935 Data blue Dark slate, 9125192 Data blue Royal 1, 16741960 Data turquoise Medium, 13422920 Data blue Sky 4, 9138250 Data Indigo, 8519755 Data Grey 29, 4868682 Data Grey 30, 5066061 Data Grey 31, 5197647 Data Grey 32, 5395026 Data Grey 33, 5526612 Data Grey 34, 5723991 Data Grey 35, 5855577 Data Grey 36, 6052956 Data green Sea 2, 9760334 Data blue Steel 3, 13472847 Data gray Dark slate 4, 9145170 Data blue Cadet 4, 9143891 Data green Pale 4, 5540692 Data green Sea 1, 10485588 Data Purple 4, 9116245 Data green olive Dark, 3107669 Data blue Steel 2, 15641692 Data purple Medium 4, 9127773 Data Grey 37, 6184542 Data Blue Cadet, 10526303 Data blue sky Light 4, 9141088 Data Grey 38, 6381921 Data Grey 39, 6513507 Data blue Steel 1, 16758883 Data Blue Cornflower, 15570276 Data Grey 40, 6710886 Data turquoise Pale 4, 9145190 Data Chartreuse 3, 52582 Data Aquamarine, 11193702 Data orchid Dark 4, 9118312 Data blue Light 4, 9143144 Data blue Slate 3, 13457769 Data greyDim, 6908265 Data Olive drab 4, 2263913 Data green sea Dark4, 6916969 Data Blue Slate, 13458026 Data Grey 42, 7039851 Data Olive Drab, 2330219 Data gray Slate 4, 9141100 Data blue Sky 3, 13477484 Data Grey 43, 7237230 Data blue steel Light 4, 9141102 Data green olive Dark 4, 4033390 Data Grey 44, 7368816 Data Gray Slate, 9470064 Data Grey 45, 7566195 Data Grey 46, 7697781 Data Chartreuse 2, 61046 Data Aquamarine 2, 13037174 Data Gray Slate Light, 10061943 Data Grey 47, 7895160 Data gray slate Dark 3, 13487481 Data orchid Medium 4, 9123706 Data Grey 48, 8026746 Data cyan Light 4, 9145210 Data blue Cadet 3, 13485434 Data Blue Slate Medium, 15624315 Data green Pale 3, 8179068 Data Green Lawn, 64636 Data Purple 3, 13444733 Data Grey 49, 8224125 Data blue Sky 2, 15646846 Data Grey 50, 8355711 Data Chartreuse, 65407 Data Aquamarine, 13959039 Data Maroon, 128 Data Purple, 8388736 Data Olive, 32896 Data Gray, 8421504 Data Grey 51, 8553090 Data blue Slate 1, 16740227 Data Honeydew 4, 8620931 Data Azure 4, 9145219 Data blue Light slate, 16740484 Data Grey 52, 8750469 Data Grey 53, 8882055 Data Blue Sky, 15453831 Data Blue Sky Light, 16436871 Data blue Sky 1, 16764551 Data purple Medium 3, 13461641 Data Blue violet, 14822282 Data violet Blue, 14822282 Data Grey 54, 9079434 Data Red Dark, 139 Data Magenta Dark, 9109643 Data pink Deep 4, 5245579 Data Firebrick 4, 1710731 Data Maroon 4, 6429835 Data red Violet 4, 5382795 Data Violet red 4, 5382795 Data Brown 4, 2302859 Data Orange red 4, 9611 Data red Orange 4, 9611 Data Tomato 4, 2504331 Data Indian red 4, 3816075 Data pink Hot 4, 6437515 Data Coral 4, 3096203 Data orange Dark 4, 17803 Data Brown Saddle, 1262987 Data Sienna 4, 2508683 Data violet Pale red 4, 6113163 Data red violet Pale 4, 6113163 Data Orchid 4, 8996747 Data Salmon 4, 3755147 Data salmon Light 4, 4347787 Data Orange 4, 23179 Data Tan 4, 2841227 Data pink Light 4, 6643595 Data Pink 4, 7103371 Data goldenrod Dark 4, 550283 Data Plum 4, 9135755 Data Goldenrod 4, 1337739 Data Rosy brown 4, 6908299 Data brown Rosy 4, 6908299 Data Burly wood 4, 5600139 Data wood Burly 4, 5600139 Data Gold 4, 30091 Data Peach puff 4, 6649739 Data white Navajo 4, 6191499 Data Thistle 4, 9141131 Data Bisque 4, 7044491 Data rose Misty 4, 8093067 Data Wheat 4, 6717067 Data goldenrod Light 4, 5013899 Data white Antique 4, 7897995 Data Lavender blush 4, 8815499 Data Khaki 4, 5146251 Data Seashell 4, 8554123 Data Cornsilk 4, 7899275 Data Lemon chiffon 4, 7375243 Data Snow 4, 9013643 Data Yellow 4, 35723 Data yellow Light 4, 8031115 Data Ivory 4, 8620939 Data Grey 55, 9211020 Data blue sky Light3, 13481613 Data gray slate Dark 2, 15658637 Data blue Cadet 2, 15656334 Data Grey 56, 9408399 Data green sea Dark, 9419919 Data Green Light, 9498256 Data Purple 2, 15608977 Data Grey 57, 9539985 Data purple Medium, 14381203 Data violet Dark, 13828244 Data Grey 58, 9737364 Data Grey 59, 9868950 Data turquoise Pale 3, 13487510 Data gray slate Dark 1, 16777111 Data blue Cadet 1, 16774552 Data Green Pale, 10025880 Data orchid Dark, 13382297 Data Grey 60, 10066329 Data orchid Dark 3, 13447834 Data blue Light 3, 13484186 Data Yellow Green, 3329434 Data green Pale 1, 10157978 Data Purple 1, 16724123 Data green sea Dark3, 10210715 Data Grey 61, 10263708 Data Grey 62, 10395294 Data purple Medium 2, 15628703 Data gray Slate 3, 13481631 Data Purple, 15736992 Data Sienna, 2970272 Data Grey 63, 10592673 Data blue steel Light 3, 13481378 Data green olive Dark 3, 5950882 Data Grey 64, 10724259 Data blue sky Light 2, 15651748 Data Brown, 2763429 Data Grey 65, 10921638 Data Grey 66, 11053224 Data Gray Dark, 11119017 Data purple Medium 1, 16745131 Data Grey 67, 11250603 Data Grey 68, 11382189 Data Blue Light, 15128749 Data Green Yellow, 3145645 Data Yellow Green, 3145645 Data turquoise Pale 2, 15658670 Data turquoise Pale, 15658671 Data Maroon, 6303920 Data Grey 69, 11579568 Data Blue Light Steel, 14599344 Data Blue Powder, 15130800 Data blue sky Light 1, 16769712 Data Firebrick, 2237106 Data orchid Dark 2, 15612594 Data blue Light 2, 15654834 Data Grey 70, 11776947 Data Olive drab 2, 3862195 Data orchid Medium 3, 13456052 Data cyan Light 3, 13487540 Data green sea Dark 2, 11857588 Data Grey 71, 11908533 Data goldenrod Dark, 755384 Data Grey 72, 12105912 Data gray Slate 2, 15651769 Data orchid Medium, 13850042 Data Grey 73, 12237498 Data turquoise Pale 1, 16777147 Data Brown Rosy, 9408444 Data blue steel Light 2, 15651516 Data olive green Dark 2, 6876860 Data khaki Dark, 7059389 Data Grey 74, 12434877 Data Grey, 12500670 Data orchid Dark 1, 16727743 Data Grey 75, 12566463 Data blue Light 1, 16773055 Data Silver, 12632256 Data Olive drab 1, 4128704 Data Honeydew 3, 12701121 Data Azure 3, 13487553 Data green sea Dark 1, 12713921 Data Grey 76, 12763842 Data Grey 77, 12895428 Data gray Slate 1, 16769734 Data violet red Medium, 8721863 Data red violet Medium, 8721863 Data Grey 78, 13092807 Data Grey 79, 13224393 Data blue steel Light1, 16769482 Data olive green Dark1, 7405514 Data green olive Dark1, 7405514 Data Grey 80, 13421772 Data Red 3, 205 Data Magenta 3, 13435085 Data pink Deep 3, 7737549 Data Firebrick 3, 2500301 Data Maroon 3, 9447885 Data Violet red 3, 7877325 Data Red Violet 3, 7877325 Data Brown 3, 3355597 Data Orange red 3, 14285 Data Red Orange 3, 14285 Data Tomato, 3755981 Data Tomato red, 3755981 Data Indian red 3, 5592525 Data Coral 3, 4545485 Data Indian red, 6053069 Data pink Hot 3, 9461965 Data orange Dark 3, 26317 Data Chocolate 3, 1926861 Data Sienna 3, 3762381 Data violet red Pale 3, 9005261 Data red violet Pale 3, 9005261 Data Orchid 3, 13199821 Data Salmon 3, 5533901 Data salmon Light 3, 6455757 Data Orange 3, 34253 Data Peru, 4163021 Data pink Light 3, 9800909 Data Pink 3, 10392013 Data goldenrod Dark 3, 824781 Data Plum 3, 13473485 Data Goldenrod 3, 1940429 Data Rosy brown 3, 10197965 Data brown Rosy 3, 10197965 Data Burly wood 3, 8235725 Data wood Burly 3, 8235725 Data Gold 3, 44493 Data Peachpuff 3, 9809869 Data white Navajo 3, 9155533 Data Thistle, 13481421 Data Bisque 3, 10401741 Data rose Misty 3, 11909069 Data Wheat 3, 9878221 Data goldenrod Light 3, 7388877 Data white Antique 3, 11583693 Data Lavender blush 3, 12960205 Data Seashell 3, 12568013 Data Khaki 3, 7587533 Data Cornsilk 3, 11651277 Data Lemon chiffon 3, 10865101 Data Snow 3, 13224397 Data Yellow 3, 52685 Data yellow Light 3, 11849165 Data Ivory 3, 12701133 Data Grey 81, 13619151 Data Violet red, 9445584 Data red Violet, 9445584 Data orchid Medium 2, 15622097 Data Grey 82, 13750737 Data cyan Light 2, 15658705 Data Brown Chocolate, 1993170 Data Chocolate Brown, 1993170 Data Tan, 9221330 Data Gray Light, 13882323 Data Grey 83, 13948116 Data Grey 84, 14079702 Data Thistle, 14204888 Data Grey 85, 14277081 Data Orchid, 14053594 Data Goldenrod, 2139610 Data violet red Pale, 9662683 Data red violet Pale, 9662683 Data Grey 86, 14408667 Data Crimson, 3937500 Data Gainsboro, 14474460 Data Plum, 14524637 Data Burly wood, 8894686 Data wood Burly, 8894686 Data Grey 87, 14606046 Data orchid Medium 1, 16738016 Data Grey 88, 14737632 Data Honeydew 2, 14741216 Data Azure 2, 15658720 Data Cyan Light, 16777184 Data Grey 89, 14935011 Data Grey 90, 15066597 Data Lavender, 16443110 Data Grey 91, 15263976 Data salmon Dark, 8034025 Data Grey 92, 15461355 Data Grey 93, 15592941 Data Red 2, 238 Data Magenta 2, 15597806 Data pink Deep 2, 8983278 Data Firebrick 2, 2895086 Data Maroon 2, 10957038 Data Violet red 2, 9190126 Data red Violet 2, 9190126 Data Brown 2, 3881966 Data Orange red 2, 16622 Data red Orange 2, 16622 Data Tomato 2, 4349166 Data Indian red 2, 6513646 Data Coral 2, 5270254 Data pink Hot 2, 10971886 Data orange Dark 2, 30446 Data Chocolate 2, 2193134 Data Sienna 2, 4356590 Data violet red Pale 2, 10451438 Data red violet Pale 2, 10451438 Data Orchid 2, 15301358 Data Salmon 2, 6456046 Data Violet, 15631086 Data salmon Light 2, 7509486 Data Orange 2, 39662 Data Tan 2, 4823790 Data pink Light 2, 11379438 Data Pink 2, 12102126 Data goldenrod Dark 2, 962030 Data Plum 2, 15642350 Data Goldenrod 2, 2274542 Data Rosy brown 2, 11842798 Data brown Rosy 2, 11842798 Data Burly wood 2, 9553390 Data wood Burly 2, 9553390 Data Gold 2, 51694 Data Peachpuff 2, 11389934 Data white Navajo 2, 10604526 Data Thistle 2, 15651566 Data Bisque 2, 12047854 Data rose Misty 2, 13817326 Data Wheat 2, 11458798 Data goldenrod Light 2, 8576238 Data goldenrod Light, 8576494 Data white Antique 2, 13426670 Data Lavender blush 2, 15065326 Data Seashell 2, 14607854 Data Khaki 2, 8775406 Data Goldenrod Pale, 11200750 Data Cornsilk 2, 13494510 Data Lemon chiffon 2, 12577262 Data Snow 2, 15329774 Data Yellow 2, 61166 Data yellow Light 2, 13758190 Data Ivory 2, 14741230 Data Light Coral, 8421616 Data Khaki, 9234160 Data Grey 94, 15790320 Data blue Alice, 16775408 Data Honeydew, 15794160 Data Azure, 16777200 Data Grey 95, 15921906 Data Brown Sandy, 6333684 Data Wheat, 11788021 Data Beige, 14480885 Data Grey 96, 16119285 Data Mint Cream, 16449525 Data Grey 97, 16250871 Data white Ghost, 16775416 Data Salmon, 7504122 Data white Antique, 14150650 Data white Linen, 15134970 Data Goldenrod Yellow, 13826810 Data Grey 98, 16448250 Data Grey 99, 16579836 Data white Oldlace, 15136253 Data Red, 255 Data Magenta, 16711935 Data pink Deep, 9639167 Data Firebrick 1, 3158271 Data Maroon 1, 11744511 Data Violet red 1, 9846527 Data red Violet 1, 9846527 Data Brown 1, 4210943 Data Orange Red, 17919 Data red Orange, 17919 Data Tomato, 4678655 Data pink Hot, 11823615 Data Indian red 1, 6974207 Data pink Hot 1, 11824895 Data Coral 1, 5665535 Data orange Dark 1, 32767 Data Chocolate 1, 2392063 Data Coral, 5275647 Data Sienna 1, 4686591 Data violet red Pale 1, 11240191 Data red violet Pale 1, 11240191 Data Orchid 1, 16417791 Data orange Dark, 36095 Data Salmon 1, 6917375 Data salmon Light, 8036607 Data Orange, 42495 Data Tan 1, 5219839 Data pink Light 1, 12168959 Data Pink 1, 12957183 Data pink Light, 12695295 Data goldenrod Dark 1, 1030655 Data Plum 1, 16759807 Data Pink, 13353215 Data Goldenrod 1, 2474495 Data Rosy brown 1, 12698111 Data brown rosy 1, 12698111 Data Burly wood 1, 10212351 Data wood Burly 1, 10212351 Data Gold, 55295 Data Peach Puff, 12180223 Data White Navajo, 11394815 Data Thistle 1, 16769535 Data Moccasin, 11920639 Data Bisque, 12903679 Data Misty Rose, 14804223 Data Wheat 1, 12249087 Data Blanched Almond, 13495295 Data goldenrod Light 1, 9170175 Data Papaya Whip, 14020607 Data white Antique 1, 14413823 Data Lavender Blush, 16118015 Data Seashell, 15660543 Data Khaki 1, 9434879 Data Cornsilk, 14481663 Data Lemon Chiffon, 13499135 Data white Floral, 15792895 Data Snow, 16448255 Data white Snow, 16448255 Data Yellow, 65535 Data yellow Light, 14745599 Data Ivory, 15794175 Data White Ivory, 15794175 Data White, 16777215 End Sub ' Sub Generate_Colors aa_common_Locals Local Num_Colors, Doing_Color As Long Local Colr() As String 'name Local Stps() As Long 'Steps in gradient range Local rr(), gg(), bb(), txChg() As Byte 'rgb starting colors Local Txt_Color, tx1(), tx2() As Long 'text colors ' ctr = 100 'Way more than needed 'by putting colors in arrays this way, makes it easy to change presentation order Dim Colr(1 To ctr), Stps(1 To ctr) Dim rr(1 To ctr), gg(1 To ctr), bb(1 To ctr), tx1(1 To ctr), tx2(1 To ctr), txChg(1 To ctr) Reset i 'Violet Indigo Blue Green Yellow Orange Red is rainbow 'Stps() = shades of color : txChg() = point to change text color Incr i: Colr(i) = "Violet" : Stps(i) = 50: rr(i) = 255: gg(i) = 000: bb(i) = 255: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 25 'Magenta Incr i: Colr(i) = "Indigo" : Stps(i) = 50: rr(i) = 070: gg(i) = 000: bb(i) = 255: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 30 'Blue Incr i: Colr(i) = "Blue" : Stps(i) = 50: rr(i) = 000: gg(i) = 000: bb(i) = 255: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 30 'Blue Incr i: Colr(i) = "Green" : Stps(i) = 50: rr(i) = 000: gg(i) = 255: bb(i) = 000: tx1(i) = %Blue : tx2(i) = %Black: txChg(i) = 15 'Green Incr i: Colr(i) = "Yellow" : Stps(i) = 45: rr(i) = 255: gg(i) = 255: bb(i) = 000: tx1(i) = %Green: tx2(i) = %Black: txChg(i) = 25 'Yellow Incr i: Colr(i) = "Orange" : Stps(i) = 50: rr(i) = 255: gg(i) = 125: bb(i) = 000: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 10 'Orange Incr i: Colr(i) = "Red" : Stps(i) = 45: rr(i) = 255: gg(i) = 000: bb(i) = 000: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 10 'Red Incr i: Colr(i) = "Cyan" : Stps(i) = 50: rr(i) = 000: gg(i) = 255: bb(i) = 255: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 5 'Cyan Incr i: Colr(i) = "Black" : Stps(i) = 50: rr(i) = 000: gg(i) = 000: bb(i) = 000: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 33 'Black ' Incr i: Colr(i) = "White" : Stps(i) = 50: rr(i) = 255: gg(i) = 255: bb(i) = 255: tx1(i) = %Black: tx2(i) = %Black: txChg(i) = 33 'White Incr i: Colr(i) = "Purple" : Stps(i) = 50: rr(i) = 135: gg(i) = 000: bb(i) = 255: tx1(i) = %White: tx2(i) = %White: txChg(i) = 25 'Purple Incr i: Colr(i) = "Aqua" : Stps(i) = 50: rr(i) = 000: gg(i) = 255: bb(i) = 200: tx1(i) = %White: tx2(i) = %Black: txChg(i) = 25 'Aqua stp = 5 Num_Colors = i Reset Num_Elements For ctr = 1 To i Num_Elements = Num_Elements + Stps(ctr) Next ctr Dim ColorArray(1 To Num_Elements) As Colors_Array ' Reset i 'used above While Doing_Color < Num_Colors Incr Doing_Color Reset i1 For ctr = 0 To 255 Step stp Incr i1 'step counter If i1 > Stps(Doing_Color) Then Exit For 'enough gradient ' If i = Num_Elements Then Exit For 'JIC array limit reached Incr i ' l$ = Colr(Doing_Color) If rr(Doing_Color) Then r = rr(Doing_Color) Else r = ctr If gg(Doing_Color) Then g = gg(Doing_Color) Else g = ctr If bb(Doing_Color) Then b = bb(Doing_Color) Else b = ctr GoSub Assign_it Next ctr Reset ctr1 'color range ctr for name If i = Num_Elements Then GoTo Done 'JIC array limit reached Wend Done: ub = UBound(ColorArray()) Call Generate_Colors_Add_Data ' ? Str$(UBound(ColorArray())),, Str$(ub) Exit Sub '************** Assign_it: Incr ctr1 dv = RGB(r, g, b) l$ = MCase$(l$) & Using$(" ##", ctr1) '****** If i1 < txChg(Doing_Color) Then Txt_Color = tx1(Doing_Color) Else Txt_Color = tx2(Doing_Color) 'Txt_Color = (Abs(dv - &hFFFFFF)) 'not good 'Txt_Color = RGB(Abs(r - 255), g, Abs(b - 255)) 'opposite? - not so hot anyway 'Txt_Color = RGB( ((R& + 128) Mod 256), ((G& + 128) Mod 256), ((B& + 128) Mod 256) ) 'Not good contrast 'Txt_Color = RGB((Abs(r-255)), (Abs(g-255)), (Abs(g-255)))'contrast goes from good(?) to invisible back to good(?) 'Txt_Color = RGB_to_HSL(r, g, b) 'Contrast mostly poor 'Rtns Hue, Luminescence and Saturation ColorArray(i).Order = i ColorArray(i).Sort_by = Using$("#######", i) ColorArray(i).Background_Color = dv ColorArray(i).Text_Color = Txt_Color ColorArray(i).Actual_Name = l$ ColorArray(i).Decimal_Name = Using$("###,###,### ", dv) & l$ ColorArray(i).Display_Name = _ Hex$(r, 2) & " " & Hex$(g, 2) & " " & Hex$(b, 2) & " - " & _ l$ ColorArray(i).Hex_Name = ColorArray(i).Display_Name ColorArray(i).Weight = RGB_to_HSL(r, g, b) ColorArray(i).r = r ColorArray(i).g = g ColorArray(i).b = b Return End Sub ' ' ******************************************************* ' Function Btn_Set_Face_Color(ddlg As Dword, Id As Long, Btn_Color As Long) As Long ButtonPlus ddlg, Id, %BP_FACE_BLEND, 255 'true color ButtonPlus dDlg, Id, %BP_FACE_COLOR, Btn_Color ' &H008FDF8F End Function ' Function Btn_Set_Text_Color(ddlg As Dword, Id As Long, Btn_Color As Long) As Long ButtonPlus dDlg, Id, %BP_Text_COLOR, Btn_Color ' &H008FDF8F End Function ' Macro AA_common_Locals 'prefix by AA puts at top of F4 (function list) - easy to find Local nm, rx, gx, bx, hx, fn, l, l1, s1, s2, fle, s, t As String Local fg, flag, fnt, bg, rh, bh, gh, ctr1, flen, fnum, ctr, i, i1, dv As Long Local stile, ub, lb, Num_Elements, stp, r, g, b As Long Local bg_disp, fg_disp As String Local Style&, ExStyle& Local ht_temp, wd2,Testing_Flag, n1, clor, Id, Row, Col, N As Long Local ht2, ht1, wd1, wd, ht, Max_ht, n2, Btn_Face_Color, Btn_Text_Color As Long Local tmp(), tmp1() As String ' Local i, clor, wd, ht, Id, n As Long End Macro '' Macro z_T_into_Tmp_Array 'send t$ returns tmp$() ctr = ParseCount(t$, $CrLf) Dim tmp$(ctr) Parse t$, tmp$(), $CrLf End Macro ' Macro z_Binary_Get 'send fn$, returns flen, fle$ fnum = FreeFile Open fn$ For Binary As fnum flen = Lof(fnum) Fle$ = Space$(flen)'create a space to put the file Get fnum,,fle$ 'put the file in the space Close fnum End Macro ' Macro z_Binary_Put 'send fn$, fle$ fnum = FreeFile Open fn$ For Binary As fnum Put fnum,,fle$ 'put the file Close fnum End Macro ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ' ' ******************************************************* ' ' ************************************************************* ' Application Globals Variables (#2) ' ************************************************************* ' ' ' ************************************************************* ' Application Entrance ' ************************************************************* ' Function PBMain Local Count& aa_common_Locals ' ' defaults g_Textbox_fg_Color_Flag = 8 'Black? g_Textbox_bg_Flag = 1 'first Color Button ' g_Sort_Flag = 6 'sort by order g_Checkbox_Flag = 1 'Default fg, bg g_Display_Hex_or_Decimal = 1 ' 0=Hex values in display 1=Decimals 'g_Stay_Resident = 1 ' ClipBoard Reset 'empty when starting ' ' Call Generate_Colors Call Spinner_Jumps_Setup ' Parameters_Start ' PBMain_Display(0) Textbox_Update ' Do Dialog DoEvents To Count& Loop Until Count&=0 End Function ' ' ************************************************************* ' Application Dialogs (#3) ' ************************************************************* ' ' Macro Color_Sort_Buttons For Id = 1 To 10 'more than enough If Id = g_Sort_Flag Then clor = g_hDlg_Highlight_Color 'Gold Else clor = g_hDlg_bg_Color End If Btn_Set_Face_Color(g_hDlg, %Start_Sort_Btn_Ids_at + Id, Clor) Control ReDraw g_hDlg, %Start_Sort_Btn_Ids_at + Id Next Id End Macro ' Macro Color_Checkboxes For Id = 1 To 10 If Id = g_Checkbox_Flag Then 'set in Callback which button to color clor = g_hDlg_Highlight_Color 'Gold Control Set Check g_hDlg, %Start_g_CheckBox_Ids_at + Id, 1 Else clor = g_hDlg_bg_Color Control Set Check g_hDlg, %Start_g_CheckBox_Ids_at + Id, 0 End If Control Set Color g_hDlg, %Start_g_CheckBox_Ids_at + Id, -1, clor Control ReDraw g_hDlg, %Start_g_CheckBox_Ids_at + Id Next Id End Macro ' Function Add_Color_Buttons As Long AA_common_Locals PBMD_Fonts_Colors_Setup ' wd = 130 ht = 12 Style = %BS_Center '%BS_Left 'easier to see sorts during testing than center ' For N&= LBound(ColorArray()) To UBound(ColorArray()) Id = %Start_Color_Btn_Ids_at + N Control Kill g_hContainer&, Id 'case old buttons Row = ((N&-1)*15)+2 l$ = Trim$(ColorArray(n).Display_Name) Control Add Button, g_hContainer&, Id, _ l$, _ 1, Row, _ wd, ht, _ Style, _ Call Button_SubClass_Processor Control Set Font g_hContainer&, Id, hFont12 If Len(l$) > 20 Then Control Set Font g_hContainer&, Id, hFont10 Clor = ColorArray(n).Background_Color If Clor = 0 Then Clor = 1 'Black for ButtonPlus Btn_Set_Face_Color(g_hContainer&, Id, Clor) Clor = ColorArray(n).Text_Color Btn_Set_Text_Color(g_hContainer, Id, Clor) Next N& End Function ' Function Sort_Color_Array() As Long AA_common_Locals For ctr = LBound(ColorArray()) To UBound(ColorArray()) ' l$ = ColorArray(ctr).Actual_Name n = RGB(ColorArray(ctr).Background_Color) hx$ = Hex$(n, 6) rx$ = Left$(hx$, 2) '1st 2 bytes bx$ = Mid$(hx$, 3, 2) 'Middle gx$ = Right$(hx$, 2) 'Last 2 rh = Val("&h" & rx$) gh = Val("&h" & gx$) bh = Val("&h" & bx$) 'hex value sort not good, want decimal value I think ' Select Case g_Sort_Flag Case 1 'RGB ColorArray(ctr).Sort_by = ColorArray(ctr).Hex_Name 'already in hex order ' Case 2 'BGR n1 = Bgr(ColorArray(ctr).b, ColorArray(ctr).g,ColorArray(ctr).r) ColorArray(ctr).Sort_by = Hex$(n1, 6) & ColorArray(ctr).Actual_Name ' ColorArray(ctr).Sort_by = Using$("### ### ### ", _ ' ColorArray(ctr).b, _ ' ColorArray(ctr).g, _ ' ColorArray(ctr).r) & _ ' ColorArray(ctr).Actual_Name ' Case 3 'Name order ColorArray(ctr).Sort_by = l$ ' Case 4 'Weight order ColorArray(ctr).Sort_by = Using$("#########", ColorArray(ctr).Weight) & l$ ' Case 5 'decimal value ColorArray(ctr).Sort_by = Using$("#########", ColorArray(ctr).Background_Color) & l$ ' Case 6 'original pre-sorted order ColorArray(ctr).Sort_by = Using$("#########", ColorArray(ctr).Order) ' Case Else Exit Function End Select ColorArray(ctr).Sort_by = RTrim$(ColorArray(ctr).Sort_by) & " >>> " & ColorArray(ctr).Display_Name 'case of dup values Next ctr ' Array Sort ColorArray() ' Call Spinner_Jumps_Setup ' Call Testing_File("C:\Temp\Data.tst") End Function ' Macro PBMD_Fonts_Colors_Setup Local hfont6, hfont7, hfont8, hfont10, hFont12, hFont14, hfont16 As Dword Font New "Comic Sans MS", 6 To hFont6 Font New "Comic Sans MS", 7 To hFont7 Font New "Comic Sans MS", 8 To hFont8 Font New "Comic Sans MS", 10 To hFont10 Font New "Comic Sans MS", 12 To hFont12 Font New "Comic Sans MS", 14 To hFont14 Font New "Comic Sans MS", 16 To hFont16 Dim fg_Tint(1 To 99) As fg_Clors Reset ctr Incr ctr: fg_Tint(ctr).Actual_Name = "Black ":fg_Tint(ctr).Color_Value = &H000000 Incr ctr: fg_Tint(ctr).Actual_Name = "Blue ":fg_Tint(ctr).Color_Value = &HFF0000 Incr ctr: fg_Tint(ctr).Actual_Name = "Green ":fg_Tint(ctr).Color_Value = &H00FF00 Incr ctr: fg_Tint(ctr).Actual_Name = "Cyan ":fg_Tint(ctr).Color_Value = &HFFFF00 Incr ctr: fg_Tint(ctr).Actual_Name = "Red ":fg_Tint(ctr).Color_Value = &H0000FF Incr ctr: fg_Tint(ctr).Actual_Name = "Magenta ":fg_Tint(ctr).Color_Value = &HFF00FF Incr ctr: fg_Tint(ctr).Actual_Name = "Yellow ":fg_Tint(ctr).Color_Value = &H00FFFF Incr ctr: fg_Tint(ctr).Actual_Name = "White ":fg_Tint(ctr).Color_Value = &HFFFFFF Incr ctr: fg_Tint(ctr).Actual_Name = "Gray ":fg_Tint(ctr).Color_Value = &H808080 Incr ctr: fg_Tint(ctr).Actual_Name = "LtGray ":fg_Tint(ctr).Color_Value = &HC0C0C0 ReDim Preserve fg_Tint(1 To ctr) ' g_Alt_Text_Color_Flag = 1 End Macro ' ' Sub z_Testing_File(tf As String)' As Long AA_common_Locals Open tf$ For Output As #1 pf Space$(5);"Sort_by "; Space$(4); ">>> Name "; Space$(5); Time$;" " ; Date$; " "; Select Case g_Sort_Flag Case 1: pf "RGB Order" Case 5: pf "BGR Order" Case 2: pf "Name Order" Case 3: pf "Weight Order" Case 4: pf "Original Order" Case 6: pf "Decimal Order" End Select ' For ctr = LBound(ColorArray()) To UBound(ColorArray()) pf Using$("### ", ctr); ColorArray(ctr).Sort_by; '_ '" --- "; ColorArray(ctr).Display_Name; If ctr > 1 Then ' If ColorArray(ctr).Sort_by = ColorArray(ctr - 1).Sort_by Then If ColorArray(ctr).Background_Color = ColorArray(ctr - 1).Background_Color Then Incr ctr1 'count them pf " Duplicate"; End If End If pf " " 'line feed Next ctr pf " " pf , Using$("#, Duplicates", ctr1) Close #1 End Sub ' ' ******************************************************* ' Function Textbox_Update As Long aa_Common_locals ' s$ = g_Textbox_bg_Name$ & $CrLf & g_Textbox_fg_Name$ ' s$ = g_Start_Prms$ & $CrLf & "Testing" Id = %Id_Textbox Control Set Text g_hDlg, Id, s$ Control Set Color g_hDlg, Id, g_Textbox_FG_Color, g_Textbox_BG_Color Control ReDraw g_hDlg, Id ' Id = %Start_Sort_Btn_Ids_at + 7'Use Text colors button Btn_Set_Face_Color(g_hDlg, Id, g_hDlg_Highlight_Color) Control ReDraw g_hDlg, Id End Function ' Macro PBMD_02_Bottom_Buttons wd2 = (wd1 ) - 5 Control Add Button, g_hDlg, %Bottom_Btn_Help, _ "Invaluable Incredible Articulate Witty Unnecessary Instructions", _ 10 , ht2 - 4, wd2, 8 'Control Add Button, g_hDlg, %Bottom_Btn_Exit, "Exit", 10 + wd2 + 10, ht2 - 4, wd2, 8 Id = %Bottom_Btn_Help :Control Set Font g_hDlg, Id, hfont8: Btn_Set_Text_Color(g_hdlg, Id, 16711680): Btn_Set_Face_Color(g_hdlg, Id, 13172515) ' Id = %Bottom_Btn_Exit :Control Set Font g_hDlg, Id, hfont8: Btn_Set_Text_Color(g_hdlg, Id, 65535): Btn_Set_Face_Color(g_hdlg, Id, 10845695) End Macro ' Macro PBMD_01_Dialog_Create Style = %WS_POPUP Style = Style Or %DS_MODALFRAME Style = Style Or %WS_CAPTION Style = Style Or %WS_MINIMIZEBOX ' Style = Style Or %WS_SYSMENU Style = Style Or %DS_CENTER ExStyle& = 0 Wd = 265 Wd1 = wd - 20 ht = 405 ht2 = ht 'hold for later Dialog New hParent&, Space$(12) & "Color Buttons v 0.0000000000002.5.9", _ 0, 0, Wd, ht + 5, Style&, ExStyle& To g_hDlg& Dialog Set Color g_hDlg, %Black, g_hDlg_bg_Color End Macro ' Macro PBMD_03_Container_Create wd = 135'Wd - 30'140 ht = ht - 30'20 Max_ht = 16 * UBound(ColorArray())' ' g_hContainer& = x_CreateScrollContainer(g_hDlg&, 10, 20, wd, ht, Max_ht) wd = 140 ht = 12 Dialog Set Color g_hContainer&, %Black, %White End Macro ' Macro PBMD_06_Exit_or_Resident Row = Row + ht + 2 ht = 12 Ctr = 11: s$ = "Exit on Click": GoSub Add_Checkbox Control Set Check g_hDlg, Id, 1 'default Control Set Color g_hDlg, Id, -1, g_hDlg_Highlight_Color Ctr = 12: s$ = "Stay Resident": GoSub Add_Checkbox Ctr = 13: s$ = "Decimal Display": GoSub Add_Checkbox Ctr = 14: s$ = "Hex Display": GoSub Add_Checkbox End Macro ' Macro PBMD_07_Text_Spinners Id = %Id_Textbox_fg_Color_Spinner Control Add $updown_class, g_hDlg, Id, "", col + wd - 1, row + (ht \ 2), wd, ht + 2, %spinner_style Control Add Label, g_hDlg, Id + 1, " fg", col + wd - 1, row + (ht \ 2) - 12, 9, 12 Control Set Color g_hDlg, Id + 1, -1, g_hDlg_bg_Color Id = %Id_Textbox_bg_Color_Spinner Control Add $updown_class, g_hDlg, Id, "", col - 3 , row + (ht \ 2), wd, ht, %spinner_style Control Add Label, g_hDlg, Id + 1, "bg", col -3, row + (ht \ 2) - 12, 9, 12 Control Set Color g_hDlg, Id + 1, -1, g_hDlg_bg_Color ' g_Textbox_bg_Name$ = "Standard" g_Textbox_fg_Name$ = "Black" s$ = g_Textbox_fg_Name$ & $CrLf & g_Textbox_bg_Name$ ' 'hDlg&, 10, 20, Id = %Id_Color_Array_Spinner Control Add $updown_class, g_hDlg, Id, "", 0 , 20, wd, ht, %spinner_style stile = %ss_center Or %SS_NOTIFY Control Add Label, g_hDlg, %Id_Textbox, s$, col + 8, Row, Wd - 9, ht + ht + 4, stile Control Set Font g_hDlg, %Id_Textbox, hfont12 g_Textbox_BG_Color = g_hDlg_bg_Color g_Textbox_FG_Color = %Black Control Set Color g_hDlg, %Id_Textbox, g_Textbox_FG_Color, g_Textbox_BG_Color Control ReDraw g_hDlg, %Id_Textbox ' Row = Row + ht + 2'extra size on tb's End Macro ' Macro PBMD_04_Color_to_Clipboard Col = 10 Row = 1 ht1 = 16 fnt = hfont16 s$ = "Click Color to Clipboard" Id = %Start_Color_Btn_Ids_at GoSub Add_Label End Macro ' Macro PBMD_05_Colors_Available Row = 17 Col = Wd + 25 'beside container Wd = 90 ht = 20 wd1 = wd fnt = hfont16 s$ = Using$("#, Colors", UBound(ColorArray())): Id = %Start_g_CheckBox_Ids_at - 1:GoSub Add_Label End Macro ' Macro PBMD_08_Sort_Buttons 'processed in PBMain_CB_Processor Row = Row + ht + 4 ht = 16 '%Start_Sort_Btn_Ids_at ctr = 7: s$ = "Textbox to Clipboard": GoSub Add_Option_Button: font10 ctr = 1: s$ = "Sort by RGB": GoSub Add_Option_Button ctr = 2: s$ = "Sort by BGR": GoSub Add_Option_Button ctr = 3: s$ = "Sort by Name" : GoSub Add_Option_Button ctr = 4: s$ = "Hue, Luminescence, Saturation": GoSub Add_Option_Button: font7 ctr = 5: s$ = "Sort by Decimal": GoSub Add_Option_Button ctr = 6: s$ = "Sort by Order": GoSub Add_Option_Button Color_Sort_Buttons End Macro ' Macro PBMD_09_ClipBoard 'by PBMain_CB_Processor wd1 = wd fnt = hfont12 Row = Row + 4 s$ = "Put in Clipboard:": Id = %Start_g_CheckBox_Ids_at - 2:GoSub Add_Label ht_temp = ht 'save to restore when done here ' ht = ht -2 Row = Row + ht' + 2 ctr = 1: s$ = "Default fg, bg": GoSub Add_Checkbox Control Set Check g_hDlg, Id, 1 'default ' ctr = 2: s$ = "Hex Value": GoSub Add_Checkbox ctr = 3: s$ = "Name & Values": GoSub Add_Checkbox ctr = 7: s$ = "Button Plus": GoSub Add_Checkbox': font10 ctr = 4: s$ = "Control Set": GoSub Add_Checkbox': font8 ctr = 5: s$ = "Dialog Set": GoSub Add_Checkbox': font8 ctr = 6: s$ = "Color =" & Chr$(34) & "Hex" & Chr$(34): GoSub Add_Checkbox ctr = 8: s$ = ", Value (added)": GoSub Add_Checkbox Color_Checkboxes ht = ht_temp 'restore case use after this End Macro ' Sub PBMain_Display(ByVal hParent&) AA_common_Locals 'PBMD_ = macros belonging to PBMain_Display (though may be used elsewhere) to reduce clutter PBMD_Fonts_Colors_Setup g_hDlg_bg_Color = 16766935 g_hDlg_fg_Color = %Black g_hDlg_Highlight_Color = 55295 'gold ' PBMD_01_Dialog_Create ' PBMD_02_Bottom_Buttons ' PBMD_03_Container_Create ' PBMD_04_Color_to_Clipboard 'Label ' Add_Color_Buttons'color buttons in container ' PBMD_05_Colors_Available ' PBMD_06_Exit_or_Resident ' Hex(13) /Decimal display ' PBMd_07_Text_Spinners 'Textbox colors ' PBMD_08_Sort_Buttons ' ' Row = Row + ht + 4 ' PBMD_09_ClipBoard ' ' Decimal_Display_UnSet 'Start with Hex display ' ' Exit_Box_Unset 'stay resident at start ' ' Color_Sort_Buttons ' Parameters_Beginning 'Set according to saved values ' Dialog Show Modeless g_hContainer& , Call Container_CB_Processor Dialog Show Modeless g_hDlg& , Call PBMain_CB_Processor Exit Sub '*********** Add_Label: Control Add Label, g_hDlg, Id, s$, col, Row, wd1, ht1, %ss_Center Control Set Font g_hDlg, Id, Fnt Control Set Color g_hDlg, Id, -1, g_hDlg_bg_Color '&hcbc0ff Return ' Add_Checkbox: Id = %Start_g_CheckBox_Ids_at + ctr Control Add CheckBox, g_hDlg, Id, _ s$, _ Col, Row, _ Wd, ht, _ %SS_Center, _ Call PBMain_CB_Processor Control Set Font g_hDlg, Id, hFont12 Control Set Color g_hDlg, Id, -1, g_hDlg_bg_Color Row = Row + ht + 2 Return ' Add_Option_Button: Id = %Start_Sort_Btn_Ids_at + ctr Control Add Button, g_hDlg, Id, _ s$, _ Col, Row, _ Wd, ht, _ %SS_Center, _ Call PBMain_CB_Processor Control Set Font g_hDlg, Id, hFont12 Row = Row + ht + 3 Return ' End Sub ' ************************************************************* ' Dialog Callback Procedures ' ************************************************************* ' CallBack Function Container_CB_Processor Select Case CB.Msg Case Else End Select End Function ' ' ------------------------------------------------ CallBack Function Button_SubClass_Processor '%Start_g_CheckBox_Ids_at aa_common_Locals If CB.CtlMsg=%BN_CLICKED Then Id = CB.Ctl - %Start_Color_Btn_Ids_at bg = ColorArray(Id).Background_Color fg = ColorArray(Id).Text_Color nm$ = Trim$(ColorArray(Id).Actual_Name) & " " ' Exit_Names 'color button clicked so set spinner bg g_Textbox_bg_Name$ = nm$ g_Textbox_fg_Name$ = fg_Disp$ g_Textbox_BG_Color = bg g_Textbox_fG_Color = fg 'g_Button_Flag = 1 Textbox_Update ' ' If g_Checkbox_Flag = 1 Then 'decimal ' fg_disp$ = Using$(" #", fg) ' bg_disp$ = Using$(" #", bg) ' Else 'not checked so must be Hex ' fg_disp$ = " &h" & Hex$(fg, 6) ' bg_disp$ = " &h" & Hex$(bg, 6) ' End If ' Select Case g_Checkbox_Flag 'what to put in clipboard Case 1, 2: CB_Default Case 3: CB_Name_Values Case 4: CB_Control_Set Case 5: CB_Dialog_Set Case 6: CB_Color_Equals Case 7: CB_Button_Plus Case 10: CB_Clipboard: Incr flag End Select ClipBoard Set Text s$ Control Get Check g_hDlg, %Start_g_CheckBox_Ids_at + 11 To i 'if 0 then resident checked so don't end 'If flag = 0 And i = 1 Then Dialog End g_hDlg If i = 1 Then Parameters_Save_At_Exit Dialog End g_hDlg End If End If End Function ' ------------------------------------------------ ' ' Macro Update_Color_Button_fg_Colors For ctr = LBound(ColorArray()) To UBound(ColorArray()) ColorArray(ctr).Text_Color = fg_Tint(g_Textbox_fg_Color_Flag).Color_Value Next ctr End Macro ' Macro Update_Container Sort_Color_Array Color_Sort_Buttons Add_Color_Buttons Dialog ReDraw g_hContainer End Macro ' Macro Exit_Box_Unset Id = %Start_g_CheckBox_Ids_at + 11 Control Set Check g_hDlg, Id, 0 'unset set exit box Control Set Color g_hDlg, Id, -1, g_hDlg_bg_Color Control ReDraw g_hDlg, Id Id = %Start_g_CheckBox_Ids_at + 12 Control Set Check g_hDlg, Id, 1 'unset set exit box Control Set Color g_hDlg, Id, -1, g_hDlg_Highlight_Color Control ReDraw g_hDlg, Id End Macro ' Macro Exit_Box_Set Id = %Start_g_CheckBox_Ids_at + 11 Control Set Check g_hDlg, Id, 1 'set set exit box Control Set Color g_hDlg, Id, -1, g_hDlg_Highlight_Color Control ReDraw g_hDlg, Id Id = %Start_g_CheckBox_Ids_at + 12 Control Set Check g_hDlg, Id, 0 'Unset resident box Control Set Color g_hDlg, Id, -1, g_hDlg_Bg_Color Control ReDraw g_hDlg, Id End Macro ' Macro Decimal_Display_Set Id = %Start_g_CheckBox_Ids_at + 13 Control Set Check g_hDlg, Id, 1 'set Control Set Color g_hDlg, Id, -1, g_hDlg_Highlight_Color Control ReDraw g_hDlg, Id Id = %Start_g_CheckBox_Ids_at + 14 Control Set Check g_hDlg, Id, 0 'Unset Control Set Color g_hDlg, Id, -1, g_hDlg_Bg_Color Control ReDraw g_hDlg, Id g_Display_Hex_or_Decimal = 1 Call Display_Name_Reset End Macro ' Macro Decimal_Display_UnSet Id = %Start_g_CheckBox_Ids_at + 13 Control Set Check g_hDlg, Id, 0 'unset Control Set Color g_hDlg, Id, -1, g_hDlg_bg_Color Control ReDraw g_hDlg, Id Id = %Start_g_CheckBox_Ids_at + 14 Control Set Check g_hDlg, Id, 1 'unset Control Set Color g_hDlg, Id, -1, g_hDlg_Highlight_Color Control ReDraw g_hDlg, Id g_Display_Hex_or_Decimal = 0 Call Display_Name_Reset End Macro ' Sub Display_Name_Reset aa_common_Locals For i = LBound(ColorArray()) To UBound(ColorArray()) If g_Display_Hex_or_Decimal = 1 Then ColorArray(i).Display_Name = ColorArray(i).Decimal_Name Else ColorArray(i).Display_Name = ColorArray(i).Hex_Name End If Next i Add_Color_Buttons 'redisplay End Sub ' '********* Macro CB_Clipboard ClipBoard Get Text To s1$ s$ = s1$ & Str$(bg) & ", " End Macro ' Macro CB_Color_Equals = s$ = " Color=" & Chr$(34) & "#" & Hex$(bg, 6) & Chr$(34) & " " ' Macro CB_Default = s$ = fg_Disp$ & ", " & bg_Disp$ ' Macro CB_Button_Plus s$ = " Btn_Set_Text_Color(dlg, Id," & fg_disp$ & "):" & _ " Btn_Set_Face_Color(dlg, Id," & bg_disp$ & "): " End Macro ' Macro CB_Name_Values s$ = Trim$(g_Textbox_bg_Name$) & _ " fg = " & Str$(fg) & _ " bg = " & Str$(bg) End Macro ' Macro CB_Dialog_Set s$ = "Dialog Set Color Dlg, " & _ "&h" & Hex$(fg) & ", " & _ "&h" & Hex$(bg) End Macro ' Macro CB_Control_set s$ = "Control Set Color Dlg, Id," & _ fg_disp$ & ", " & _ bg_disp$ End Macro ' ' ******************************************************* ' ' CallBack Function PBMain_CB_Processor aa_common_locals ' Local Id, ctr, clor As Long Static Last_Sort_Flag As Long Select Case CB.Msg Case %WM_syscommand Call Parameters_Save_At_Exit Dialog End CB.Hndl ' Case %Wm_notify 'for spinners Select Case CB.CtlMsg Case %BN_CLICKED, %STN_CLICKED pnmud = CB.lParam Id = CB.Ctl Select Case Id Case %Id_Textbox_fg_Color_Spinner 'right side If @pnmud.hdr.Code = %udn_deltapos Then '+1 or -1 g_Textbox_fg_Color_Flag = g_Textbox_fg_Color_Flag + @pnmud.idelta ub = UBound(fg_Tint()) lb = LBound(fg_Tint()) If g_Textbox_fg_Color_Flag < lb Then g_Textbox_fg_Color_Flag = ub If g_Textbox_fg_Color_Flag > ub Then g_Textbox_fg_Color_Flag = lb Id = g_Textbox_fg_Color_Flag g_Textbox_FG_Color = fg_Tint(Id).Color_Value g_Textbox_fg_Name$ = Trim$(fg_Tint(Id).Actual_Name) & " fg" Textbox_Update Exit_Box_Unset Control Set Color CB.Hndl, %Start_g_CheckBox_Ids_at + 12, -1, g_hDlg_Highlight_Color End If ' Case %Id_Textbox_bg_Color_Spinner 'left side If @pnmud.hdr.Code = %udn_deltapos Then '+1 or -1 g_Textbox_bg_Flag = g_Textbox_bg_Flag + @pnmud.idelta ub = UBound(ColorArray()) lb = LBound(ColorArray()) If g_Textbox_bg_Flag < lb Then g_Textbox_bg_Flag = ub If g_Textbox_bg_Flag > ub Then g_Textbox_bg_Flag = lb Id = g_Textbox_bg_Flag g_Textbox_bg_Color = ColorArray(Id).Background_Color g_Textbox_bg_Name$ = Trim$(ColorArray(Id).Actual_Name) & " bg" Textbox_Update Exit_Box_Unset Control Set Color CB.Hndl, %Start_g_CheckBox_Ids_at + 12, -1, g_hDlg_Highlight_Color End If ' Case %Id_Color_Array_Spinner 'Jumps 'g_Color_Array_Jumps(), g_Jumps_Psn If @pnmud.hdr.Code = %udn_deltapos Then '+1 or -1 g_Jumps_Psn = g_Jumps_Psn + @pnmud.idelta ub = UBound(g_Color_Array_Jumps()) lb = LBound(g_Color_Array_Jumps()) If g_Jumps_Psn < lb Then g_Jumps_Psn = lb If g_Jumps_Psn > ub Then g_Jumps_Psn = ub Id = g_Jumps_Psn n = g_Color_Array_Jumps(Id) Row = ((N - 1) * 15) + 2 'from container setup - row width 'g_Textbox_bg_Name$ = "Id" & Str$(Id) & $CrLf & "Row" & Str$(row) 'Textbox_Update 'just while testing ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Local Scri As SCROLLINFO, OldPos&, NewPos&, hChildDlg& Scri.cbSize=(SizeOf(Scri)) Scri.fMask=%SIF_ALL OldPos&=GetScrollInfo(g_hCDlg, %SB_VERT, Scri) 'cbhndl = g_hCDlg OldPos&=Scri.nPos 'now set newpos scri.npos = Row If Scri.nPosScri.nMax Then Scri.nPos=Scri.nMax If Scri.nPos<>OldPos& Then Scri.cbSize=(SizeOf(Scri)) Scri.fMask=%SIF_POS Scri.nPos=Scri.nPos NewPos&=SetScrollInfo(g_hCDlg,%SB_VERT,Scri, %TRUE) NewPos&=-NewPos& Dialog Get User g_hCDlg, 1 To hChildDlg& Dialog Set Loc hChildDlg&, 0, NewPos& End If ' Dialog Post g_hDlg, %WM_VSCROLL, 0, 0 'now tell it to scroll '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' End If End Select End Select ' Case %WM_COMMAND 'This processes command messages Select Case CB.Ctl - %Start_Sort_Btn_Ids_at Last_Sort_Flag = g_Sort_Flag Case 1, 2, 3, 4, 5, 6 'sort by Select Case CB.CtlMsg Case %BN_CLICKED g_Sort_Flag = CB.Ctl - %Start_Sort_Btn_Ids_at End Select Update_Container ' Case 7 'use textbox colors and exit Select Case CB.CtlMsg Case %BN_CLICKED fg = g_Textbox_FG_Color bg = g_Textbox_BG_Color exit_Names Select Case g_Checkbox_Flag Case 1, 2: CB_Default Case 3: CB_Name_Values Case 4: CB_Control_Set Case 5: CB_Dialog_Set Case 6: CB_Color_Equals Case 7: CB_Button_Plus Case 10: CB_Clipboard: Exit_Box_Unset End Select ClipBoard Set Text s$ Control Get Check g_hDlg, %Start_g_CheckBox_Ids_at + 11 To i 'if 0 then resident checked so don't end If i Then Parameters_Save_At_Exit Dialog End g_hDlg End If End Select ' End Select ' Select Case CB.Ctl - %Start_g_CheckBox_Ids_at Id = CB.Ctl - %Start_g_CheckBox_Ids_at Case 1 To 10 g_Checkbox_Flag = Id Color_Checkboxes ' Case 11 'Exit on choice Control Get Check CB.Hndl, CB.Ctl To Flag Select Case flag Case 0: Exit_Box_Set Case 1: Exit_Box_UnSet End Select Case 12 'stay resident Control Get Check CB.Hndl, CB.Ctl To Flag Select Case flag Case 0: Exit_Box_UnSet Case 1: Exit_Box_Set End Select ' Case 13 'Decimal Display Control Get Check CB.Hndl, CB.Ctl To Flag Select Case flag Case 0: Decimal_Display_Set Case 1: Decimal_Display_UnSet End Select ' Case 14 'Hex Display Control Get Check CB.Hndl, CB.Ctl To Flag Select Case flag Case 1: Decimal_Display_Set Case 0: Decimal_Display_UnSet End Select End Select ' Select Case CB.Ctl Case %Id_Textbox If CB.CtlMsg = %STN_CLICKED Then Exit_Box_Unset Case %Bottom_Btn_Help Call Help End Select End Select End Function ' ------------------------------------------------ ' Macro pf = Print #1, ' Sub z_Get_Colors_From_File AA_common_Locals fn$ = CurDir$ & "\Color.inc" z_Binary_Get 'send fn$, returns flen, fle$ t$ = fle$ z_T_into_Tmp_Array 'send t$ returns tmp$() Close Open "c:\Temp\Color.Data" For Output As #1 For ctr = LBound(tmp$()) To UBound(tmp$()) If InStr(tmp$(ctr), "=") = 0 Then Iterate For 'not line we want t$ = tmp$(ctr) 'easier i = InStr(t$, "%") If i = 0 Then Iterate For 'bum line t$ = Mid$(t$, i + 1) 'strip "%" i = InStr(t$, " =") If i = 0 Then Iterate For 'bum line s$ = Left$(t$, i - 1) 'name t$ = Mid$(t$, i + 3) 'get value n = Val(t$) 'make decimal pf "Data " & s$ & ", " & Str$(n) Next ctr ? "done",, FuncName$ End Sub ' ************************************************************* ' Scrollable Container ' ************************************************************* ' Function x_CreateScrollContainer(ByVal hParent&, ByVal X&, ByVal Y&, ByVal W&, ByVal H&, ByVal MaxH&) As Long Local OffsetW&, OffsetH&, hRealCDlg& OffsetW&=(2*GetSystemMetrics(%SM_CXEDGE))+GetSystemMetrics(%SM_CXVSCROLL) OffsetH&=(2*GetSystemMetrics(%SM_CXEDGE)) Dialog Pixels hParent&, OffsetW&, OffsetH& To Units OffsetW&, OffsetH& Dialog New hParent&, "", X&, Y&, W&+OffsetW&, H&+OffsetH&, _ %WS_CHILD Or %WS_VSCROLL, %WS_EX_CLIENTEDGE Or %WS_EX_CONTROLPARENT To g_hCDlg& Local S As SCROLLINFO S.cbSize=(SizeOf(S)) S.fMask=%SIF_ALL S.nPos=0 S.nPage= 15 * 24 ' set page skip value here S.nMin=0 S.nMax=MaxH&-H& SetScrollInfo(g_hCDlg&,%SB_VERT,S, %TRUE) Dialog New g_hCDlg&, "", 0,0, W&, MaxH&, %WS_CHILD, %WS_EX_CONTROLPARENT To hRealCDlg& Dialog Set Color hRealCDlg&, %Black, %White ' do dialog show in calling code Dialog Show Modeless g_hCDlg& , Call Container_DLGPROC Dialog Set User g_hCDlg&, 1, hRealCDlg& ' store child handle Function=hRealCDlg& End Function ' CallBack Function Container_DLGPROC Select Case CbMsg Case %WM_VSCROLL Local S As SCROLLINFO, OldPos&, NewPos&, hChildDlg& S.cbSize=(SizeOf(S)) S.fMask=%SIF_ALL OldPos&=GetScrollInfo(g_hCDlg, %SB_VERT, S) 'cbhndl = g_hCDlg OldPos&=S.nPos Select Case LoWrd(CbWParam) Case %SB_LINEDOWN S.nPos=S.nPos+15 Case %SB_LINEUP S.nPos=S.nPos-15 Case %SB_PAGEDOWN S.nPos=S.nPos+S.nPage Case %SB_PAGEUP S.nPos=S.nPos-S.nPage Case %SB_THUMBPOSITION S.nPos=S.nTrackPos Case %SB_THUMBTRACK S.nPos=S.nTrackPos Case Else End Select If S.nPosS.nMax Then S.nPos=S.nMax If S.nPos<>OldPos& Then S.cbSize=(SizeOf(S)) S.fMask=%SIF_POS S.nPos=S.nPos NewPos&=SetScrollInfo(CbHndl,%SB_VERT,S, %TRUE) NewPos&=-NewPos& Dialog Get User g_hCDlg, 1 To hChildDlg& 'cbhndl = g_hCDlg Dialog Set Loc hChildDlg&, 0, NewPos& End If Case Else End Select End Function ' ' ******************************************************* ' ' Get the inverse of a color by splitting it ' into r,g,b components and subtracting each from 255 (for text on labels) Function Color_Inverse(hColor As Long) As Long Local r,g,b As Byte r=255-GetRValue(hColor) g=255-GetGValue(hColor) b=255-GetBValue(hColor) Function=RGB(r,g,b) ' < MOD ''''''''''' End Function ''''''''''' '------------------/ ''''''''''' 'DB code ''''''''''' ' Modifications for more consistantly readable text: ''''''''''' Local rh,gh,bh As Byte ''''''''''' Local rDiff, gDiff, bDiff As Byte ''''''''''' Local cBrightness, cDiff, cbDiff As Long ''''''''''' rh=GetRValue(hColor) : gh=GetGValue(hColor) : bh=GetBValue(hColor) ''''''''''' ''''''''''' ' calc color difference (between color and (inversed) text) > 500 is 'good' ? ''''''''''' rDiff = Max(r, rh) - Min(r, rh) ''''''''''' gDiff = Max(g, gh) - Min(g, gh) ''''''''''' bDiff = Max(b, bh) - Min(b, bh) ''''''''''' cDiff = rDiff + gDiff + bDiff ''''''''''' ''''''''''' cBrightness = (rh*299 + gh*587 + bh*114)/1000 ' brightness of the color ''''''''''' ''''''''''' ' calc color brightness difference (between text and color) > 125 is 'good' ? ''''''''''' cbDiff = Max((r*299 + g*587 + b*114)/1000, (rh*299 + gh*587 + bh*114)/1000) - _ ''''''''''' Min((r*299 + g*587 + b*114)/1000, (rh*299 + gh*587 + bh*114)/1000) ''''''''''' ''''''''''' If cDiff > 500 And cbDiff > 125 Then ' in test list of 543 colors - ''''''''''' Function=RGB(r,g,b) ' ~ 139 inverse colors are 'ok' ''''''''''' ElseIf cBrightness > 125 Then ''''''''''' Function=RGB(0,0,0) ' ~ 241 better set to black ''''''''''' Else ''''''''''' Function=RGB(255,255,255) ' ~ 163 better set to white ''''''''''' End If End Function ' < /MOD '------------------/ColorInverse ' ' ******************************************************* ' ' ' from http://www.powerbasic.com/support/pbforums/showthread.php?t=13027&highlight=HSL+RGB 'Trevor Ridley Sub y_HSLtoRGB(ByVal Hue As Integer, _ ByVal Saturation As Integer, _ ByVal Luminance As Integer, _ ByRef RGBRed As Integer, _ ByRef RGBGreen As Integer, _ ByRef RGBBlue As Integer) Dim pHue As Single Dim pSat As Single Dim pLum As Single Dim pRed As Single Dim pGreen As Single Dim pBlue As Single Dim temp2 As Single Dim temp3() As Single Dim temp1 As Single Dim n As Integer ReDim temp3(0 To 2) pHue = Hue / 255 pSat = Saturation / 255 pLum = Luminance / 255 If pSat = 0 Then pRed = pLum pGreen = pLum pBlue = pLum Else If pLum < 0.5 Then temp2 = pLum * (1 + pSat) Else temp2 = pLum + pSat - pLum * pSat End If temp1 = 2 * pLum - temp2 temp3(0) = pHue + 1 / 3 temp3(1) = pHue temp3(2) = pHue - 1 / 3 For n = 0 To 2 If temp3(n) < 0 Then temp3(n) = temp3(n) + 1 If temp3(n) > 1 Then temp3(n) = temp3(n) - 1 If 6 * temp3(n) < 1 Then temp3(n) = temp1 + (temp2 - temp1) * 6 * temp3(n) Else If 2 * temp3(n) < 1 Then temp3(n) = temp2 Else If 3 * temp3(n%) < 2 Then temp3(n%) = temp1 + (temp2 - temp1) _ * ((2 / 3) - temp3(n%)) * 6 Else temp3(n%) = temp1 End If End If End If Next n% pRed = temp3(0) pGreen = temp3(1) pBlue = temp3(2) End If RGBRed = Int(pRed * 255) RGBGreen = Int(pGreen * 255) RGBBlue = Int(pBlue * 255) End Sub ' ' ******************************************************* ' 'http://www.powerbasic.com/support/pbforums/showthread.php?t=25002&highlight=HSL 'Bruce Warner ' %HSLMAX = 255 ' H, S and L values can be 0 - HSLMAX. 240 matches what is ' used by MS Win; any number less than 1 byte is OK; ' works best if it is evenly divisible by 6 %RGBMAX = 255 ' R, G, and B value can be 0 - RGBMAX %UNDEFINED = 0 ' Hue is undefined if Saturation = 0 (greyscale) Type RGBtype Red As Long Grn As Long Blu As Long End Type Type HSLtype Hue As Long ' Hue Sat As Long ' Saturation Lum As Long ' Luminance End Type ' Function RGB_to_HSL(r&, g&, b&) As Long ' Rtns Hue, Luminescence and Saturation Dim cMax As Long, cMin As Long Dim RDelta As Double, GDelta As Double, BDelta As Double Dim H As Double, S As Double, L As Double Dim cMinus As Long, cPlus As Long cMax = Max( r&, g&, b&) ' Highest color value cMin = Min( r&, g&, b&) ' Lowest color value cMinus = cMax - cMin ' Used to simplify the cPlus = cMax + cMin ' calculations somewhat. L = ((cPlus * %HSLMAX) + %RGBMAX) / (2 * %RGBMAX) ' Calc Luminance (lightness) If cMax = cMin Then ' achromatic (r=g=b, greyscale) S = 0 ' Saturation 0 for greyscale H = %UNDEFINED ' Hue undefined for greyscale Else If L <= (%HSLMAX / 2) Then ' Calculate color saturation S = ((cMinus * %HSLMAX) + 0.5) / cPlus Else S = ((cMinus * %HSLMAX) + 0.5) / (2 * %RGBMAX - cPlus) End If RDelta = (((cMax - r&) * (%HSLMAX / 6)) + 0.5) / cMinus ' Calculate hue GDelta = (((cMax - g&) * (%HSLMAX / 6)) + 0.5) / cMinus BDelta = (((cMax - b&) * (%HSLMAX / 6)) + 0.5) / cMinus Select Case cMax Case CLng(r&) H = BDelta - GDelta Case CLng(g&) H = (%HSLMAX / 3) + RDelta - BDelta Case CLng(b&) H = ((2 * %HSLMAX) / 3) + GDelta - RDelta End Select If H < 0 Then H = H + %HSLMAX End If 'gHSL.Hue = CLng(H) 'gHSL.Lum = CLng(L) 'gHSL.Sat = CLng(S) Function = RGB(h, l, s) '(h * h * h) + (l * l) + s '? End Function ' RGB to HSL ' ' ******************************************************* ' Function Parameters_Start As Long ' Exit Function aa_common_locals ' fn$ = Exe.NameX$ '"Color_Buttons.Exe" z_Binary_Get 'send fn$, returns flen, fle$ 'file closed ' i = Len(t_Start_Flags) s$ = Right$(fle$, i) 'Mid$(fle$, flen - i) ' t_Start_Flags.Exist = s$ If InStr(s$, "Swede") = 0 Then 'not Set yet ' New_Parms$ = Right$(" Swede" & "1110010000", Len(prm)) t_Start_Flags.Exist = "Swede" t_Start_Flags.Stay_Resident = 1 t_Start_Flags.Decimal_Display = 1 t_Start_Flags.Sort_Flag = 6 'order sort t_Start_Flags.Checkbox_Flag = 1 'default values used ? s$ & "xxx",,"Setting up first time" 'Exit Function s$ = "Swede1161" End If ' g_Start_Prms$ = s$ 'Check for change at exit flag = Val(Mid$(s$, 6, 1)) t_Start_Flags.Stay_Resident = flag flag = Val(Mid$(s$, 7, 1)) t_Start_Flags.Decimal_Display = flag flag = Val(Mid$(s$, 8, 1)) t_Start_Flags.Sort_Flag = flag 'order sort flag = Val(Mid$(s$, 9, 1)) t_Start_Flags.Checkbox_Flag = flag 'default values used End Function ' Function Parameters_Beginning() As Long aa_Common_Locals If t_Start_Flags.Stay_Resident = 1 Then Exit_Box_Unset Else Exit_Box_Set End If If t_Start_Flags.Decimal_Display = 1 Then Decimal_Display_Set Else Decimal_Display_UnSet End If g_Sort_Flag = t_Start_Flags.Sort_Flag Sort_Color_Array g_Checkbox_Flag = t_Start_Flags.Checkbox_Flag Color_Checkboxes End Function ' Function Parameters_Save_At_Exit () As Long ' Exit Function aa_common_Locals ' t_Start_Flags.Exist = "Swede" s$ = t_Start_Flags.Exist 'checking for changed flags ' Id = 12: Control Get Check g_hdlg, %Start_g_CheckBox_Ids_at + Id To flag t_Start_Flags.Stay_Resident = flag s$ = s$ & Right$(Str$(Flag), 1) ' ? s$,,"1" ' Id = 13: Control Get Check g_hdlg, %Start_g_CheckBox_Ids_at + Id To flag t_Start_Flags.Decimal_Display = flag s$ = s$ & Right$(Str$(Flag), 1) ' ? s$,,"2" ' t_Start_Flags.Sort_Flag = g_Sort_Flag t_Start_Flags.Checkbox_Flag = g_Checkbox_Flag ' s$ = s$ & Right$(Str$(t_Start_Flags.Sort_Flag), 1) s$ = s$ & Right$(Str$(t_Start_Flags.Checkbox_Flag), 1) ' ? s$,,"3" If g_Start_Prms$ = s$ Then Exit Function 'nothing changed ' ? "Was " & g_Start_Prms$ & " xxx" & $CrLf & _ ' "Now " & s$ & " xxx",, "Parameters Changed" ' ' Dim ThisExe$, Temp_Exe$ ' Temp_Exe$ = "~Temp.exe" If IsFile(Exe.Path$ + Temp_Exe$) Then ' ~Temp.exe? get rid of residual from previous run, Kill Exe.Path$ + Temp_Exe$ ' or see alt. # below End If ' ? "" ThisExe$ = Exe.NameX$ ' "Color_Buttons.exe" Name ThisExe As Temp_Exe$ '<<< error 70 permission denied FileCopy Temp_Exe$, ThisExe$ '"Original.exe" ' Make new copy w/ original name ' ' 'Modify Original.exe ' Change as required (Change Stringtable - UpdateResource ??) fn$ = ThisExe$ z_Binary_Get 'send fn$, returns flen, fle$ i = Len(t_Start_Flags) t$ = Right$(fle$, i) 'end of file ' If Left$(t$, 5) <> "Swede" Then 'params not set yet fle$ = fle$ & s$ Else Mid$(fle$, flen - i + 1) = s$ End If z_Binary_Put 'send fn$, fle$ ' ' ' ' # Alternative - remove residual ~Temp.exe on exit. ' ' At program end - Create a batch file that can delete ~Temp.exe and itself as per Wayne Diamond.. ' ' http://www.powerbasic.com/support/fo...ML/001350.html ' ' ' MsgBox "Done",, fn$ End Function ' ' ******************************************************* ' '[/Code]