home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / COLOR.PRG < prev    next >
Text File  |  1993-03-18  |  15KB  |  402 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: COLOR.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 02/25/1993
  5. *-- Notes.....: These routines are color processing routines that are not
  6. *--             in the main procedure file. See README.TXT for details on how
  7. *--             to use this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION ColorOf
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  13. *-- Date........: 01/11/1992
  14. *-- Notes.......: This function will return the color of a specified area
  15. *--               (as built in to dBASE). 
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 01/11/1992 -- Original
  18. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  19. *-- Called by...: Any
  20. *-- Usage.......: ColorOf("<cArea>")
  21. *-- Example.....: ?ColorOf("Messages")
  22. *-- Returns.....: Color (foreground/background)
  23. *-- Parameters..: cArea = Area you wish to return the color of from list:
  24. *--               BOX/BOXES        = Boxes
  25. *--               BORDER/PERIMETER = Border color
  26. *--               NORMAL           = Normal screen/text
  27. *--               HIGHLIGHT        = Highlights
  28. *--               MESSAGE          = Messages
  29. *--               TITLE            = Titles
  30. *--               INFORMATION      = Information
  31. *--               FIELDS           = Fields
  32. *-------------------------------------------------------------------------------
  33.  
  34.     parameters cArea
  35.     
  36.     private cAttrib, cWanted, nPos
  37.     
  38.     cAttrib = set("ATTRIBUTES")
  39.     cWanted = upper(alltrim(cArea))
  40.     
  41.     if cWanted = "BOX"
  42.         nPos = 6
  43.     else
  44.         nPos = at(left(cWanted,4),;
  45.             "    NORM HIGH PERI MESS TITL BOXE INFO FIEL BORD") / 5
  46.         if nPos = 9
  47.             nPos = 3    && "Border" = "Perimeter"
  48.         endif
  49.     endif
  50.     
  51.     do case
  52.         case nPos = 0
  53.             cAttrib = ""  && return null string for error
  54.         case nPos < 4
  55.             cAttrib = left(cAttrib,at("&",cAttrib) - 2)
  56.         otherwise
  57.             cAttrib = substr(cAttrib,at("&",cAttrib) + 3)
  58.             nPos = nPos - 3
  59.     endcase
  60.     do while nPos > 1
  61.         cAttrib = substr(cAttrib,at(",",cAttrib) + 1)
  62.         nPos = nPos - 1
  63.     enddo
  64.     
  65. RETURN left(cAttrib,at(",",cAttrib+",")-1)
  66. *-- EoF: ColorOf()
  67.  
  68. FUNCTION Attribyte
  69. *-------------------------------------------------------------------------------
  70. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  71. *-- Date........: 03/19/1992
  72. *-- Notes.......: Converts a dBASE color code for an area to the corresponding
  73. *--               attribute byte as it is stored in video RAM.
  74. *--               Does not work for monochrome codes and does not check for
  75. *--               validity of color code given.
  76. *-- Written for.: dBASE IV, 1.1
  77. *-- Rev. History: 03/19/1992 -- Original
  78. *-- Calls.......: None
  79. *-- Called by...: Any
  80. *-- Usage.......: Attribyte(<cCode>)
  81. *-- Example.....: ? Attribyte("BG+/B")
  82. *-- Returns.....: Numeric = Attribute byte value, in example 27 (0001 1011b)
  83. *-- Parameters..: cCode = dBase code for colors of an area
  84. *-------------------------------------------------------------------------------
  85.  
  86.     parameters cCode
  87.     private nAttr,cHalf,nSlash
  88.     nSlash=at("/",cCode)
  89.     cHalf=trim(ltrim(iif(nSlash=0,"N",substr(cCode,nSlash+1))))
  90.     nAttr=16*(iif("B" $ cHalf,1,0)+iif("G" $ cHalf,2,0);
  91.       +iif("R" $ cHalf,4,0)+iif("W" $ cHalf,7,0))
  92.     cHalf=trim(ltrim(iif(nSlash=0,cCode,left(cCode,nSlash-1))))
  93.     nAttr=nAttr+iif("B" $ cHalf,1,0)+iif("G" $ cHalf,2,0);
  94.       +iif("R" $ cHalf,4,0)+iif("W" $ cHalf,7,0)
  95.     nAttr=nAttr+iif("+" $ cCode,8,0)+iif("*" $ cCode,128,0)
  96.     
  97. RETURN iif("X" $ cCode, 0, nAttr)
  98. *-- EoF: Attribyte()
  99.  
  100. FUNCTION Colorname
  101. *-------------------------------------------------------------------------------
  102. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  103. *-- Date........: 03/19/1992
  104. *-- Notes.......: Converts an attribute value for an area to the name of the
  105. *--               corresponding color combination, assuming Iscolor() = .T.
  106. *--               Does not check for validity of argument, integer 0<=arg<256
  107. *-- Written for.: dBASE IV, 1.1
  108. *-- Rev. History: 03/19/1992 -- Original
  109. *-- Calls.......: None
  110. *-- Called by...: Any
  111. *-- Usage.......: Colorname(<nAttr>)
  112. *-- Example.....: ? Colorname(27)
  113. *-- Returns.....: Character = Name of color combination, in example
  114. *--                    "bright cyan on blue"
  115. *-- Parameters..: nAttr = value of attribute byte
  116. *-------------------------------------------------------------------------------
  117.  
  118.     parameters nAttr
  119.     private nColr,cName
  120.     cName=iif(nAttr>127,"blinking ","")
  121.     nColr=mod(nAttr,16)
  122.     do case
  123.       case nColr=8
  124.         cName=cName+"gray"
  125.       case nColr=14
  126.         cName=cName+"yellow"
  127.       otherwise
  128.         if nColr>7
  129.           cName=cname+"bright "
  130.         endif
  131.         cName=cName+trim(substr("black  blue   green  cyan   ";
  132.           +"red    magentabrown  white  ",mod(nColr,8)*7+1,7))
  133.     endcase
  134.     nColr = mod(int(nAttr/16),8)
  135.     cName=cName+" on "+trim(substr("black  blue   green  cyan   ";
  136.       +"red    magentabrown  white  ",nColr*7+1,7))
  137.     
  138. RETURN cName
  139. *-- EoF: Colorname()
  140.  
  141. FUNCTION Colorcode
  142. *-------------------------------------------------------------------------------
  143. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  144. *-- Date........: 03/19/1992
  145. *-- Notes.......: Converts an attribute value for an area to the dBase code for
  146. *--               the corresponding color combination, assuming Iscolor() = .T.
  147. *--               Does not check for validity of argument, integer 0<=arg<256
  148. *-- Written for.: dBASE IV, 1.1
  149. *-- Rev. History: 03/19/1992 -- Original
  150. *-- Calls.......: None
  151. *-- Called by...: Any
  152. *-- Usage.......: Colorcode(<nAttr>)
  153. *-- Example.....: ? Colorcode(27)
  154. *-- Returns.....: Character = Code for color combination, in example "BG+/B"
  155. *-- Parameters..: nAttr = value of attribute byte
  156. *-------------------------------------------------------------------------------
  157.  
  158.     parameters nAttr
  159.     private cColrs
  160.     cColrs="N B G BGR RBGRW "
  161.     
  162. RETURN trim(substr(cColrs,mod(nAttr,8)*2+1,2));
  163.   +iif(mod(int(nAttr/8),2)>0,"+","");
  164.   +iif(nAttr>127,"*","")+"/";
  165.   +trim(substr(cColrs,mod(int(nAttr/16),8)*2+1,2))
  166. *-- EoF: Colorcode()
  167.  
  168. PROCEDURE ReColor
  169. *-------------------------------------------------------------------------------
  170. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  171. *-- Date........: 04/23/1992
  172. *-- Notes.......: Restores colors to those held in a string of the form
  173. *--               returned by set("ATTRIBUTE").
  174. *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
  175. *-- Rev. History: 04/23/1992 -- Original
  176. *-- Calls       : None
  177. *-- Called by...: Any
  178. *-- Usage.......: DO ReColor WITH <cColors>
  179. *-- Example.....: DO Recolor WITH OldColors
  180. *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
  181. *-- Side effects: Changes the screen colors.
  182. *-------------------------------------------------------------------------------
  183.  
  184.   parameters cColors
  185.   private cThis, cNext, nAt, cLeft, nX, cAreas
  186.   cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  187.   cLeft = cColors + ", "
  188.   nX = 0
  189.   do while nX < 8
  190.     nX = nX + 1
  191.     cThis = substr( cAreas, 4 * nX, 4 )
  192.     if nX = 3
  193.       nAt = at( "&", cLeft )
  194.       cNext = left( cLeft, nAt - 2 )
  195.       cLeft = substr( cLeft, nAt + 3 )
  196.       SET COLOR TO , , &cNext
  197.     else
  198.       nAt = at( ",", cLeft )
  199.       cNext = left( cLeft, nAt - 1 )
  200.       cLeft = substr( cLeft, nAt + 1 )
  201.       SET COLOR OF &cThis TO &cNext
  202.     endif
  203.   enddo
  204.  
  205. RETURN
  206. *-- EoP: ReColor
  207.  
  208. FUNCTION NormColors
  209. *-------------------------------------------------------------------------------
  210. *-- Programmer..: Jay Parsons       CIS 70160,340
  211. *-- Date........: 02/23/1993
  212. *-- Notes.......: Returns the "normal" portion of a color string
  213. *-- Written for.: dBASE IV, Version 1.5.
  214. *-- Rev. History: 02/23/1993 -- Original Release
  215. *-- Calls.......: None
  216. *-- Called by...: Any
  217. *-- Usage.......: NormColors( <cColor> )
  218. *-- Example.....: ? NormColors( "N/BG,BG+/N,W+/B" )
  219. *-- Parameters..: cColor    -   String holding colors
  220. *-- Returns.....: Character, normal color portion of string.
  221. *-------------------------------------------------------------------------------
  222.         parameters cColor
  223.         private cRet
  224.         cRet = cColor
  225.         if "," $ cRet
  226.           cRet = left( cRet, at( ",", cRet ) - 1 )
  227.         endif
  228. RETURN upper( ltrim( trim ( cRet ) ) )
  229. *-- EoF: NormColors()
  230.  
  231. FUNCTION HighColors
  232. *-------------------------------------------------------------------------------
  233. *-- Programmer..: Jay Parsons       CIS 70160,340
  234. *-- Date........: 02/23/1993
  235. *-- Notes.......: Returns the "highlight" portion of a color string
  236. *-- Written for.: dBASE IV, Version 1.5.
  237. *-- Rev. History: 02/23/1993 -- Original Release
  238. *-- Calls.......: None
  239. *-- Called by...: Any
  240. *-- Usage.......: HighColors( <cColor> )
  241. *-- Example.....: ? HighColors( "N/BG,BG+/N,W+/B" )
  242. *-- Parameters..: cColor    -   String holding colors
  243. *-- Returns.....: Character, highlight color portion of string.
  244. *--               Returns empty string if no such portion.
  245. *-------------------------------------------------------------------------------
  246.         parameters cColor
  247.         private cRet
  248.         cRet = ""
  249.         if "," $ cColor
  250.           cRet = substr( cColor, at( ",",cColor ) + 1 )
  251.           if "," $ cRet
  252.             cRet = left( cRet, at( ",", cRet ) - 1 )
  253.           endif
  254.         endif
  255. RETURN upper( ltrim( trim( cRet ) ) )
  256. *-- EoF: HighColors()
  257.  
  258. FUNCTION BordColors
  259. *-------------------------------------------------------------------------------
  260. *-- Programmer..: Jay Parsons       CIS 70160,340
  261. *-- Date........: 02/23/1993
  262. *-- Notes.......: Returns the "border" portion of a color string
  263. *-- Written for.: dBASE IV, Version 1.5.
  264. *-- Rev. History: 02/23/1993 -- Original Release
  265. *-- Calls       : None
  266. *-- Called by...: Any
  267. *-- Usage.......: BordColors( <cColor> )
  268. *-- Example.....: ? BordColors( "N/BG,BG+/N,W+/B" )
  269. *-- Parameters..: cColor    -   String holding colors
  270. *-- Returns.....: Character, border color portion of string.
  271. *--               Returns empty string if no such portion.
  272. *-------------------------------------------------------------------------------
  273.         parameters cColor
  274.         private cRet
  275.         cRet = ""
  276.         if "," $ cColor
  277.           cRet = substr( cColor, at( ",",cColor ) + 1 )
  278.           if "," $ cRet
  279.             cRet = substr( cRet, at( ",", cRet ) + 1 )
  280.           else
  281.             cRet = ""
  282.           endif
  283.         endif
  284. RETURN upper( ltrim( trim( cRet ) ) )
  285. *-- EoF: BordColors()
  286.  
  287. FUNCTION OppColor
  288. *-------------------------------------------------------------------------------
  289. *-- Programmer..: Jay Parsons       CIS 70160,340
  290. *-- Date........: 02/23/1993
  291. *-- Notes.......: Returns a color "opposite" the one given as its
  292. *--                 parameter.  Assumes iscolor().
  293. *--               You may substitute your own colors in the "cNew" table.
  294. *--                 If you do this, note that if you substitute the same
  295. *--                 color for two or more colors, this function is used
  296. *--                 on both colors and they are the original foreground
  297. *--                 and background colors of some area, you may finish with
  298. *--                 the foreground and background set to the same color.
  299. *--               As furnished, the color returned is the one that would
  300. *--                 result from performing a bitwise NOT on the R, G and B
  301. *--                 bits of the parameter color.  By using this function
  302. *--                 twice, you restore the original color, the technique
  303. *--                 used for animation.
  304. *-- Written for.: dBASE IV, Version 1.5.
  305. *-- Rev. History: 02/23/1993 -- Original Release
  306. *-- Calls.......: None
  307. *-- Called by...: Any
  308. *-- Usage.......: OppColor( <cColor> )
  309. *-- Example.....: ? OppColor( "N" )
  310. *-- Parameters..: cColor    -   String holding color to invert
  311. *-- Returns.....: Character, string holding inverted color
  312. *-------------------------------------------------------------------------------
  313.         parameters cColor
  314.         private nAt, cRet, cOrig, cOld, cNew
  315.  
  316.         * ruler  12345678901234567890123456789012
  317.         cOld =  "   N   B   G   R   BGB GRG RBR W"
  318.         cNew =  "   W   RG  RB  BG  R   B   G   N"
  319.  
  320.         cOrig = cColor
  321.         cRet = ""
  322.         if "*" $ cOrig
  323.           cRet = cRet + "*"
  324.           cOrig = stuff( cOrig, at( "*", cOrig ), 1, "" )
  325.         endif
  326.         if "+" $ cOrig
  327.           cRet = cRet + "+"
  328.           cOrig = stuff( cOrig, at( "+", cOrig ), 1, "" )
  329.         endif
  330.         nAt = 4 * int( at( cOrig, cOld ) / 4 )
  331.         cRet = trim( substr( cNew, nAt, 2 ) ) + cRet
  332.  
  333. RETURN cRet
  334. *-- EoF: OppColor()
  335.  
  336. FUNCTION ForeColor
  337. *-------------------------------------------------------------------------------
  338. *-- Programmer..: Jay Parsons       CIS 70160,340
  339. *-- Date........: 02/24/1993
  340. *-- Notes       : Returns foreground part of color string.
  341. *-- Written for.: dBASE IV, Version 1.5.
  342. *-- Rev. History: 02/24/1993 -- Original Release
  343. *--               03/18/1993 -- bug returning "**" or "++" fixed, Jay Parsons
  344. *-- Calls       : None
  345. *-- Called by...: Any
  346. *-- Usage.......: ForeColor( <cColor> )
  347. *-- Example.....: ? ForeColor( "N/BG" )
  348. *-- Parameters..: cColor    -   String holding color foreground and background
  349. *-- Returns     : Character, string with foreground portion of the color
  350. *-------------------------------------------------------------------------------
  351.         parameters cColor
  352.         private cRet
  353.         cRet = upper( trim( ltrim( cColor ) ) )
  354.         if "/" $ cRet
  355.           cRet = left( cRet, at( "/", cRet ) - 1 )
  356.         endif
  357.         if "*" $ cColor .and. .not. "*" $ cRet
  358.           cRet = cRet + "*"
  359.         endif
  360.         if "+" $ cColor .and. .not. "+" $ cRet
  361.           cRet = cRet + "+"
  362.         endif
  363.  
  364. RETURN cRet
  365. *-- EoF: ForeColor()
  366.  
  367. FUNCTION BackColor
  368. *-------------------------------------------------------------------------------
  369. *-- Programmer..: Jay Parsons       CIS 70160,340
  370. *-- Date........: 02/24/1993
  371. *-- Notes       : Returns background part of color string.
  372. *-- Written for.: dBASE IV, Version 1.5.
  373. *-- Rev. History: 02/04/1993 -- Original Release
  374. *-- Calls       : None
  375. *-- Called by...: Any
  376. *-- Usage.......: BackColor( <cColor> )
  377. *-- Example.....: ? BackColor( "N/BG" )
  378. *-- Parameters..: cColor    -   String holding color foreground and background
  379. *-- Returns     : Character, string with background portion of the color.
  380. *--               Returns empty string if no such portion.
  381. *-------------------------------------------------------------------------------
  382.         parameters cColor
  383.         private cRet
  384.         cRet = upper( trim( ltrim( cColor ) ) )
  385.         if "/" $ cRet
  386.           cRet = substr( cRet, at( "/", cRet ) + 1 )
  387.           if "*" $ cRet
  388.             cRet = stuff( cRet, at( "*", cRet ), 1, "" )
  389.           endif
  390.           if "+" $ cRet
  391.             cRet = stuff( cRet, at( "+", cRet ), 1, "" )
  392.           endif
  393.         else
  394.           cRet = ""
  395.         endif
  396. RETURN upper( ltrim( trim( cRet ) ) )
  397. *-- EoF: BackColor()
  398.  
  399. *-------------------------------------------------------------------------------
  400. *-- EoP: COLOR.PRG
  401. *-------------------------------------------------------------------------------
  402.