INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Usefull Functions & Procedures

Bin - Dec - Hex - RGB Converter by craigsboyd
Posted: 20 Sep 03 (Edited 18 Feb 05)

Slighthaze = NULL



In Thread184-658948 other members and I were discussing the possibilities for converting an RGB value to Hex.  I decided to expand on that and the following is what I came up with, a form class that converts Binary, Decimal, Hexadecimal, and RGB values all at the same time.  (Cut-N-Paste the code below into a prg file and run it from within VFP 7+)

CODE

PUBLIC oForm
oForm = CREATEOBJECT("clsconverter")
oForm.show()

DEFINE CLASS clsconverter AS form

    Top = 0
    Left = 0
    Height = 201
    Width = 337
    DoCreate = .T.
    Caption = "NUMERIC CONVERTER"
    Name = "clsconverter"

    ADD OBJECT txtbin AS textbox WITH ;
        Alignment = 1, ;
        Value = ("0"), ;
        Height = 23, ;
        Left = 108, ;
        TabIndex = 1, ;
        Top = 36, ;
        Width = 204, ;
        Name = "txtBin"

    ADD OBJECT txtdec AS textbox WITH ;
        Alignment = 3, ;
        Value = 0, ;
        Height = 23, ;
        InputMask = "###,###,###,###,###", ;
        Left = 108, ;
        TabIndex = 2, ;
        Top = 72, ;
        Width = 204, ;
        Name = "txtDec"

    ADD OBJECT txtr AS textbox WITH ;
        Alignment = 3, ;
        Value = 0, ;
        Height = 23, ;
        InputMask = "###", ;
        Left = 108, ;
        TabIndex = 4, ;
        Top = 144, ;
        Width = 48, ;
        Name = "txtR"

    ADD OBJECT txtg AS textbox WITH ;
        Alignment = 3, ;
        Value = 0, ;
        Height = 23, ;
        InputMask = "###", ;
        Left = 158, ;
        TabIndex = 5, ;
        Top = 144, ;
        Width = 48, ;
        Name = "txtG"

    ADD OBJECT txtb AS textbox WITH ;
        Alignment = 3, ;
        Value = 0, ;
        Height = 23, ;
        InputMask = "###", ;
        Left = 208, ;
        TabIndex = 6, ;
        Top = 144, ;
        Width = 48, ;
        Name = "txtB"

    ADD OBJECT txthex AS textbox WITH ;
        Alignment = 1, ;
        Value = ("0x0"), ;
        Height = 23, ;
        Left = 108, ;
        TabIndex = 3, ;
        Top = 108, ;
        Width = 204, ;
        Name = "txtHex"

    ADD OBJECT label1 AS label WITH ;
        AutoSize = .T., ;
        BackStyle = 0, ;
        Caption = "Binary", ;
        Height = 17, ;
        Left = 24, ;
        Top = 36, ;
        Width = 36, ;
        Name = "Label1"

    ADD OBJECT label2 AS label WITH ;
        AutoSize = .T., ;
        BackStyle = 0, ;
        Caption = "Decimal", ;
        Height = 17, ;
        Left = 24, ;
        Top = 72, ;
        Width = 48, ;
        Name = "Label2"

    ADD OBJECT label3 AS label WITH ;
        AutoSize = .T., ;
        BackStyle = 0, ;
        Caption = "Hexadecimal", ;
        Height = 17, ;
        Left = 24, ;
        Top = 108, ;
        Width = 74, ;
        Name = "Label3"

    ADD OBJECT label4 AS label WITH ;
        AutoSize = .T., ;
        BackStyle = 0, ;
        Caption = "RGB", ;
        Height = 17, ;
        Left = 24, ;
        Top = 144, ;
        Width = 28, ;
        Name = "Label4"

    ADD OBJECT cmdcolor AS commandbutton WITH ;
        Top = 145, ;
        Left = 259, ;
        Height = 23, ;
        Width = 53, ;
        Caption = "COLOR", ;
        Name = "cmdColor"

    PROCEDURE dec2hex
        LPARAMETERS lnValue
        Return(TRANSFORM(lnValue, '@0'))
    ENDPROC

    PROCEDURE dec2bin
        LPARAMETERS lnValue
        LOCAL cBinString, i, nLen, nVal, TempString, TempVal, cReturnString

        cBinString = ""
        nVal = lnValue

        DO WHILE .T.
            nVal = (nVal / 2)
            If OCCURS(".", transform(nVal)) > 0
              cBinString = cBinString + "1"
              nVal = INT(nVal)
              If nVal < 1
                exit
              EndIf
            Else
              cBinString = cBinString + "0"
               If nVal < 1
                 exit
               EndIf
            EndIf
        ENDDO

        cReturnString = ""
        nLen = Len(cBinString)
        For i = nLen To 1 Step -1
         cReturnString = cReturnString + SUBSTR(cBinString, I, 1)
        ENDFOR

        Return(cReturnString)
    ENDPROC

    PROCEDURE dec2rgb
        LPARAMETERS lnValue
        *!* To give credit where credit is due
        *!* This procedure copied almost verbatim from MS site
        *!* http://support.microsoft.com/default.aspx?scid=http://support.microsoft.com:80/support/kb/articles/Q140/8/48.asp&NoWebContent=1
        
        lTalk=IIF(SET('TALK')='ON',.T.,.F.)
        SET TALK OFF

        * Determine the hexadecimal equivalent of the decimal parameter passed
        lcHex = ""
        lnFactor = 24          && set up factor value one exponent greater than used

        FOR lnPos = 6 TO 1 STEP -1
             lnFactor = lnFactor - 4     && decrement factorial
             lnExp = 2 ^ lnFactor        && extrapolate next least power of two
             FOR lnOrd = 15 TO 1 STEP -1
                  IF lnValue < lnExp            && no value greater than current one,
                       lcHex = lcHex + "0"    && so store a zero in this position
                       EXIT                   && go back for the next value
                  ENDIF
                  IF lnValue >= lnExp * lnOrd  && is value greater than or equal to?
                       * find the matching hex value from its ordinal position
                       lcHex = lcHex + SUBSTR('123456789ABCDEF', lnOrd, 1)
                       EXIT
                  ENDIF
             ENDFOR
             lnValue = lnValue % lnExp     && leave remainder of exponential division
        ENDFOR

        * reverse the order of the individual color indicators
        lcHex = RIGHT(lcHex, 2) + SUBSTR(lcHex, 3, 2) + LEFT(lcHex, 2)

        * convert the pairs into decimal values
        lnPick = 2          && offset to determine which pair to convert
        lcRGB = ""     && start of string delineator

        * parse each color indicator and convert to decimal
        FOR lnColor = 1 TO 3
             lcHue = SUBSTR(lcHex, (lnPick * lnColor) - 1, 2) && pull out color
             lnMSB = ASC(LEFT(lcHue, 1))     && "Most Significant Bit"
             lnLSB = ASC(RIGHT(lcHue, 1))     && "Least Significant Bit"

             * subtract appropriate value from each to get decimal equivalent
             lnMSB = lnMSB - IIF(lnMSB > 57, 55, 48)
             lnLSB = lnLSB - IIF(lnLSB > 57, 55, 48)

             * then add decimals together
             lcRGB = lcRGB + TRANSFORM( lnMSB * 16 + lnLSB, '999') + ", "
        ENDFOR
        lcRGB = LEFT(lcRGB, LEN(lcRGB) - 2)
        RETURN ALLTRIM(lcRGB)
    ENDPROC

    PROCEDURE hex2dec
        LPARAMETERS lcValue

        RETURN(VAL(ALLTRIM(lcValue)))
    ENDPROC

    PROCEDURE bin2dec
        LPARAMETERS lcValue
        LOCAL i, nLen, nReturn, nPower
        lcValue = ALLTRIM(lcValue)
        nReturn = 0
        nLen =LEN(lcValue) - 1
        FOR i = 1 TO nLen
            nPower = nLen - i + 1
            IF SUBSTR(lcValue,i,1) = "1"
                nReturn = nReturn + (2 ^ nPower)
            ENDIF
        ENDFOR
        nReturn = nReturn + VAL(RIGHT(lcValue,1))

        return(nReturn)
    ENDPROC

    PROCEDURE rgb2dec
        LPARAMETERS nlRValue, nlGValue, nlBValue
        return(RGB(nlRValue, nlGValue, nlBValue))
    ENDPROC

    PROCEDURE txtbin.InteractiveChange
        LOCAL lnValue, lcValue
        if LEN(ALLTRIM(this.Value)) < 1
            this.Value = "0"
        ENDIF
        lnValue = thisform.bin2dec(this.Value)
        thisform.txtDec.value = lnValue
        thisform.txthex.value = thisform.dec2hex(lnValue)
        lcValue = thisform.dec2rgb(lnValue)
        thisform.txtR.value = VAL(GETWORDNUM(lcValue, 1, ","))
        thisform.txtG.value = VAL(GETWORDNUM(lcValue, 2, ","))
        thisform.txtB.value = VAL(GETWORDNUM(lcValue, 3, ","))
    ENDPROC

    PROCEDURE txtdec.InteractiveChange
        LOCAL lnValue, lcValue
        lnValue = this.value
        thisform.txtBin.value = thisform.dec2bin(lnValue)
        thisform.txthex.value = thisform.dec2hex(lnValue)
        lcValue = thisform.dec2rgb(lnValue)
        thisform.txtR.value = VAL(GETWORDNUM(lcValue, 1, ","))
        thisform.txtG.value = VAL(GETWORDNUM(lcValue, 2, ","))
        thisform.txtB.value = VAL(GETWORDNUM(lcValue, 3, ","))
    ENDPROC

    PROCEDURE txtdec.RangeLow
        RETURN 0
    ENDPROC

    PROCEDURE txtdec.GotFocus
        ON READERROR MESSAGEBOX("Negative entries are not allowed")
    ENDPROC

    PROCEDURE txtdec.LostFocus
        ON READERROR
    ENDPROC

    PROCEDURE txtr.InteractiveChange
        LOCAL lnValue
        lnValue = thisform.rgb2dec(thisform.txtR.Value,thisform.txtG.Value, thisform.txtB.Value)
        thisform.txtDec.value = lnValue
        thisform.txtBin.value = thisform.dec2bin(lnValue)
        thisform.txthex.value = thisform.dec2hex(lnValue)
    ENDPROC

    PROCEDURE txtr.LostFocus
        ON READERROR
    ENDPROC

    PROCEDURE txtr.GotFocus
        ON READERROR MESSAGEBOX("Valid Entry 0 - 255")
    ENDPROC

    PROCEDURE txtr.RangeHigh
        RETURN 255
    ENDPROC

    PROCEDURE txtr.RangeLow
        RETURN 0
    ENDPROC

    PROCEDURE txtg.InteractiveChange
        LOCAL lnValue
        lnValue = thisform.rgb2dec(thisform.txtR.Value,thisform.txtG.Value, thisform.txtB.Value)
        thisform.txtDec.value = lnValue
        thisform.txtBin.value = thisform.dec2bin(lnValue)
        thisform.txthex.value = thisform.dec2hex(lnValue)
    ENDPROC

    PROCEDURE txtg.RangeLow
        RETURN 0
    ENDPROC

    PROCEDURE txtg.RangeHigh
        RETURN 255
    ENDPROC

    PROCEDURE txtg.GotFocus
        ON READERROR MESSAGEBOX("Valid Entry 0 - 255")
    ENDPROC

    PROCEDURE txtg.LostFocus
        ON READERROR
    ENDPROC

    PROCEDURE txtb.InteractiveChange
        LOCAL lnValue
        lnValue = thisform.rgb2dec(thisform.txtR.Value,thisform.txtG.Value, thisform.txtB.Value)
        thisform.txtDec.value = lnValue
        thisform.txtBin.value = thisform.dec2bin(lnValue)
        thisform.txthex.value = thisform.dec2hex(lnValue)
    ENDPROC

    PROCEDURE txtb.RangeLow
        RETURN 0
    ENDPROC

    PROCEDURE txtb.RangeHigh
        RETURN 255
    ENDPROC

    PROCEDURE txtb.LostFocus
        ON READERROR
    ENDPROC

    PROCEDURE txtb.GotFocus
        ON READERROR MESSAGEBOX("Valid Entry 0 - 255")
    ENDPROC

    PROCEDURE txthex.InteractiveChange
        LOCAL lnValue
        if LEN(ALLTRIM(this.Value)) < 3 OR LEFT(ALLTRIM(this.Value),2) != "0x"
            this.Value = "0x0"
        ENDIF

        lnValue = thisform.hex2dec(this.Value)
        thisform.txtDec.value = lnValue
        thisform.txtBin.value = thisform.dec2bin(lnValue)
        lcValue = thisform.dec2rgb(lnValue)
        thisform.txtR.value = VAL(GETWORDNUM(lcValue, 1, ","))
        thisform.txtG.value = VAL(GETWORDNUM(lcValue, 2, ","))
        thisform.txtB.value = VAL(GETWORDNUM(lcValue, 3, ","))
    ENDPROC

    PROCEDURE cmdcolor.Click
        LOCAL lnValue, lcValue
        lnValue = GETCOLOR()
        IF lnValue >= 0
            thisform.txtDec.value = lnValue
            thisform.txtbin.value = thisform.dec2bin(lnValue)
            thisform.txthex.value = thisform.dec2hex(lnValue)
            lcValue = thisform.dec2rgb(lnValue)
            thisform.txtR.value = VAL(GETWORDNUM(lcValue, 1, ","))
            thisform.txtG.value = VAL(GETWORDNUM(lcValue, 2, ","))
            thisform.txtB.value = VAL(GETWORDNUM(lcValue, 3, ","))
        ENDIF
    ENDPROC

ENDDEFINE

Back to Microsoft: Visual FoxPro FAQ Index
Back to Microsoft: Visual FoxPro Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close