Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Color common dialog box with rainbow color examples.

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Color common dialog box with rainbow color examples.

    ' June 23, 2002: This is an updated version for PB Win 6 and 7.
    '
    ' Color common dialog box demonstration with rainbow color examples.
    '
    ' This program demonstrates the use of Windows' color common dialog and
    ' some examples of various color combinations using a label (static) control
    ' as originally suggested by Lance Edmonds for graphic purposes
    ' in the PowerBasic Forum.
    '
    ' The code skeleton was generated by EZGUI Freeware Dialog Designer
    ' by Christopher R. Boss see web site at EZGUI.COM.
    ' Unused code has been removed to improve clarity.
    '
    ' Comments for improvement are most welcome. Public domain.
    ' Use at own risk!
    '
    ' Best Wishes,
    ' Erik Christensen ---- e.chr@email.dk
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    '
    %NOANIMATE    = 1
    %NOBUTTON     = 1
    %NOCOMBO      = 1
    %NODRAGLIST   = 1
    %NOHEADER     = 1
    %NOIMAGELIST  = 1
    %NOLIST       = 1
    %NOTRACKBAR   = 1
    '
    #INCLUDE "win32api.inc"
    #INCLUDE "commctrl.inc"
    #INCLUDE "COMDLG32.INC"
    '
    %FORM1_STATIC1            = 105
    %FORM1_TEXT1              = 110
    %FORM1_BUTTON1            = 115
    %FORM1_BUTTON2            = 120
    %FORM1_BUTTON3            = 125
    %FORM1_BUTTON4            = 130
    %FORM1_BUTTON5            = 135
    %FORM1_BUTTON6            = 140
    ' --------------------------------------------------
    DECLARE SUB ShowDialog_Form1(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION Form1_DLGPROC
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON1()
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON2()
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON3()
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON4()
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON5()
    DECLARE CALLBACK FUNCTION CBF_FORM1_BUTTON6()
    DECLARE SUB ShowText2(BYVAL hDC AS LONG,BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG, _
        BYVAL FaceName AS STRING,BYVAL TextStr AS STRING,BYREF XX&,BYREF YY&,BYREF TxCol&)
    DECLARE FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
        BYVAL FaceName AS STRING) AS LONG
    DECLARE FUNCTION colorapi AS LONG
    
    GLOBAL hForm1&    ' Dialog handle
    GLOBAL lfFont AS lOGFONT   ' Logfont structure
    GLOBAL hEdit AS LONG
    GLOBAL hGraph AS LONG
    GLOBAL tm AS TEXTMETRIC    ' Textmetric structure
    GLOBAL X&,Y&,X1&,Y1&
    GLOBAL Rct AS RECT
    GLOBAL Ps AS PAINTSTRUCT   ' Paint structure
    GLOBAL Brush AS LONG
    GLOBAL ExampleFlag AS LONG
    GLOBAL TextFont AS LONG
    GLOBAL CF AS SINGLE
    GLOBAL LogPixelsY AS LONG 'pixels per logical inch
                              'along the screen height
    ' *************************************************************
    FUNCTION PBMAIN
        LOCAL Count&
        LOCAL hDC AS LONG
        LOCAL CC1 AS INIT_COMMON_CONTROLSEX
        CC1.dwSize=SIZEOF(CC1)
        CC1.dwICC=%ICC_WIN95_CLASSES
        InitCommonControlsEX CC1
        'Retrieves a handle of a display device context (DC) for the
        'client area of the specified window (here the desktop).
        hDC = GetDC(%HWND_DESKTOP)
        '
        'Retrieves device-specific information about the number
        'of pixels per logical inch along the screen height
        '(depends on screen resolution setting).
        'This is important to define appropriate font sizes.
        'LogPixelsY = 120 for large fonts and 96 for small fonts setting of Windows
        LogPixelsY  = GetDeviceCaps(hDC, %LOGPIXELSY)
        CF = 1 ' dialog conversion factor for large fonts setting
        IF LogPixelsY = 96 THEN CF = 1.25 ' dialog conversion factor for small fonts setting
        '
        ReleaseDC %HWND_DESKTOP, hDC
        '
        Brush=CreateSolidBrush(RGB(255,255,255)) ' white brush
        ExampleFlag=0
        ShowDialog_Form1 0
        DO
          DIALOG DOEVENTS TO Count&
        LOOP UNTIL Count&=0
        DeleteObject Brush
        CALL DeleteObject (TextFont)
    END FUNCTION
    ' *************************************************************
    SUB ShowDialog_Form1(BYVAL hParent&)
        LOCAL Style&, ExStyle&,hCtl&
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
        ' NB: the clipchildren style must be included
        ExStyle& = 0
        X&=360:Y&=262
        DIALOG NEW hParent&, "Choose Color Dialog Demonstration", 0, 0,  X&*CF, Y&*CF, Style&, ExStyle& TO hForm1&
        DIALOG UNITS hForm1&, X&, Y& TO PIXELS X1&, Y1&
        ' The graphics routines use pixels. Hence this conversion.
        CONTROL ADD LABEL, hForm1&, %FORM1_STATIC1, "", 0, 0, X&*CF,234*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
            ' NB: The grayframe style must be included
        CONTROL HANDLE hForm1&, %FORM1_STATIC1 TO hGraph ' handle for graphics window
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON3,  "Example &1", 10*CF, 242*CF, 40*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON3
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON4,  "Example &2", 60*CF, 242*CF, 40*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON4
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON5,  "Color RGB &Data", 110*CF, 242*CF, 60*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON5
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON6,  "&Text", 180*CF, 242*CF, 30*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON6
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON1,  "Choose &Color", 220*CF, 242*CF, 80*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON1
        CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON2,  "&End", 310*CF, 242*CF, 40*CF, 12*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON2
        DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
    END SUB
    ' *************************************************************
    CALLBACK FUNCTION Form1_DLGPROC
        LOCAL hDC AS LONG
        ' Get rectangle in label (static) control
        GetClientRect hGraph,Rct
        SELECT CASE CBMSG
            CASE %WM_PAINT
              hDC = BeginPaint(CBHNDL, Ps)
              ' obtain handle of the static label control
              hDC = GetDC(GetDlgItem(CBHNDL, %FORM1_STATIC1))
              SELECT CASE ExampleFlag
                  CASE 0: CALL TextGraphics0(hDC)
                  CASE 1: CALL ColorExample1(hDC)
                  CASE 2: CALL ColorExample2(hDC)
                  CASE 3: CALL ColorExample3(hDC)
                  CASE ELSE
              END SELECT
              EndPaint CBHNDL, Ps
              ReleaseDC GetDlgItem(CBHNDL, %FORM1_STATIC1), hDC
              FUNCTION = 1
            ' -----------------------------------------------
            CASE %WM_CTLCOLORMSGBOX , %WM_CTLCOLORBTN, %WM_CTLCOLOREDIT,_
                 %WM_CTLCOLORSTATIC, %WM_CTLCOLORSCROLLBAR, %WM_CTLCOLORLISTBOX
                ' Control colors
                SELECT CASE GetDlgCtrlID(CBLPARAM)
                    CASE  %FORM1_TEXT1
                        SetTextColor CBWPARAM, RGB(0,0,191)
                        SetBkColor CBWPARAM, RGB(255,255,255)
                        FUNCTION=Brush
                    CASE ELSE
                        FUNCTION=0
                END SELECT
            CASE ELSE
        END SELECT
    END FUNCTION
    ' -------------------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON1
        LOCAL hCtl&, res&
        res&=colorapi ' function which calls the ChooseColor dialog
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON3
        LOCAL res&
        CONTROL KILL hForm1&, %FORM1_TEXT1
        ExampleFlag=1
        res&=InvalidateRect(hForm1&,Rct,%TRUE)
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON4
        LOCAL res&
        CONTROL KILL hForm1&, %FORM1_TEXT1
        ExampleFlag=2
        res&=InvalidateRect(hForm1&,Rct,%TRUE)
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON5
        LOCAL res&
        CONTROL KILL hForm1&, %FORM1_TEXT1
        ExampleFlag=3
        res&=InvalidateRect(hForm1&,Rct,%TRUE)
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON6 ' text
        LOCAL res&,t$
        LOCAL hEdit AS LONG
        CONTROL KILL hForm1&, %FORM1_TEXT1
        t$="Color demonstration program, version 2, June 23, 2002.   "+ _
        "By Erik Christensen ----- e.chr@email.dk"+$CRLF + $CRLF + _
        "Generally color is described by 3 characteristics: " + $CRLF + _
        "1. Hue (tint) is related to the frequency of the light or the "+ _
        "position in the spectrum or the relative amounts of red, green and "+ _
        "blue. A pure hue is 50% luminosity and 100% saturation. "+$CRLF+ _
        "2. Saturation. This is the amount of perceived color, or the percentage "+ _
        "of hue in a color. Saturated colors are vivid, strong, or deep. "+ _
        "Desaturated colors are dull, weak, or washed out. Saturation is "+ _
        "thus the richness of hue. Saturation is decreased in "+ _
        "proportion to dilution of the color by grayness. "+$CRLF+ _
        "3. Brightness (tone, luminance, value, luminosity, lightness). "+ _
        "This describes the total amount of light in the color. Zero "+ _
        "brightness is black and 100% is white, intermediate values are "+ _
        "light or dark colors. "+$CRLF+ _
        "Human vision has a nonlinear perceptual response to brightness: "+ _
        "a source having a luminance only 18% of a reference luminance "+ _
        "appears about half as bright. The perceptual response to luminance "+ _
        "is called Lightness. "+$CRLF+ _
        "If three sources appear red, green and blue, and have the same "+ _
        "radiance in the visible spectrum, then the green will appear the "+ _
        "brightest of the three because the luminous efficiency function "+ _
        "peaks in the green region of the spectrum. The red will appear less "+ _
        "bright, and the blue will be the darkest of the three. "+ _
        "When you look at a rainbow you do not see a smooth gradation of "+ _
        "colors. Instead, some bands appear quite narrow, and others are "+ _
        "quite broad. Perceptibility of hue variation near 540 nm (green) is half "+ _
        "that of either 500 nm (blue-cyan) or 600 nm (orange). If you use the rainbow's colors "+ _
        "to represent data, the visibility of differences among your data "+ _
        "values will depend on where they lie in the spectrum. If you are "+ _
        "using color to aid in the visual detection of patterns, you should "+ _
        "use colors chosen according to the principles of perceptual uniformity. "+$CRLF+$CRLF+ _
        "This program focuses on rainbow colors. Example 1 shows these colors "+ _
        "fully saturated. Example 2 shows the same colors with gradual darkening and whitening. "+ _
        "The color RGB data chart is based on the same principle. "+$CRLF+$CRLF+ _
        "The Choose Color dialog allows one to select up to 16 colors of ones own "+ _
        "specification. You could expand the program to save these colors if you "+ _
        "want to do that."
        CONTROL ADD TEXTBOX, hForm1&,  %FORM1_TEXT1,"", 0,0, X&*CF, 234*CF, _
            %WS_CHILD OR %WS_VISIBLE OR %ES_READONLY OR %ES_LEFT OR %ES_MULTILINE OR %WS_VSCROLL OR %WS_TABSTOP, _
            %WS_EX_CLIENTEDGE
        TextFont=MakeFont(15*CF,400,0,0,0,"Arial")
        CONTROL HANDLE hForm1&,%FORM1_TEXT1 TO hEdit
        CALL SendMessage (hEdit, %WM_SETFONT, TextFont, 0) ' send font to control
        CONTROL SET TEXT hForm1&,%FORM1_TEXT1, t$
        ExampleFlag=10 ' prevents calling to other routine
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_FORM1_BUTTON2
        DIALOG END CBHNDL
    END FUNCTION
    ' ------------------------------------------------
    ' ------------------------------------------------
    FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
        BYVAL FaceName AS STRING) AS LONG
        ' -----------------------
        'TYPE LOGFONT defines the attributes of a font.
        'See LOGFONT in the Win32 help file
        lfFont.lfHeight = -MulDiv(FontTypeSize,LogPixelsY,72) ' better than: -(FontTypeSize * LogPixelsY) \ 72
                                                ' logical height of font
        lfFont.lfWidth = 0                      ' logical average character width
        lfFont.lfEscapement = 0                 ' angle of escapement
        lfFont.lfOrientation = 0                ' base-line orientation angle
        lfFont.lfWeight = FontWeight            ' font weight
        lfFont.lfItalic = Italic                ' italic attribute flag
        lfFont.lfUnderline = Underline          ' underline attribute flag
        lfFont.lfStrikeOut = StrikeOut          ' strikeout attribute flag
        lfFont.lfCharSet = %ANSI_CHARSET        ' character set identifier
        lfFont.lfOutPrecision = %OUT_TT_PRECIS  ' output precision
        lfFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS  ' clipping precision
        lfFont.lfQuality = %DEFAULT_QUALITY     ' output quality
        lfFont.lfPitchAndFamily = %FF_DONTCARE  ' pitch and family
        lfFont.lfFaceName = FaceName            ' typeface name string
        ' -----------------------
        ' Make font according to specifications
        FUNCTION = CreateFontIndirect (lfFont)
    END FUNCTION
    ' ------------------------------------------------
    SUB ShowText2(BYVAL hDC AS LONG,BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG, _
        BYVAL FaceName AS STRING,BYVAL TextStr AS STRING,BYREF XX&,BYREF YY&,BYREF TxCol&)
        DIM lpsz AS ASCIIZ * 255
        LOCAL CurrentFont AS LONG
        LOCAL i%,j%,YD&,res&
        CurrentFont=MakeFont(FontTypeSize,FontWeight,Italic,Underline,0,FaceName)
        SelectObject hDC, CurrentFont ' select font for the static control
        res&=SetTextColor(hDC, TxCol&)
        res& = GetTextMetrics(hDC,tm)
        ' Vertical extension (YD&)= Character Height + Space between lines
        YD& = tm.tmHeight + tm.tmExternalLeading
        lpsz=TextStr
        TextOut hDC, XX&,YY&, lpsz, BYVAL LEN(lpsz)
        CALL DeleteObject (CurrentFont) ' delete font
        ' Go one line down
        YY&=YY&+YD&
    END SUB
    ' ----------------------------------
    ' ----------------------------------
    SUB TextGraphics0(hDC AS LONG)
        LOCAL XX&,YY&,hEdit AS LONG
        FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
        SetTextAlign hDC,%TA_CENTER '%TA_LEFT
        XX&=X1&*CF/2.1:YY&=Y1*CF/25
        CALL ShowText2(hDC,64*CF,1000,0,0,"Edwardian Script ITC","Color",XX&,YY&,RGB(225,0,0))
        CALL ShowText2(hDC,64*CF,1000,0,0,"Edwardian Script ITC","Demonstration",XX&,YY&,RGB(0,164,0))
        CALL ShowText2(hDC,64*CF,1000,0,0,"Edwardian Script ITC","Program",XX&,YY&,RGB(0,0,255))
    END SUB
    ' ----------------------------------
    ' ----------------------------------
    FUNCTION colorapi AS LONG
        'This function uses the Windows ChooseColor common dialog.
        '
        'Some flags that can be used with the dialog:
        'You can experiment with different combinations of these.
        '%CC_RGBINIT                     = &H00000001&
        '%CC_FULLOPEN                    = &H00000002&
        '%CC_PREVENTFULLOPEN             = &H00000004&
        '%CC_SHOWHELP                    = &H00000008&
        '%CC_ENABLEHOOK                  = &H00000010&
        '%CC_ENABLETEMPLATE              = &H00000020&
        '%CC_ENABLETEMPLATEHANDLE        = &H00000040&
        '
        'TYPE CHOOSECOLORAPI  ' Structure used by the dialog
        '  lStructSize    AS LONG  'the length, in bytes, of the structure
        '  hwndOwner      AS LONG  'Identifies the window that owns the dialog box. This member can be any valid window handle, or it can be NULL if the dialog box has no owner.
        '  hInstance      AS LONG  'If neither CC_ENABLETEMPLATEHANDLE nor CC_ENABLETEMPLATE is set, this member is ignored
        '  rgbResult      AS DWORD 'If the CC_RGBINIT flag is set, rgbResult specifies the color initially selected when the dialog box is created. If the user clicks the OK button, rgbResult specifies the user's color selection.
        '  lpCustColors   AS DWORD PTR 'Pointer to an array of 16 COLORREF values. To preserve new custom colors between calls to the ChooseColor function, you should allocate static memory for the array.
        '  Flags          AS LONG  'flags that you can use to initialize the Color common dialog box.
        '  lCustData      AS LONG  'Specifies application-defined data that the system passes to the hook procedure identified by the lpfnHook member.
        '  lpfnHook       AS DWORD  'This member is ignored unless the CC_ENABLEHOOK flag is set in the Flags member
        '  lpTemplateName AS ASCIIZ PTR 'This member is ignored unless the CC_ENABLETEMPLATE flag is set in the Flags member.
        'END TYPE
        '
        LOCAL CS AS CHOOSECOLORAPI
        LOCAL Res   AS LONG
        LOCAL I  AS LONG, K AS LONG, K2 AS LONG
        LOCAL Red&,Green&,Blue&,t$
        STATIC Index AS LONG
        DIM YourColors(15) AS STATIC LONG 'Array to hold your selected colors
                                          'This static array keeps your
                                          'selection between calls.
        CS.lStructSize  = SIZEOF(CS)
        CS.hwndOwner    = 0     'Handle of owner window.
                                'If this is zero, then the dialog
                                'appears at the top left corner.
        CS.lpCustColors = VARPTR(YourColors(0))
        CS.rgbResult    = RGB(0,0,255) 'default color setting (Blue)
        CS.Flags = CS.Flags OR %CC_FULLOPEN OR %CC_RGBINIT
    
        ' Call to the Windows choosecolor common dialog
        Res = ChooseColor(CS)
        Index =15
        'The colors in the array are initially black, but the static
        'array preserves custom colors created by the user for subsequent
        'ChooseColor calls.
        Red&=CS.rgbResult MOD 256
        Green&=(CS.rgbResult\256) MOD 256
        Blue&=(CS.rgbResult\256^2) MOD 256
        IF Res >0 THEN ' OK pressed
            t$="Latest color chosen: &H"+HEX$(CS.rgbResult,6)+"  =  "+FORMAT$(CS.rgbResult,"########")+"  =  "+ _
            "RGB("+FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)+")"+$CRLF+$CRLF+ _
            "Custom colors selected by you:"+$CRLF
            FOR I=0 TO Index
                Red&=YourColors(I) MOD 256
                Green&=(YourColors(I)\256) MOD 256
                Blue&=(YourColors(I)\256^2) MOD 256
                t$=t$+"Color"+STR$(I)+": &H"+HEX$(YourColors(I),6)+"  =  "+FORMAT$(YourColors(I),"########")+"  =  "+ _
                   "RGB("+FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)+")"+$CRLF
            NEXT
            MSGBOX t$,%MB_ICONINFORMATION,"Color Selection Demonstration"
        END IF
        '
        ' The lines below push the selected colors to the right to allow new
        ' colors to be added to the left when the dialog is called the next time.
        ' These lines may be deleted if you wish.
        K=7
        FOR I=7 TO 0 STEP -1
            IF YourColors(I)>0 THEN SWAP YourColors(I),YourColors(K) ECR K
        NEXT
        K2=15
        FOR I=15 TO 8 STEP -1
            IF YourColors(I)>0 THEN SWAP YourColors(I),YourColors(K2) ECR K2
        NEXT
        IF K<K2-8 THEN SWAP YourColors(K+1),YourColors(K+9)
        '
        FUNCTION=1
    END FUNCTION
    '
    '
    'The custom colors extension of the COLOR DIALOG box allows the
    'user to specify a color using RGB or HSL values. However, the
    'CHOOSECOLOR structure uses only RGB values to report the colors
    'created or selected by the user.
    '
    'RGB COLOR Model
    '
    'The RGB model is used to designate colors for displays and other
    'devices that emit light. Valid red, green, and blue values range
    'from 0 through 255, with 0 indicating minimum intensity and 255
    'indicating maximum intensity. The following table
    'shows how the primary colors red, green, and blue can be combined
    'to produce four additional colors. (For display devices, the color
    'black results when the red, green, and blue values are set TO 0.
    'in display technology, black is the absence of all colors.)
    '
    'Following are eight colors and their associated RGB values:
    'COLOR   RGB values
    'Red     255,   0,   0
    'Green   0,   255,   0
    'Blue    0,     0, 255
    'Cyan    0,   255, 255
    'Magenta 255,   0, 255
    'Yellow  255, 255,   0
    'White   255, 255, 255
    'Black   0,     0,   0
    '
    'Windows stores internal colors as 32-bit RGB values that have the
    'following hexadecimal form: 0x00bbggrr.
    '
    'The low-order byte contains a value for the relative intensity
    'of red; the second byte contains a value for green; and the third
    'byte contains a value for blue. The high-order byte must be zero.
    'You can use the RGB macro to get an RGB value based on specified
    'intensities for the red, green, and blue components. Besides the
    'formulas provided in the routine you may use the GetRValue, GetBValue, and
    'GetGValue macros to extract individual colors from an RGB color value.
    '
    'HSL Color Model
    '
    'The COLOR DIALOG box provides controls for specifying HSL values.
    'The dialog includes a color spectrum control and a luminosity slide
    'control.
    'In the COLOR DIALOG box, the saturation and luminosity values
    'must be in the range 0 through 240, and the hue value must be
    'in the range 0 through 239.
    '
    'Converting HSL Values TO RGB Values
    '
    'The DIALOG box procedure provided in COMDLG32.DLL for the
    'COLOR DIALOG box contains code that converts HSL values to the
    'corresponding RGB values. Following are several colors and their
    'associated HSL and RGB values.
    '
    'COLOR   HSL values      RGB values
    'Red     (0, 240, 120)   (255, 0, 0)
    'Yellow  (40, 240, 120)  (255, 255, 0)
    'Green   (80, 240, 120)  (0, 255, 0)
    'Cyan    (120, 240, 120) (0, 255, 255)
    'Blue    (160, 240, 120) (0, 0, 255)
    'Magenta (200, 240, 120) (255, 0, 255)
    'White   (0, 0, 240)     (255, 255, 255)
    'Black   (0, 0, 0)       (0, 0, 0)
    '
    '
    SUB ColorExample1(hDC AS LONG)
        LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
        LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
        DIM lpsz AS ASCIIZ * 255
        LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
        LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
        LOCAL hPen AS LONG
        LOCAL hBrush AS LONG
        FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
        SetTextAlign hDC,%TA_LEFT '%TA_CENTER
        XX&=2*CF:YY&=Y1&*CF/2.7
        CALL ShowText2(hDC,16*CF,400,1,0,"Arial","Rainbow Colors",XX&,YY&,RGB(0,0,0))
        CALL ShowText2(hDC,16*CF,400,1,0,"Arial","Saturation 100%",XX&,YY&,RGB(0,0,0))
        XX&=X1&*2*CF/3.06:YY&=Y1&*CF/2.24
        Radius&=Y1&*CF/2.3
        xLeft  = XX& - Radius& : xRight =  XX& + Radius&
        yTop   = YY& - Radius& : yBottom = YY& + Radius&
        FOR i&=0 TO 359 STEP 2           ' one 360 degrees turn (color loop)
            Radian!=i&*0.0174533
            xStart=XX&+Radius&*COS(Radian!)  ' coordinates
            yStart=YY&+Radius&*SIN(Radian!)
            xEnd=XX&+Radius&*COS((i&-3)*0.0174533) ' angle converted to radians
            yEnd=YY&+Radius&*SIN((i&-3)*0.0174533)
            CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
            Col&=RGB(Red&,Green&,Blue&) ' make color from red, green and blue
            hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
            hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
            ' draw pie piece in specified color
            Pie hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
            ' delete pen and brush (very important cleaning up)
            DeleteObject SelectObject(hDC, hPen)
            DeleteObject SelectObject(hDC, hBrush)
        NEXT
    END SUB
    '
    '
    SUB ColorExample2(hDC AS LONG)
        LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
        LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
        DIM lpsz AS ASCIIZ * 255
        LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
        LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
        LOCAL hPen AS LONG
        LOCAL hBrush AS LONG
        FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
        SetTextAlign hDC,%TA_LEFT '%TA_CENTER
        XX&=1*CF:YY&=Y1&*CF/2.7
        CALL ShowText2(hDC,10*CF,400,1,0,"Arial","Rainbow Colors With Gradual",XX&,YY&,RGB(0,0,0))
        CALL ShowText2(hDC,10*CF,400,1,0,"Arial","Whitening (Center)",XX&,YY&,RGB(0,0,0))
        CALL ShowText2(hDC,10*CF,400,1,0,"Arial","And Blackening (Periphery)",XX&,YY&,RGB(0,0,0))
        XX&=X1&*2*CF/3.057:YY&=Y1&*CF/2.24
        Radius&=Y1&*CF/2.3+7
        FOR j&=-15 TO 16 ' loop to darken (negative j&) and lighten (positive j&) color
        'FOR j&=16 TO -15 STEP -1 ' you may try this instead.
            Radius&=Radius&-7
            xLeft  = XX& - Radius& : xRight =  XX& + Radius& ' coordinates
            yTop   = YY& - Radius& : yBottom = YY& + Radius&
            FOR i&=0 TO 359 STEP 4           ' one 360 degrees turn (color loop)
                Radian!=i&*0.0174533
                xStart=XX&+Radius&*COS(Radian!)        ' coordinates
                yStart=YY&+Radius&*SIN(Radian!)
                xEnd=XX&+Radius&*COS((i&-5)*0.0174533) ' angle in radians
                yEnd=YY&+Radius&*SIN((i&-5)*0.0174533)
                CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
                IF j&<0 THEN ' darken color (j& is negative)
                    Red&=Red&+j&*Red&/20 ' darken red, green and blue in same porportion
                    Green&=Green&+j&*Green&/20
                    Blue&=Blue&+j&*Blue&/20
                END IF
                IF j&>0 THEN ' lighten color (j& is positive)
                    Red&=Red&+(255-Red&)*j&/16 ' lighten red, green and blue in same porportion
                    Green&=Green&+(255-Green&)*j&/16
                    Blue&=Blue&+(255-Blue&)*j&/16
                END IF
                Col&=RGB(Red&,Green&,Blue&) ' make color from red, green and blue
                hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
                hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
                ' draw pie section of circle in specified color
                Pie hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
                ' delete pen and brush (very important cleaning up)
                DeleteObject SelectObject(hDC, hPen)
                DeleteObject SelectObject(hDC, hBrush)
            NEXT
        NEXT
    END SUB
    '
    '
    SUB ColorExample3(hDC AS LONG)
        LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
        LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
        DIM lpsz AS ASCIIZ * 255
        LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
        LOCAL hPen AS LONG
        LOCAL hBrush AS LONG
        ' Make a suitable narrow font
        TextFont=MakeFont(6*CF,400,0,0,0,"Gill Sans MT Condensed")
        SelectObject hDC, TextFont
        FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
        SetTextAlign hDC,%TA_LEFT '%TA_CENTER
        FOR j&=-7 TO 7
            xLeft  = 2+47.4*(j&+7)/CF^.3     ' coordinates of rectangle
            xRight = 2+47.4*(j&+8)/CF^.3
            FOR i&=0 TO 359 STEP 10          ' one 360 degrees turn (color loop)
                yTop   = 2+1.28*i&*CF^.085           ' coordinates of rectangle
                yBottom = 18+1.28*i&*CF^.085
                CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
                IF j&<0 THEN ' darken red, green and blue in same proportion
                    Red&=Red&+j&*Red&/8 ' subtract amount (remember: j& is negative)
                    Green&=Green&+j&*Green&/8
                    Blue&=Blue&+j&*Blue&/8
                END IF
                IF j&>0 THEN ' lighten red, green and blue in same proportion
                    Red&=Red&+(255-Red&)*j&/8 ' add amount (j& is positive)
                    Green&=Green&+(255-Green&)*j&/8
                    Blue&=Blue&+(255-Blue&)*j&/8
                END IF
                Col&=RGB(Red&,Green&,Blue&) ' Make specified color
                hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
                hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
                Rectangle hDC,xLeft,yTop,xRight,yBottom ' draw rectangle in specified color
                ' delete pen and brush (very important cleaning up)
                DeleteObject SelectObject(hDC, hPen)
                DeleteObject SelectObject(hDC, hBrush)
                ' make text
                a$=FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)
                res&=SetBkColor(hDC,Col&)
                ' Decide from color if text should be black or white
                ' This function is suited when transformation to a grey scale is needed.
                IF Red&*.222+Green&*.707+Blue&*.071>128 THEN  ' Color is light,
                    res&=SetTextColor(hDC, RGB(0,0,0))        ' then text should be black.
                ELSE                                          ' Color is dark,
                    res&=SetTextColor(hDC, RGB(255,255,255))  ' then text should be white.
                END IF
                lpsz=a$
                ' Write text on top of color rectangle
                TextOut hDC, xLeft+2,yTop, lpsz, BYVAL LEN(lpsz)
            NEXT
        NEXT
    END SUB
    '
    '
    SUB GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
        SELECT CASE i& 'i& can vary between 0 and 359 (full circle)
            CASE 0 TO 59
                Red&=(i& MOD 60)*4.25       ' increasing red
                Green&=255                  ' maximum green
                Blue&=0                     ' no blue
            CASE 60 TO 119
                Red&=255                    ' maximum red
                Green&=255-(i& MOD 60)*4.25 ' decreasing green
                Blue&=0                     ' no blue
            CASE 120 TO 179
                Red&=255                    ' maximum red
                Green&=0                    ' no green
                Blue&=(i& MOD 60)*4.25      ' increasing blue
            CASE 180 TO 239
                Red&=255-(i& MOD 60)*4.25   ' decreasing red
                Green&=0                    ' no green
                Blue&= 255                  ' maximum blue
            CASE 240 TO 299
                Red&=0                      ' no red
                Green&=(i& MOD 60)*4.25     ' increasing green
                Blue& = 255                 ' maximum blue
            CASE 300 TO 359
                Red&=0                      ' no red
                Green&=255                  ' maximum green
                Blue&=255-(i& MOD 60)*4.25  ' decreasing blue
            CASE ELSE
        END SELECT
    END SUB
    '
    '  e.chr@email.dk
    [This message has been edited by Erik Christensen (edited June 23, 2002).]

  • #2
    This just to inform you that the program has been updated
    to work for both PB Win 6 and 7.

    Comments are welcome in the Programmers or Windows forum.

    Regards,

    Erik

    ------------------

    Comment


    • #3
      ' This is an update of the program, which now runs without problems using PBWin10.

      ' Best regards,

      ' Erik

      Code:
      ' This is an update of the program, which now runs without problems using PBWin10.
      
      ' Best regards,
      
      ' Erik
      
      #COMPILE EXE
      #REGISTER NONE
      #DIM ALL
      '
      %NOANIMATE    = 1
      %NOBUTTON     = 1
      %NOCOMBO      = 1
      %NODRAGLIST   = 1
      %NOHEADER     = 1
      %NOIMAGELIST  = 1
      %NOLIST       = 1
      %NOTRACKBAR   = 1
      '
      #INCLUDE "win32api.inc"
      #INCLUDE "commctrl.inc"
      #INCLUDE "COMDLG32.INC"
      '
      %FORM1_STATIC1            = 105
      %FORM1_TEXT1              = 110
      %FORM1_BUTTON1            = 115
      %FORM1_BUTTON2            = 120
      %FORM1_BUTTON3            = 125
      %FORM1_BUTTON4            = 130
      %FORM1_BUTTON5            = 135
      %FORM1_BUTTON6            = 140
      ' --------------------------------------------------
      GLOBAL hForm1&             ' Dialog handle
      GLOBAL lfFont AS lOGFONT   ' Logfont structure
      GLOBAL hEdit AS LONG
      GLOBAL hGraph AS LONG
      GLOBAL tm AS TEXTMETRIC    ' Textmetric structure
      GLOBAL X&,Y&,X1&,Y1&
      GLOBAL Rct AS RECT
      GLOBAL Ps AS PAINTSTRUCT   ' Paint structure
      GLOBAL Brush AS LONG
      GLOBAL ExampleFlag AS LONG
      GLOBAL TextFont AS LONG
      GLOBAL CF AS SINGLE
      ' *************************************************************
      FUNCTION PBMAIN
          LOCAL Count&
          LOCAL hDC AS LONG
          LOCAL CC1 AS INIT_COMMON_CONTROLSEX
          CC1.dwSize=SIZEOF(CC1)
          CC1.dwICC=%ICC_WIN95_CLASSES
          InitCommonControlsEX CC1
      
          CF = 2
      
          Brush=CreateSolidBrush(RGB(255,255,255)) ' white brush
          ExampleFlag=0
          ShowDialog_Form1 0
          DO
            DIALOG DOEVENTS TO Count&
          LOOP UNTIL Count&=0
          DeleteObject Brush
          CALL DeleteObject (TextFont)
      END FUNCTION
      ' *************************************************************
      SUB ShowDialog_Form1(BYVAL hParent&)
          LOCAL Style&, ExStyle&,hCtl&
          Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
          ' NB: the clipchildren style must be included
          ExStyle& = 0
          X&=360:Y&=262
          DIALOG NEW PIXELS, hParent&, "Choose Color Dialog Demonstration", 0, 0,  X&*CF, Y&*CF, Style&, ExStyle& TO hForm1&
          DIALOG UNITS hForm1&, X&, Y& TO PIXELS X1&, Y1&
          ' The graphics routines use pixels. Hence this conversion.
          CONTROL ADD LABEL, hForm1&, %FORM1_STATIC1, "", 0, 0, X&*CF,234*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
              ' NB: The grayframe style must be included
          CONTROL HANDLE hForm1&, %FORM1_STATIC1 TO hGraph ' handle for graphics window
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON3,  "Example &1", 10*CF, 242*CF, 40*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON3
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON4,  "Example &2", 60*CF, 242*CF, 40*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON4
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON5,  "Color RGB &Data", 110*CF, 242*CF, 60*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON5
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON6,  "&Text", 180*CF, 242*CF, 30*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON6
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON1,  "Choose &Color", 220*CF, 242*CF, 80*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON1
          CONTROL ADD "Button", hForm1&,  %FORM1_BUTTON2,  "&End", 310*CF, 242*CF, 40*CF, 12*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTON2
          DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
      END SUB
      ' *************************************************************
      CALLBACK FUNCTION Form1_DLGPROC
          LOCAL hDC AS LONG
          ' Get rectangle in label (static) control
          GetClientRect hGraph,Rct
          SELECT CASE CBMSG
              CASE %WM_PAINT
                hDC = BeginPaint(CBHNDL, Ps)
                ' obtain handle of the static label control
                hDC = GetDC(GetDlgItem(CBHNDL, %FORM1_STATIC1))
                SELECT CASE ExampleFlag
                    CASE 0: CALL TextGraphics0(hDC)
                    CASE 1: CALL ColorExample1(hDC)
                    CASE 2: CALL ColorExample2(hDC)
                    CASE 3: CALL ColorExample3(hDC)
                    CASE ELSE
                END SELECT
                EndPaint CBHNDL, Ps
                ReleaseDC GetDlgItem(CBHNDL, %FORM1_STATIC1), hDC
                FUNCTION = 1
              ' -----------------------------------------------
              CASE %WM_CTLCOLORMSGBOX , %WM_CTLCOLORBTN, %WM_CTLCOLOREDIT,_
                   %WM_CTLCOLORSTATIC, %WM_CTLCOLORSCROLLBAR, %WM_CTLCOLORLISTBOX
                  ' Control colors
                  SELECT CASE GetDlgCtrlID(CBLPARAM)
                      CASE  %FORM1_TEXT1
                          SetTextColor CBWPARAM, RGB(0,0,191)
                          SetBkColor CBWPARAM, RGB(255,255,255)
                          FUNCTION=Brush
                      CASE ELSE
                          FUNCTION=0
                  END SELECT
              CASE ELSE
          END SELECT
      END FUNCTION
      ' -------------------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON1
          LOCAL hCtl&, res&
          res&=colorapi ' function which calls the ChooseColor dialog
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON3
          LOCAL res&
          CONTROL KILL hForm1&, %FORM1_TEXT1
          ExampleFlag=1
          res&=InvalidateRect(hForm1&,Rct,%TRUE)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON4
          LOCAL res&
          CONTROL KILL hForm1&, %FORM1_TEXT1
          ExampleFlag=2
          res&=InvalidateRect(hForm1&,Rct,%TRUE)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON5
          LOCAL res&
          CONTROL KILL hForm1&, %FORM1_TEXT1
          ExampleFlag=3
          res&=InvalidateRect(hForm1&,Rct,%TRUE)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON6 ' text
          LOCAL res&,t$
          LOCAL hEdit AS LONG
          CONTROL KILL hForm1&, %FORM1_TEXT1
          t$="Color demonstration program, version 3, September 1, 2013.   "+ _
          "By Erik Christensen"+$CRLF + $CRLF + _
          "Generally color is described by 3 characteristics: " + $CRLF + _
          "1. Hue (tint) is related to the frequency of the light or the "+ _
          "position in the spectrum or the relative amounts of red, green and "+ _
          "blue. A pure hue is 50% luminosity and 100% saturation. "+$CRLF+ _
          "2. Saturation. This is the amount of perceived color, or the percentage "+ _
          "of hue in a color. Saturated colors are vivid, strong, or deep. "+ _
          "Desaturated colors are dull, weak, or washed out. Saturation is "+ _
          "thus the richness of hue. Saturation is decreased in "+ _
          "proportion to dilution of the color by grayness. "+$CRLF+ _
          "3. Brightness (tone, luminance, value, luminosity, lightness). "+ _
          "This describes the total amount of light in the color. Zero "+ _
          "brightness is black and 100% is white, intermediate values are "+ _
          "light or dark colors. "+$CRLF+ _
          "Human vision has a nonlinear perceptual response to brightness: "+ _
          "a source having a luminance only 18% of a reference luminance "+ _
          "appears about half as bright. The perceptual response to luminance "+ _
          "is called Lightness. "+$CRLF+ _
          "If three sources appear red, green and blue, and have the same "+ _
          "radiance in the visible spectrum, then the green will appear the "+ _
          "brightest of the three because the luminous efficiency function "+ _
          "peaks in the green region of the spectrum. The red will appear less "+ _
          "bright, and the blue will be the darkest of the three. "+ _
          "When you look at a rainbow you do not see a smooth gradation of "+ _
          "colors. Instead, some bands appear quite narrow, and others are "+ _
          "quite broad. Perceptibility of hue variation near 540 nm (green) is half "+ _
          "that of either 500 nm (blue-cyan) or 600 nm (orange). If you use the rainbow's colors "+ _
          "to represent data, the visibility of differences among your data "+ _
          "values will depend on where they lie in the spectrum. If you are "+ _
          "using color to aid in the visual detection of patterns, you should "+ _
          "use colors chosen according to the principles of perceptual uniformity. "+$CRLF+$CRLF+ _
          "This program focuses on rainbow colors. Example 1 shows these colors "+ _
          "fully saturated. Example 2 shows the same colors with gradual darkening and whitening. "+ _
          "The color RGB data chart is based on the same principle. "+$CRLF+$CRLF+ _
          "The Choose Color dialog allows one to select up to 16 colors of ones own "+ _
          "specification. You could expand the program to save these colors if you "+ _
          "want to do that."
          CONTROL ADD TEXTBOX, hForm1&,  %FORM1_TEXT1,"", 0,0, X&*CF, 234*CF, _
              %WS_CHILD OR %WS_VISIBLE OR %ES_READONLY OR %ES_LEFT OR %ES_MULTILINE OR %WS_VSCROLL OR %WS_TABSTOP, _
              %WS_EX_CLIENTEDGE
          TextFont=MakeFont(21,400,0,0,0,"Arial")
          CONTROL HANDLE hForm1&,%FORM1_TEXT1 TO hEdit
          CALL SendMessage (hEdit, %WM_SETFONT, TextFont, 0) ' send font to control
          CONTROL SET TEXT hForm1&,%FORM1_TEXT1, t$
          ExampleFlag=10 ' prevents calling to other routine
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION CBF_FORM1_BUTTON2
          DIALOG END CBHNDL
      END FUNCTION
      ' ------------------------------------------------
      FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
          BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
          BYVAL FaceName AS STRING) AS LONG
          ' -----------------------
          lfFont.lfHeight = FontTypeSize
          lfFont.lfWidth = 0                      ' logical average character width
          lfFont.lfEscapement = 0                 ' angle of escapement
          lfFont.lfOrientation = 0                ' base-line orientation angle
          lfFont.lfWeight = FontWeight            ' font weight
          lfFont.lfItalic = Italic                ' italic attribute flag
          lfFont.lfUnderline = Underline          ' underline attribute flag
          lfFont.lfStrikeOut = StrikeOut          ' strikeout attribute flag
          lfFont.lfCharSet = %ANSI_CHARSET        ' character set identifier
          lfFont.lfOutPrecision = %OUT_TT_PRECIS  ' output precision
          lfFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS  ' clipping precision
          lfFont.lfQuality = %DEFAULT_QUALITY     ' output quality
          lfFont.lfPitchAndFamily = %FF_DONTCARE  ' pitch and family
          lfFont.lfFaceName = FaceName            ' typeface name string
          ' -----------------------
          ' Make font according to specifications
          FUNCTION = CreateFontIndirect (lfFont)
      END FUNCTION
      ' ------------------------------------------------
      SUB ShowText2(BYVAL hDC AS LONG,BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
          BYVAL Italic AS LONG, BYVAL Underline AS LONG, _
          BYVAL FaceName AS STRING,BYVAL TextStr AS STRING,BYREF XX&,BYREF YY&,BYREF TxCol&)
          DIM lpsz AS ASCIIZ * 255
          LOCAL CurrentFont AS LONG
          LOCAL i%,j%,YD&,res&
          CurrentFont=MakeFont(FontTypeSize,FontWeight,Italic,Underline,0,FaceName)
          SelectObject hDC, CurrentFont ' select font for the static control
          res&=SetTextColor(hDC, TxCol&)
          res& = GetTextMetrics(hDC,tm)
          ' Vertical extension (YD&)= Character Height + Space between lines
          YD& = tm.tmHeight + tm.tmExternalLeading
          lpsz=TextStr
          TextOut hDC, XX&,YY&, lpsz, BYVAL LEN(lpsz)
          CALL DeleteObject (CurrentFont) ' delete font
          ' Go one line down
          YY&=YY&+YD&
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB TextGraphics0(hDC AS LONG)
          LOCAL XX&,YY&,hEdit AS LONG
          FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
          SetTextAlign hDC,%TA_CENTER '%TA_LEFT
          XX&=X1&*CF/2.45:YY&=Y1*CF/25
          CALL ShowText2(hDC,55*CF,1000,0,0,"Monotype Corsiva","Color",XX&,YY&,RGB(225,0,0))
          CALL ShowText2(hDC,55*CF,1000,0,0,"Monotype Corsiva","Demonstration",XX&,YY&,RGB(0,164,0))
          CALL ShowText2(hDC,55*CF,1000,0,0,"Monotype Corsiva","Program",XX&,YY&,RGB(0,0,255))
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      FUNCTION colorapi AS LONG
          'This function uses the Windows ChooseColor common dialog.
          '
          'Some flags that can be used with the dialog:
          'You can experiment with different combinations of these.
          '%CC_RGBINIT                     = &H00000001&
          '%CC_FULLOPEN                    = &H00000002&
          '%CC_PREVENTFULLOPEN             = &H00000004&
          '%CC_SHOWHELP                    = &H00000008&
          '%CC_ENABLEHOOK                  = &H00000010&
          '%CC_ENABLETEMPLATE              = &H00000020&
          '%CC_ENABLETEMPLATEHANDLE        = &H00000040&
          '
          'TYPE CHOOSECOLORAPI  ' Structure used by the dialog
          '  lStructSize    AS LONG  'the length, in bytes, of the structure
          '  hwndOwner      AS LONG  'Identifies the window that owns the dialog box. This member can be any valid window handle, or it can be NULL if the dialog box has no owner.
          '  hInstance      AS LONG  'If neither CC_ENABLETEMPLATEHANDLE nor CC_ENABLETEMPLATE is set, this member is ignored
          '  rgbResult      AS DWORD 'If the CC_RGBINIT flag is set, rgbResult specifies the color initially selected when the dialog box is created. If the user clicks the OK button, rgbResult specifies the user's color selection.
          '  lpCustColors   AS DWORD PTR 'Pointer to an array of 16 COLORREF values. To preserve new custom colors between calls to the ChooseColor function, you should allocate static memory for the array.
          '  Flags          AS LONG  'flags that you can use to initialize the Color common dialog box.
          '  lCustData      AS LONG  'Specifies application-defined data that the system passes to the hook procedure identified by the lpfnHook member.
          '  lpfnHook       AS DWORD  'This member is ignored unless the CC_ENABLEHOOK flag is set in the Flags member
          '  lpTemplateName AS ASCIIZ PTR 'This member is ignored unless the CC_ENABLETEMPLATE flag is set in the Flags member.
          'END TYPE
          '
          LOCAL CS AS CHOOSECOLORAPI
          LOCAL Res1   AS LONG
          LOCAL I  AS LONG, K AS LONG, K2 AS LONG
          LOCAL Red&,Green&,Blue&,t$
          STATIC Index AS LONG
          DIM YourColors(15) AS STATIC LONG 'Array to hold your selected colors
                                            'This static array keeps your
                                            'selections between calls.
          CS.lStructSize  = SIZEOF(CS)
          CS.hwndOwner    = hForm1& 'Handle of owner window.
                                    'If this is zero, then the dialog
                                    'appears at the top left corner.
          CS.lpCustColors = VARPTR(YourColors(0))
          CS.rgbResult    = RGB(0,0,255) 'default color setting (Blue)
          CS.Flags = CS.Flags OR %CC_FULLOPEN OR %CC_RGBINIT
      
          ' Call to the Windows choosecolor common dialog
          Res1 = ChooseColor(CS)
          Index =15
          'The colors in the array are initially black, but the static
          'array preserves custom colors created by the user for subsequent
          'ChooseColor calls.
          Red&=CS.rgbResult MOD 256
          Green&=(CS.rgbResult\256) MOD 256
          Blue&=(CS.rgbResult\256^2) MOD 256
          IF Res1 >0 THEN ' OK pressed
              t$="Latest color chosen: &H"+HEX$(CS.rgbResult,6)+"  =  "+FORMAT$(CS.rgbResult,"########")+"  =  "+ _
              "RGB("+FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)+")"+$CRLF+$CRLF+ _
              "Custom colors selected by you:"+$CRLF
              FOR I=0 TO Index
                  Red&=YourColors(I) MOD 256
                  Green&=(YourColors(I)\256) MOD 256
                  Blue&=(YourColors(I)\256^2) MOD 256
                  t$=t$+"Color"+STR$(I)+": &H"+HEX$(YourColors(I),6)+"  =  "+FORMAT$(YourColors(I),"########")+"  =  "+ _
                     "RGB("+FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)+")"+$CRLF
              NEXT
              MSGBOX t$,%MB_ICONINFORMATION,"Color Selection Demonstration"
          END IF
          '
          ' The lines below push the selected colors to the right to allow new
          ' colors to be added to the left when the dialog is called the next time.
          ' These lines may be deleted if you wish.
          K=7
          FOR I=7 TO 0 STEP -1
              IF YourColors(I)>0 THEN SWAP YourColors(I),YourColors(K) 'ECR K
          NEXT
          K2=15
          FOR I=15 TO 8 STEP -1
              IF YourColors(I)>0 THEN SWAP YourColors(I),YourColors(K2) 'ECR K2
          NEXT
          IF K<K2-8 THEN SWAP YourColors(K+1),YourColors(K+9)
          '
          FUNCTION=1
      END FUNCTION
      '
      SUB ColorExample1(hDC AS LONG)
          LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
          LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
          DIM lpsz AS ASCIIZ * 255
          LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
          LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
          LOCAL hPen AS LONG
          LOCAL hBrush AS LONG
          FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
          SetTextAlign hDC,%TA_LEFT '%TA_CENTER
          XX&=0.2*CF:YY&=Y1&*CF/5.5
          CALL ShowText2(hDC,20*CF,400,1,0,"Arial","Rainbow Colors",XX&,YY&,RGB(0,0,0))
          CALL ShowText2(hDC,20*CF,400,1,0,"Arial","Saturation 100%",XX&,YY&,RGB(0,0,0))
          XX&=X1&*2*CF/3.5 : YY&=Y1&*CF/4.59
          Radius&=Y1&*CF/4.7
          xLeft  = XX& - Radius& : xRight =  XX& + Radius&
          yTop   = YY& - Radius& : yBottom = YY& + Radius&
          FOR i&=0 TO 359 STEP 2           ' one 360 degrees turn (color loop)
              Radian!=i&*0.0174533
              xStart=XX&+Radius&*COS(Radian!)  ' coordinates
              yStart=YY&+Radius&*SIN(Radian!)
              xEnd=XX&+Radius&*COS((i&-3)*0.0174533) ' angle converted to radians
              yEnd=YY&+Radius&*SIN((i&-3)*0.0174533)
              CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
              Col&=RGB(Red&,Green&,Blue&) ' make color from red, green and blue
              hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
              hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
              ' draw pie piece in specified color
              PIE hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
              ' delete pen and brush (very important cleaning up)
              DeleteObject SelectObject(hDC, hPen)
              DeleteObject SelectObject(hDC, hBrush)
          NEXT
      END SUB
      '
      '
      SUB ColorExample2(hDC AS LONG)
          LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
          LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
          DIM lpsz AS ASCIIZ * 255
          LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
          LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
          LOCAL hPen AS LONG
          LOCAL hBrush AS LONG
          FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
          SetTextAlign hDC,%TA_LEFT '%TA_CENTER
          XX&=0.2*CF:YY&=Y1&*CF/5.5
          CALL ShowText2(hDC,23,400,1,0,"Arial","Rainbow Colors With Gradual",XX&,YY&,RGB(0,0,0))
          CALL ShowText2(hDC,23,400,1,0,"Arial","Whitening (Center)",XX&,YY&,RGB(0,0,0))
          CALL ShowText2(hDC,23,400,1,0,"Arial","And Blackening (Periphery)",XX&,YY&,RGB(0,0,0))
          XX&=X1&*2*CF/3.49:YY&=Y1&*CF/4.59
          Radius&=Y1&*CF/4.7 + 7
          FOR j&=-15 TO 16 ' loop to darken (negative j&) and lighten (positive j&) color
          'FOR j&=16 TO -15 STEP -1 ' you may try this instead.
              Radius&=Radius&-7
              xLeft  = XX& - Radius& : xRight =  XX& + Radius& ' coordinates
              yTop   = YY& - Radius& : yBottom = YY& + Radius&
              FOR i&=0 TO 359 STEP 4           ' one 360 degrees turn (color loop)
                  Radian!=i&*0.0174533
                  xStart=XX&+Radius&*COS(Radian!)        ' coordinates
                  yStart=YY&+Radius&*SIN(Radian!)
                  xEnd=XX&+Radius&*COS((i&-5)*0.0174533) ' angle in radians
                  yEnd=YY&+Radius&*SIN((i&-5)*0.0174533)
                  CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
                  IF j&<0 THEN ' darken color (j& is negative)
                      Red&=Red&+j&*Red&/20 ' darken red, green and blue in same porportion
                      Green&=Green&+j&*Green&/20
                      Blue&=Blue&+j&*Blue&/20
                  END IF
                  IF j&>0 THEN ' lighten color (j& is positive)
                      Red&=Red&+(255-Red&)*j&/16 ' lighten red, green and blue in same porportion
                      Green&=Green&+(255-Green&)*j&/16
                      Blue&=Blue&+(255-Blue&)*j&/16
                  END IF
                  Col&=RGB(Red&,Green&,Blue&) ' make color from red, green and blue
                  hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
                  hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
                  ' draw pie section of circle in specified color
                  PIE hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
                  ' delete pen and brush (very important cleaning up)
                  DeleteObject SelectObject(hDC, hPen)
                  DeleteObject SelectObject(hDC, hBrush)
              NEXT
          NEXT
      END SUB
      '
      '
      SUB ColorExample3(hDC AS LONG)
          LOCAL XX&,YY&,XR&,YR&,hEdit AS LONG
          LOCAL i&,j&,k&,Red&,Green&,Blue&,Col&,Radian!,Radius&,res&,a$
          DIM lpsz AS ASCIIZ * 255
          LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
          LOCAL hPen AS LONG
          LOCAL hBrush AS LONG
          ' Make a suitable narrow font
          TextFont=MakeFont(11,400,0,0,0,"Gill Sans MT Condensed")
          SelectObject hDC, TextFont
          FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
          SetTextAlign hDC,%TA_LEFT '%TA_CENTER
          FOR j&=-7 TO 7
              xLeft  = 2+59*(j&+7)/CF^.3     ' coordinates of rectangle
              xRight = 2+59*(j&+8)/CF^.3
              FOR i&=0 TO 359 STEP 10          ' one 360 degrees turn (color loop)
                  yTop   = 1.28*i&*CF^.015     ' coordinates of rectangle
                  yBottom = yTop + 14
                  CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
                  IF j&<0 THEN ' darken red, green and blue in same proportion
                      Red&=Red&+j&*Red&/8 ' subtract amount (remember: j& is negative)
                      Green&=Green&+j&*Green&/8
                      Blue&=Blue&+j&*Blue&/8
                  END IF
                  IF j&>0 THEN ' lighten red, green and blue in same proportion
                      Red&=Red&+(255-Red&)*j&/8 ' add amount (j& is positive)
                      Green&=Green&+(255-Green&)*j&/8
                      Blue&=Blue&+(255-Blue&)*j&/8
                  END IF
                  Col&=RGB(Red&,Green&,Blue&) ' Make specified color
                  hPen = SelectObject(hDC, CreatePen(0, 0, Col&))
                  hBrush = SelectObject(hDC, CreateSolidBrush (Col&))
                  Rectangle hDC,xLeft,yTop,xRight,yBottom ' draw rectangle in specified color
                  ' delete pen and brush (very important cleaning up)
                  DeleteObject SelectObject(hDC, hPen)
                  DeleteObject SelectObject(hDC, hBrush)
                  ' make text
                  a$=FORMAT$(Red&)+","+FORMAT$(Green&)+","+FORMAT$(Blue&)
                  res&=SetBkColor(hDC,Col&)
                  ' Decide from color if text should be black or white
                  ' This function is suited when transformation to a grey scale is needed.
                  IF Red&*.222+Green&*.707+Blue&*.071>128 THEN  ' Color is light,
                      res&=SetTextColor(hDC, RGB(0,0,0))        ' then text should be black.
                  ELSE                                          ' Color is dark,
                      res&=SetTextColor(hDC, RGB(255,255,255))  ' then text should be white.
                  END IF
                  lpsz=a$
                  ' Write text on top of color rectangle
                  TextOut hDC, xLeft+2,yTop, lpsz, BYVAL LEN(lpsz)
              NEXT
          NEXT
      END SUB
      '
      '
      SUB GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
          SELECT CASE i& 'i& can vary between 0 and 359 (full circle)
              CASE 0 TO 59
                  Red&=(i& MOD 60)*4.25       ' increasing red
                  Green&=255                  ' maximum green
                  Blue&=0                     ' no blue
              CASE 60 TO 119
                  Red&=255                    ' maximum red
                  Green&=255-(i& MOD 60)*4.25 ' decreasing green
                  Blue&=0                     ' no blue
              CASE 120 TO 179
                  Red&=255                    ' maximum red
                  Green&=0                    ' no green
                  Blue&=(i& MOD 60)*4.25      ' increasing blue
              CASE 180 TO 239
                  Red&=255-(i& MOD 60)*4.25   ' decreasing red
                  Green&=0                    ' no green
                  Blue&= 255                  ' maximum blue
              CASE 240 TO 299
                  Red&=0                      ' no red
                  Green&=(i& MOD 60)*4.25     ' increasing green
                  Blue& = 255                 ' maximum blue
              CASE 300 TO 359
                  Red&=0                      ' no red
                  Green&=255                  ' maximum green
                  Blue&=255-(i& MOD 60)*4.25  ' decreasing blue
              CASE ELSE
          END SELECT
      END SUB
      '
      Attached Files

      Comment

      Working...
      X