home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / code / grafik / backgr / backgrnd.bas < prev    next >
Encoding:
BASIC Source File  |  1994-09-22  |  17.2 KB  |  380 lines
  1. '****************************************************************************
  2. '*                                                                          *
  3. '*      Module Name: BackGround                                             *
  4. '*                                                                          *
  5. '*             Created:              By:Michael McCarthy                    *
  6. '*            Modified:              By:                                    *
  7. '*                                                                          *
  8. '*            Comments:                                                     *
  9. '*  This module contains 4 functions that draw and create gradiant bitmaps  *
  10. '****************************************************************************
  11. '
  12. Option Explicit
  13.  
  14.  
  15. 'These variables are used by the two forms to save the current custom colors
  16.     Global glngFrom&
  17.     Global glngTo&
  18.  
  19. 'This is the structure of a BitMap File Header
  20.     Type BITMAPmudtFileHeader
  21.     bfType As Integer
  22.     bfSize As Long
  23.     bfReserved1 As Integer
  24.     bfReserved2 As Integer
  25.     bfOffBits As Long
  26.     End Type
  27.  
  28. 'This is the structure of a bitmap header
  29.     Type BITMAPINFOHEADER '40 bytes
  30.     biSize As Long
  31.     biWidth As Long
  32.     biHeight As Long
  33.     biPlanes As Integer
  34.     biBitCount As Integer
  35.     biCompression As Long
  36.     biSizeImage As Long
  37.     bixPelsPerMeter As Long
  38.     biyPelsPerMeter As Long
  39.     biClrUsed As Long
  40.     biclrImportant As Long
  41.     End Type
  42.  
  43. 'Scratch variable
  44.     Dim mintReply%
  45.  
  46. 'This is the where the File Header and Bitmap header
  47. 'get compiled to be written out to the file
  48.     Dim mstrFileInfo As String * 54
  49.  
  50. 'These are the two header variables variables
  51.     Dim mudtFileHeader As BITMAPmudtFileHeader
  52.     Dim mudtBInfo As BITMAPINFOHEADER
  53.  
  54. '********************************************************************************
  55. '*                                                                              *
  56. '*      Function Name: CheckQB                                                  *
  57. '*                                                                              *
  58. '*             Created:              By:Michael McCarthy                        *
  59. '*            Modified:              By:                                        *
  60. '*                                                                              *
  61. '*          Parameters:                                                         *
  62. '*                                                                              *
  63. '*             Returns:                                                         *
  64. '*                      True        -   If color is a QBColor                   *
  65. '*                      False       -   If color is NOT a QBColor               *
  66. '*                                                                              *
  67. '*            Comments:                                                         *
  68. '*  When selecting gradiants that are close to one of the 20 system colors      *
  69. '*  (QBColor's) the RGB function will return a best match of the System color   *
  70. '*  instead of one of the mapped colors.  For this reason this function will    *
  71. '*  Let the DrawBackGround function know if a QBColor has been choosen.  This   *
  72. '*  allows the DrawBackGround function to minimize banding.                     *
  73. '********************************************************************************
  74. '
  75. Function CheckQB (ByVal lngColor&) As Integer
  76.  
  77. On Error GoTo CheckQBError
  78.  
  79. Dim mblnReturn%
  80.  
  81. mblnReturn = False
  82.  
  83. Select Case lngColor
  84.     Case QBColor(1): mblnReturn = True
  85.     Case QBColor(2): mblnReturn = True
  86.     Case QBColor(3): mblnReturn = True
  87.     Case QBColor(4): mblnReturn = True
  88.     Case QBColor(5): mblnReturn = True
  89.     Case QBColor(6): mblnReturn = True
  90.     Case QBColor(7): mblnReturn = True
  91.     Case QBColor(8): mblnReturn = True
  92.     Case QBColor(9): mblnReturn = True
  93.     Case QBColor(10): mblnReturn = True
  94.     Case QBColor(11): mblnReturn = True
  95.     Case QBColor(13): mblnReturn = True
  96.     Case QBColor(14): mblnReturn = True
  97.     Case QBColor(15): mblnReturn = True
  98. End Select
  99.  
  100. CheckQB = mblnReturn
  101.  
  102. Exit Function
  103. CheckQBError:
  104.     CheckQB = True
  105.     Exit Function
  106. End Function
  107.  
  108. '****************************************************************************
  109. '*                                                                          *
  110. '*      Procedure Name: CreateBitMap                                        *
  111. '*                                                                          *
  112. '*             Created:              By:Michael McCarthy                    *
  113. '*            Modified:              By:                                    *
  114. '*                                                                          *
  115. '*          Parameters:                                                     *
  116. '*                  vintNumColors   -   Number of Colors to create          *
  117. '*                  vlngFrom        -   The starting color                  *
  118. '*                  vlngTo          -   The ending color                    *
  119. '*                                                                          *
  120. '*             Returns:                                                     *
  121. '*                      True        -   If successful                       *
  122. '*                      False       -   If unsuccessful                     *
  123. '*                                                                          *
  124. '*            Comments:                                                     *
  125. '*  This function will create a 1 pixel bitmap with a color palette defined *
  126. '* by the passed parameters.                                                *
  127. '****************************************************************************
  128. '
  129. Function CreateBitmap (ByVal vintNumColors%, ByVal vlngFrom&, ByVal vlngTo&) As Integer
  130.  
  131. On Error GoTo SaveError
  132.  
  133. Dim i%
  134. Dim dblStepRed#, dblStepBlue#, dblStepGreen#
  135. Dim dblRed#, dblBlue#, dblGreen#
  136. Dim strColor$
  137.  
  138. 'Find the individual Red, Green and Blue values for the starting color
  139.     dblRed = (vlngFrom And 255)
  140.     dblGreen = (Int(vlngFrom / 256) And 255)
  141.     dblBlue = (Int(vlngFrom / 65536) And 255)
  142.  
  143. 'Find the step values for each color for the number of colors passed
  144.     dblStepRed = ((vlngTo And 255) - dblRed) / vintNumColors
  145.     dblStepGreen = ((Int(vlngTo / 256) And 255) - dblGreen) / vintNumColors
  146.     dblStepBlue = ((Int(vlngTo / 65536) And 255) - dblBlue) / vintNumColors
  147.  
  148. i = 0
  149. Do
  150. 'Create color, Colors are stored Blue, Green, Red
  151.     strColor = strColor & Chr(dblBlue And 255) & Chr(dblGreen And 255) & Chr(dblRed And 255) & Chr(0) 'Red
  152.     
  153. 'Add the step value to each color segment
  154.     dblBlue = dblBlue + dblStepBlue
  155.     dblGreen = dblGreen + dblStepGreen
  156.     dblRed = dblRed + dblStepRed
  157.     i = i + 1
  158. Loop Until i >= vintNumColors
  159.  
  160. 'Fill the Bitmap header with the appropriate values
  161.     mudtBInfo.biSize = 40               ' Size of Header in Bytes
  162.     mudtBInfo.biWidth = 1               ' Width of Bitmap in Pixels
  163.     mudtBInfo.biHeight = 1              ' Height of Bitmap in Pixels
  164.     mudtBInfo.biPlanes = 1              ' Number of Planes
  165.     mudtBInfo.biBitCount = 8            ' Number of Color Bits per Pixel
  166.     mudtBInfo.biCompression = 0         ' Compression Style
  167.     mudtBInfo.biSizeImage = (mudtBInfo.biWidth * mudtBInfo.biHeight) * 4    ' Size of Bitmap in bytes (4 bytes per pixel)
  168.     mudtBInfo.bixPelsPerMeter = 0       ' Pixels Per Meter x
  169.     mudtBInfo.biyPelsPerMeter = 0       ' Pixelx Per Meter y
  170.     mudtBInfo.biClrUsed = vintNumColors ' Number of colors in Bitmap
  171.     mudtBInfo.biclrImportant = 0        ' Number of Important Colors (0 means all important)
  172.  
  173. 'Fill the File header with the appropriate information
  174.     mudtFileHeader.bfType = 19778       '   File Type   'BM' - Bitmap
  175. 'Number of bytes in the file
  176.     mudtFileHeader.bfSize = Len(mudtFileHeader) + Len(mudtBInfo) + Len(strColor) + mudtBInfo.biSizeImage  ' frmPalette.txtFile(2)
  177.     mudtFileHeader.bfReserved1 = 0
  178.     mudtFileHeader.bfReserved2 = 0
  179. 'Number of Bytes where bitmap actually starts in the file
  180.     mudtFileHeader.bfOffBits = Len(strColor) + Len(mudtFileHeader) + Len(mudtBInfo)
  181.  
  182. 'Now fill the string with all the bitmap information
  183.     Mid(mstrFileInfo, 15, 4) = GetAscii(mudtBInfo.biSize, 4)
  184.     Mid(mstrFileInfo, 19, 4) = GetAscii(mudtBInfo.biWidth, 4)
  185.     Mid(mstrFileInfo, 23, 4) = GetAscii(mudtBInfo.biHeight, 4)
  186.     Mid(mstrFileInfo, 27, 2) = GetAscii(mudtBInfo.biPlanes, 2)
  187.     Mid(mstrFileInfo, 29, 2) = GetAscii(mudtBInfo.biBitCount, 2)
  188.     Mid(mstrFileInfo, 31, 4) = GetAscii(mudtBInfo.biCompression, 4)
  189.     Mid(mstrFileInfo, 35, 4) = GetAscii(mudtBInfo.biSizeImage, 4)
  190.     Mid(mstrFileInfo, 39, 4) = GetAscii(mudtBInfo.bixPelsPerMeter, 4)
  191.     Mid(mstrFileInfo, 43, 4) = GetAscii(mudtBInfo.biyPelsPerMeter, 4)
  192.     Mid(mstrFileInfo, 47, 4) = GetAscii(mudtBInfo.biClrUsed, 4)
  193.     Mid(mstrFileInfo, 51, 4) = GetAscii(mudtBInfo.biclrImportant, 4)
  194.                 
  195.     Mid(mstrFileInfo, 1, 2) = GetAscii(mudtFileHeader.bfType, 2)
  196.     Mid(mstrFileInfo, 3, 4) = GetAscii(mudtFileHeader.bfSize, 4)
  197.     Mid(mstrFileInfo, 7, 2) = GetAscii(mudtFileHeader.bfReserved1, 2)
  198.     Mid(mstrFileInfo, 9, 2) = GetAscii(mudtFileHeader.bfReserved2, 2)
  199.     Mid(mstrFileInfo, 11, 4) = GetAscii(mudtFileHeader.bfOffBits, 4)
  200.     
  201. 'At this point I choose to save the bitmap in the current directory
  202. 'Hopefully for immediate use, but the file can be saved anywhere
  203.     Open "custom.bmp" For Output As 1
  204.     Print #1, mstrFileInfo & strColor & Chr(0) & Chr(0) & Chr(0) & Chr(0)
  205.     Close
  206.  
  207.     CreateBitmap = True
  208. Exit Function
  209. SaveError:
  210.     Close
  211.     CreateBitmap = False
  212.     Exit Function
  213. End Function
  214.  
  215. '********************************************************************************
  216. '*                                                                              *
  217. '*      Procedure Name: DrawBackGround                                          *
  218. '*                                                                              *
  219. '*             Created:              By:Michael McCarthy                        *
  220. '*            Modified:              By:                                        *
  221. '*                                                                              *
  222. '*          Parameters:                                                         *
  223. '*                      rfrmForm    -   The form to paint                       *
  224. '*                      rstrText    -   Any text to print on the form           *
  225. '*                      vlngFrom    -   The starting color of the fill          *
  226. '*                      vlngTo      -   The ending color of the fill            *
  227. '*                      vintStyle   -   The style of the background             *
  228. '*                      vintStep    -   Number of Gradiant Steps in fill        *
  229. '*                                                                              *
  230. '*            Comments:                                                         *
  231. '*  This procedure performs a gradient fill on the background of a form shading *
  232. '*  it from the color in vlngFrom to the color in vlngTo.                       *
  233. '*  For the best effect the form should contain a picture with a pallette of    *
  234. '*  all the gradient values.  (See CreateBitmap)                                *
  235. '********************************************************************************
  236. '
  237. Sub DrawBackGround (rfrmForm As Form, rstrText$, ByVal vlngFrom&, ByVal vlngTo&, ByVal vintStyle%, ByVal vintStep%)
  238.  
  239. Dim i%
  240.  
  241. Dim lngGradColor&, lngLastColor&
  242. Dim dblWidth#, dblHeight#, dblStepHeight#, dblStepWidth#
  243. Dim dblRed#, dblBlue#, dblGreen#
  244. Dim dblStepRed#, dblStepBlue#, dblStepGreen#
  245.  
  246. On Error Resume Next
  247.  
  248. 'Find the Gradiant Starting and Step Values
  249.     dblRed = (vlngFrom And 255)
  250.     dblGreen = (Int(vlngFrom / 256) And 255)
  251.     dblBlue = (Int(vlngFrom / 65536) And 255)
  252.  
  253.     dblStepRed = ((vlngTo And 255) - dblRed) / vintStep
  254.     dblStepGreen = ((Int(vlngTo / 256) And 255) - dblGreen) / vintStep
  255.     dblStepBlue = ((Int(vlngTo / 65536) And 255) - dblBlue) / vintStep
  256.     
  257.     rfrmForm.ScaleMode = 3              'Scalemode set to pixels
  258.     rfrmForm.DrawStyle = 6              'DrawStyle set to Inside Solid
  259.     rfrmForm.AutoRedraw = True          'Make form redraw itself
  260.  
  261. 'Find the Number of Pixels for the number of steps
  262.     dblWidth = rfrmForm.ScaleWidth / vintStep
  263.     dblHeight = rfrmForm.ScaleHeight / vintStep
  264.  
  265. 'Set DrawWidth to to the maximum Pixel Size
  266.     If dblHeight > dblWidth Then
  267.     rfrmForm.DrawWidth = dblHeight + 1
  268.     Else
  269.     rfrmForm.DrawWidth = dblWidth + 1
  270.     End If
  271.  
  272. 'If this is the circle method add 2 to cover defects
  273.     If vintStyle = 4 Then rfrmForm.DrawWidth = rfrmForm.DrawWidth + 2
  274.     
  275. 'Set BackGround to the major color
  276.     rfrmForm.BackColor = vlngFrom
  277.     lngGradColor = vlngFrom
  278.  
  279. 'Cycle through all the steps and draw the appropriate pattern
  280.     For i = 1 To vintStep + 1
  281.     lngLastColor = lngGradColor
  282.     lngGradColor = (dblBlue And 255) * 65536 + Int(dblGreen And 255) * 256 + Int(dblRed And 255)
  283.     
  284.     If CheckQB(lngGradColor) Then
  285.         lngGradColor = lngLastColor
  286.         lngLastColor = (dblBlue And 255) * 65536 + Int(dblGreen And 255) * 256 + Int(dblRed And 255)
  287.     End If
  288.  
  289.     dblRed = dblRed + dblStepRed
  290.     dblBlue = dblBlue + dblStepBlue
  291.     dblGreen = dblGreen + dblStepGreen
  292.  
  293.     'Compute the current Step
  294.     dblStepHeight = (i - 1) * dblHeight
  295.     dblStepWidth = (i - 1) * dblWidth
  296.     Select Case Int(vintStyle):
  297.         Case 0: 'Top to Bottom
  298.         rfrmForm.Line (0, dblStepHeight)-(rfrmForm.ScaleWidth, dblStepHeight), lngGradColor
  299.         Case 1: 'Top Left corner to Bottom Right Corner
  300.         rfrmForm.Line (0, dblStepHeight)-(dblStepWidth, 0), lngGradColor
  301.         rfrmForm.Line (rfrmForm.ScaleWidth, rfrmForm.ScaleHeight - dblStepHeight)-(rfrmForm.ScaleWidth - dblStepWidth, rfrmForm.ScaleHeight), lngGradColor
  302.         Case 2: 'Top Right corner to Bottom Left Corner
  303.         rfrmForm.Line (rfrmForm.ScaleWidth - dblStepWidth, 0)-(rfrmForm.ScaleWidth, dblStepHeight), lngGradColor
  304.         rfrmForm.Line (0, rfrmForm.ScaleHeight - dblStepHeight)-(dblStepWidth, rfrmForm.ScaleHeight), lngGradColor
  305.         Case 3: 'Edge to Center Square
  306.         rfrmForm.Line (dblStepWidth / 2, dblStepHeight / 2)-(rfrmForm.ScaleWidth - dblStepWidth / 2, dblStepHeight / 2), lngGradColor
  307.         rfrmForm.Line (dblStepWidth / 2, dblStepHeight / 2)-(dblStepWidth / 2, rfrmForm.ScaleHeight - dblStepHeight / 2), lngGradColor
  308.         rfrmForm.Line (dblStepWidth / 2, rfrmForm.ScaleHeight - dblStepHeight / 2)-(rfrmForm.ScaleWidth - dblStepWidth / 2, rfrmForm.ScaleHeight - dblStepHeight / 2), lngGradColor
  309.         rfrmForm.Line (rfrmForm.ScaleWidth - dblStepWidth / 2, dblStepHeight / 2)-(rfrmForm.ScaleWidth - dblStepWidth / 2, rfrmForm.ScaleHeight - dblStepHeight / 2), lngGradColor
  310.         Case 4: 'Edge to Center Circle
  311.         rfrmForm.Circle (rfrmForm.ScaleWidth / 2, rfrmForm.ScaleHeight / 2), dblStepHeight, lngGradColor
  312.     End Select
  313.     Next
  314.     
  315. 'Background is drawn now put text on form
  316.     rfrmForm.ScaleMode = 2          'Scalemode set to Point
  317.     rfrmForm.FontSize = rfrmForm.ScaleWidth / 18
  318.     rfrmForm.FontBold = True
  319.     rfrmForm.FontItalic = False
  320.     rfrmForm.FontName = "Times New Roman"
  321.  
  322. 'Print the passed text
  323.     rfrmForm.CurrentY = 10
  324.     rfrmForm.CurrentX = 10
  325.     rfrmForm.ForeColor = QBColor(0)
  326.     rfrmForm.Print " " + rstrText + Str(vintStyle)
  327.  
  328. 'Offset the text for a shadowed effect
  329.     rfrmForm.CurrentY = 8
  330.     rfrmForm.CurrentX = 8
  331.     rfrmForm.ForeColor = QBColor(15)
  332.     rfrmForm.Print " " + rstrText + Str(vintStyle)
  333.  
  334. End Sub
  335.  
  336. '****************************************************************************
  337. '*                                                                          *
  338. '*      Function Name: GetAscii                                             *
  339. '*                                                                          *
  340. '*             Created:              By:Michael McCarthy                    *
  341. '*            Modified:              By:                                    *
  342. '*                                                                          *
  343. '*          Parameters:                                                     *
  344. '*                      rvntNum     -   Number to Convert                   *
  345. '*                      rintBytes   -   Number of bytes to convert to       *
  346. '*                                                                          *
  347. '*             Returns:                                                     *
  348. '*                      -   The converted string or null if unsuccessful    *
  349. '*                                                                          *
  350. '*            Comments:                                                     *
  351. '*  This funciton accepts a number and converts it to a string that can be  *
  352. '*  saved out to a file.  It converts the number using Hi/Lo format.        *
  353. '****************************************************************************
  354. '
  355. Function GetAscii (rvntNum As Variant, rintBytes%) As String
  356.  
  357. On Error GoTo GetAsciiError
  358.  
  359. Dim i%
  360. Dim lngNum As Long
  361. Dim strTemp As String * 4
  362.  
  363. i = 1
  364. lngNum = rvntNum
  365.  
  366. Do
  367.     Mid(strTemp, i, 1) = Chr(lngNum And 255)
  368.     lngNum = lngNum \ 256
  369.     i = i + 1
  370. Loop Until i > rintBytes
  371.  
  372. GetAscii = Left(strTemp, rintBytes)
  373.  
  374. Exit Function
  375. GetAsciiError:
  376.     GetAscii = ""
  377.     Exit Function
  378. End Function
  379.  
  380.