home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Real_Jigsa2028661132006.psc / clsGradient.cls < prev    next >
Text File  |  2006-10-31  |  15KB  |  452 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsGradient"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. 'Property Storage Variables
  17. Private mlColor1    As Long
  18. Private mlColor2    As Long
  19. Private mfAngle     As Single
  20.  
  21. 'Property Default Constants - Colors and Angle match Kath-Rock logo.
  22. Private Const mlDefColor1   As Long = &HFFFFD0  'Very Light Blue
  23. Private Const mlDefColor2   As Long = &H400000  'Very Dark Blue
  24. Private Const mfDefAngle    As Single = 315     'Upper-Left to Lower-Right
  25.  
  26. 'Misc Constants
  27. Private Const PI    As Double = 3.14159265358979
  28. Private Const RADS  As Double = PI / 180    '<Degrees> * RADS = radians
  29.  
  30. 'TypeDefs
  31. Private Type PointSng   'Internal Point structure
  32.     x   As Single       'Uses Singles for more precision.
  33.     y   As Single
  34. End Type
  35.  
  36. Private Type PointAPI   'API Point structure
  37.     x   As Long
  38.     y   As Long
  39. End Type
  40.  
  41. Private Type RectAPI    'API Rect structure
  42.     Left    As Long
  43.     Top     As Long
  44.     Right   As Long
  45.     Bottom  As Long
  46. End Type
  47.  
  48. 'API functions and Constants
  49. Private Const PS_SOLID As Long = 0  'Solid Pen Style (Used for CreatePen())
  50. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  51. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  52. Private Declare Function GetClientRect Lib "User32" (ByVal hWnd As Long, lpRect As RectAPI) As Long
  53. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  54. Private Declare Function GetSysColor Lib "User32" (ByVal nIndex As Long) As Long
  55. Private Declare Function GetTickCount Lib "kernel32" () As Long
  56. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  57. Private Declare Function LockWindowUpdate Lib "User32" (ByVal hWndLock As Long) As Long
  58. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As PointAPI) As Long
  59. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  60.  
  61. Public Function Draw(picObj As Object) As Boolean
  62.  
  63. 'Note: This class uses API functions to draw. If the
  64. '      destination object is in AutoRedraw mode, the
  65. '      Refresh method for that object must be invoked.
  66.  
  67. 'picObj can be a Form or PictureBox.
  68.  
  69. Dim lRet    As Long
  70. Dim lIdx    As Long
  71. Dim lTime   As Long
  72. Dim uRect   As RectAPI
  73.  
  74. '    lTime = GetTickCount()
  75.     
  76.     On Error GoTo LocalError
  77.     
  78.     'Stop the window from updating until we're finished.
  79.     lRet = LockWindowUpdate(picObj.hWnd)
  80.     
  81.     'Get the client rect in pixels
  82.     lRet = GetClientRect(picObj.hWnd, uRect)
  83.     
  84.     'Test for possible errors (GetClientRect failure or Rect < 2 pixels)
  85.     If lRet <> 0 Then
  86.         If uRect.Right > 1 And uRect.Bottom > 1 Then
  87.             lIdx = DrawGradient(picObj.hdc, uRect.Right, uRect.Bottom)
  88.             Draw = (lIdx > 0)
  89.         End If
  90.     End If
  91.     
  92.     'My P3-500 took 99 millisecs (.099 secs) to create and draw 2554 diagonal
  93.     'lines at 315 degrees. That was frmDemo maximized on a 1280 x 1024 screen.
  94.     'At this speed I can redraw an entire 1280px. screen over 10 times per second.
  95.     
  96.     'Same size rect at a 0 degree angle took 48 millisecs (.048 secs) to create and
  97.     'draw 1278 lines. This speed can redraw a 1280px. screen 20 times per second.
  98.     
  99.     'Uncomment the two lines below and the lTime line at the top
  100.     'of this function to test the times on your PC.
  101.     
  102. '    lTime = GetTickCount() - lTime
  103. '    MsgBox CStr(lIdx / 2) & " lines drawn in " & CStr(lTime) & " milliseconds"
  104.         
  105. NormalExit:
  106.     'Unlock the window to allow it to update now.
  107.     lRet = LockWindowUpdate(0)
  108.     Exit Function
  109.     
  110. LocalError:
  111.     MsgBox Err.Description, vbExclamation
  112.     Resume NormalExit
  113.  
  114. End Function
  115. Public Function BlendColors(ByVal lColor1 As Long, ByVal lColor2 As Long, ByVal lSteps As Long, laRetColors() As Long) As Long
  116.  
  117. 'Creates an array of colors blending from
  118. 'Color1 to Color2 in lSteps number of steps.
  119. 'Returns the count and fills the laRetColors() array.
  120.  
  121. Dim lIdx    As Long
  122. Dim lRed    As Long
  123. Dim lGrn    As Long
  124. Dim lBlu    As Long
  125. Dim fRedStp As Single
  126. Dim fGrnStp As Single
  127. Dim fBluStp As Single
  128.  
  129.     'Stop possible error
  130.     If lSteps < 2 Then lSteps = 2
  131.     
  132.     'Extract Red, Blue and Green values from the start and end colors.
  133.     lRed = (lColor1 And &HFF&)
  134.     lGrn = (lColor1 And &HFF00&) / &H100
  135.     lBlu = (lColor1 And &HFF0000) / &H10000
  136.     
  137.     'Find the amount of change for each color element per color change.
  138.     fRedStp = Div(CSng((lColor2 And &HFF&) - lRed), CSng(lSteps))
  139.     fGrnStp = Div(CSng(((lColor2 And &HFF00&) / &H100&) - lGrn), CSng(lSteps))
  140.     fBluStp = Div(CSng(((lColor2 And &HFF0000) / &H10000) - lBlu), CSng(lSteps))
  141.     
  142.     'Create the colors
  143.     ReDim laRetColors(lSteps - 1)
  144.     laRetColors(0) = lColor1            'First Color
  145.     laRetColors(lSteps - 1) = lColor2   'Last Color
  146.     For lIdx = 1 To lSteps - 2          'All Colors between
  147.         laRetColors(lIdx) = CLng(lRed + (fRedStp * CSng(lIdx))) + _
  148.             (CLng(lGrn + (fGrnStp * CSng(lIdx))) * &H100&) + _
  149.             (CLng(lBlu + (fBluStp * CSng(lIdx))) * &H10000)
  150.     Next lIdx
  151.     
  152.     'Return number of colors in array
  153.     BlendColors = lSteps
  154.  
  155. End Function
  156. Private Function DrawGradient(ByVal hdc As Long, ByVal lWidth As Long, ByVal lHeight As Long) As Long
  157.  
  158. Dim bDone       As Boolean
  159. Dim iIncX       As Integer
  160. Dim iIncY       As Integer
  161. Dim lIdx        As Long
  162. Dim lRet        As Long
  163. Dim hPen        As Long
  164. Dim hOldPen     As Long
  165. Dim lPointCnt   As Long
  166. Dim laColors()  As Long
  167. Dim fMovX       As Single
  168. Dim fMovY       As Single
  169. Dim fDist       As Single
  170. Dim fAngle      As Single
  171. Dim fLongSide   As Single
  172. Dim uTmpPt      As PointAPI
  173. Dim uaPts()     As PointAPI
  174. Dim uaTmpPts()  As PointSng
  175.     
  176.     On Error GoTo LocalError
  177.     
  178.     'Start with center of rect
  179.     ReDim uaTmpPts(2)
  180.     uaTmpPts(2).x = Int(lWidth / 2)
  181.     uaTmpPts(2).y = Int(lHeight / 2)
  182.     
  183.     'Calc distance to furthest edge as if rect were square
  184.     fLongSide = IIf(lWidth > lHeight, lWidth, lHeight)
  185.     fDist = (Sqr((fLongSide ^ 2) + (fLongSide ^ 2)) + 2) / 2
  186.     
  187.     'Create points to the left and the right at a 0║ angle (horizontal)
  188.     uaTmpPts(0).x = uaTmpPts(2).x - fDist
  189.     uaTmpPts(0).y = uaTmpPts(2).y
  190.     uaTmpPts(1).x = uaTmpPts(2).x + fDist
  191.     uaTmpPts(1).y = uaTmpPts(2).y
  192.     
  193.     'Lines will be drawn perpendicular to mfAngle so
  194.     'add 90║ and correct for 360║ wrap
  195.     fAngle = CDbl(mfAngle + 90) - Int(Int(CDbl(mfAngle + 90) / 360#) * 360#)
  196.     
  197.     'Rotate second and third points to fAngle
  198.     Call RotatePoint(uaTmpPts(2), uaTmpPts(0), fAngle)
  199.     Call RotatePoint(uaTmpPts(2), uaTmpPts(1), fAngle)
  200.     
  201.     'We now have a line that crosses the center and
  202.     'two sides of the rect at the correct angle.
  203.     
  204.     'Calc the starting quadrant, direction of and amount of first move
  205.     '(fMovX, fMovY moves line from center to starting edge)
  206.     'and direction of each incremental move (iIncX, iIncY).
  207.     Select Case mfAngle
  208.         Case 0 To 90
  209.             'Left Bottom
  210.             If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
  211.                 'Move line to left edge; Draw left to right
  212.                 fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, -uaTmpPts(0).x, -uaTmpPts(1).x)
  213.                 fMovY = 0
  214.                 iIncX = 1
  215.                 iIncY = 0
  216.             Else
  217.                 'Move line to bottom edge; Draw bottom to top
  218.                 fMovX = 0
  219.                 fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, lHeight - uaTmpPts(1).y, lHeight - uaTmpPts(0).y)
  220.                 iIncX = 0
  221.                 iIncY = -1
  222.             End If
  223.         Case 90 To 180
  224.             'Right Bottom
  225.             If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
  226.                 'Move line to right edge; Draw right to left
  227.                 fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, lWidth - uaTmpPts(1).x, lWidth - uaTmpPts(0).x)
  228.                 fMovY = 0
  229.                 iIncX = -1
  230.                 iIncY = 0
  231.             Else
  232.                 'Move line to bottom edge; Draw bottom to top
  233.                 fMovX = 0
  234.                 fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, lHeight - uaTmpPts(1).y, lHeight - uaTmpPts(0).y)
  235.                 iIncX = 0
  236.                 iIncY = -1
  237.             End If
  238.         Case 180 To 270
  239.             'Right Top
  240.             If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
  241.                 'Move line to right edge; Draw right to left
  242.                 fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, lWidth - uaTmpPts(1).x, lWidth - uaTmpPts(0).x)
  243.                 fMovY = 0
  244.                 iIncX = -1
  245.                 iIncY = 0
  246.             Else
  247.                 'Move line to top edge; Draw top to bottom
  248.                 fMovX = 0
  249.                 fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, -uaTmpPts(0).y, -uaTmpPts(1).y)
  250.                 iIncX = 0
  251.                 iIncY = 1
  252.             End If
  253.         Case Else   '(270 to 360)
  254.             'Left Top
  255.             If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
  256.                 'Move line to left edge; Draw left to right
  257.                 fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, -uaTmpPts(0).x, -uaTmpPts(1).x)
  258.                 fMovY = 0
  259.                 iIncX = 1
  260.                 iIncY = 0
  261.             Else
  262.                 'Move line to top edge; Draw top to bottom
  263.                 fMovX = 0
  264.                 fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, -uaTmpPts(0).y, -uaTmpPts(1).y)
  265.                 iIncX = 0
  266.                 iIncY = 1
  267.             End If
  268.     End Select
  269.     
  270.     'At this point we could calculate where the lines will cross the rect edges, but
  271.     'this would slow things down. The picObj clipping region will take care of this.
  272.     
  273.     'Start with 1000 points and add more if needed. This increases
  274.     'speed by not re-dimming the array in each loop.
  275.     ReDim uaPts(999)
  276.     
  277.     'Set the first two points in the array
  278.     uaPts(0).x = uaTmpPts(0).x + fMovX
  279.     uaPts(0).y = uaTmpPts(0).y + fMovY
  280.     uaPts(1).x = uaTmpPts(1).x + fMovX
  281.     uaPts(1).y = uaTmpPts(1).y + fMovY
  282.     
  283.     lIdx = 2
  284.     'Create the rest of the points by incrementing both points
  285.     'on each line iIncX, iIncY from the previous line's points.
  286.     'Where we stop depends on the direction of travel.
  287.     'We'll continue until both points in a set reach the end.
  288.     While Not bDone
  289.         uaPts(lIdx).x = uaPts(lIdx - 2).x + iIncX
  290.         uaPts(lIdx).y = uaPts(lIdx - 2).y + iIncY
  291.         lIdx = lIdx + 1
  292.         Select Case True
  293.             Case iIncX > 0  'Moving Left to Right
  294.                 bDone = uaPts(lIdx - 1).x > lWidth And uaPts(lIdx - 2).x > lWidth
  295.             Case iIncX < 0  'Moving Right to Left
  296.                 bDone = uaPts(lIdx - 1).x < 0 And uaPts(lIdx - 2).x < 0
  297.             Case iIncY > 0  'Moving Top to Bottom
  298.                 bDone = uaPts(lIdx - 1).y > lHeight And uaPts(lIdx - 2).y > lHeight
  299.             Case iIncY < 0  'Moving Bottom to Top
  300.                 bDone = uaPts(lIdx - 1).y < 0 And uaPts(lIdx - 2).y < 0
  301.         End Select
  302.         If (lIdx Mod 1000) = 0 Then
  303.             ReDim Preserve uaPts(UBound(uaPts) + 1000)
  304.         End If
  305.     Wend
  306.     
  307.     'Free excess memory (may have 1001 points dimmed to 2000)
  308.     ReDim Preserve uaPts(lIdx - 1)
  309.     
  310.     'Create the array of colors blending from mlColor1 to mlColor2
  311.     lRet = BlendColors(mlColor1, mlColor2, lIdx / 2, laColors)
  312.     
  313.     'Now draw each line in it's own color
  314.     For lIdx = 0 To UBound(uaPts) - 1 Step 2
  315.         'Move to next point
  316.         lRet = MoveToEx(hdc, uaPts(lIdx).x, uaPts(lIdx).y, uTmpPt)
  317.         'Create the colored pen and select it into the DC
  318.         hPen = CreatePen(PS_SOLID, 1, laColors(Int(lIdx / 2)))
  319.         hOldPen = SelectObject(hdc, hPen)
  320.         'Draw the line
  321.         lRet = LineTo(hdc, uaPts(lIdx + 1).x, uaPts(lIdx + 1).y)
  322.         'Get the pen back out of the DC and destroy it
  323.         lRet = SelectObject(hdc, hOldPen)
  324.         lRet = DeleteObject(hPen)
  325.     Next lIdx
  326.     
  327.     DrawGradient = lIdx
  328.     
  329. NormalExit:
  330.     'Free the memory
  331.     Erase laColors
  332.     Erase uaPts
  333.     Erase uaTmpPts
  334.     Exit Function
  335.     
  336. LocalError:
  337.     MsgBox Err.Description, vbExclamation, "GradientRect.cls"
  338.     DrawGradient = 0
  339.     Resume 'NormalExit
  340.     
  341. End Function
  342.  
  343. Private Sub RotatePoint(uAxisPt As PointSng, uRotatePt As PointSng, fDegrees As Single)
  344.  
  345. Dim fDX         As Single
  346. Dim fDY         As Single
  347. Dim fRadians    As Single
  348.  
  349.     fRadians = fDegrees * RADS
  350.     fDX = uRotatePt.x - uAxisPt.x
  351.     fDY = uRotatePt.y - uAxisPt.y
  352.     uRotatePt.x = uAxisPt.x + ((fDX * Cos(fRadians)) + (fDY * Sin(fRadians)))
  353.     uRotatePt.y = uAxisPt.y + -((fDX * Sin(fRadians)) - (fDY * Cos(fRadians)))
  354.     
  355. End Sub
  356.  
  357.  
  358.  
  359. Private Function Div(ByVal dNumer As Double, ByVal dDenom As Double) As Double
  360.     
  361. 'Divides dNumer by dDenom if dDenom <> 0
  362. 'Eliminates 'Division By Zero' error.
  363.  
  364.     If dDenom <> 0 Then
  365.         Div = dNumer / dDenom
  366.     Else
  367.         Div = 0
  368.     End If
  369.  
  370. End Function
  371.  
  372. Public Property Let Color1(ByVal lData As Long)
  373.     
  374. Dim lIdx As Long
  375.  
  376.     mlColor1 = lData
  377.     If mlColor1 < 0 Then
  378.         lIdx = (mlColor1 And Not &H80000000)
  379.         If lIdx >= 0 And lIdx <= 24 Then
  380.             mlColor1 = GetSysColor(lIdx)
  381.         End If
  382.     End If
  383.     
  384. End Property
  385.  
  386.  
  387. Public Property Get Color1() As Long
  388.     Color1 = mlColor1
  389. End Property
  390.  
  391.  
  392.  
  393. Public Property Let Color2(ByVal lData As Long)
  394.  
  395. Dim lIdx As Long
  396.  
  397.     mlColor2 = lData
  398.     If mlColor2 < 0 Then
  399.         lIdx = (mlColor2 And Not &H80000000)
  400.         If lIdx >= 0 And lIdx <= 24 Then
  401.             mlColor2 = GetSysColor(lIdx)
  402.         End If
  403.     End If
  404.  
  405. End Property
  406.  
  407.  
  408. Public Property Get Color2() As Long
  409.     Color2 = mlColor2
  410. End Property
  411.  
  412.  
  413.  
  414. Public Property Let Angle(ByVal fData As Single)
  415.     
  416. 'Angles are counter-clockwise and may be
  417. 'any Single value from 0 to 359.999999999.
  418.  
  419. ' 135  90 45
  420. '    \ | /
  421. '180 --o-- 0
  422. '    / | \
  423. ' 235 270 315
  424.  
  425.     'Correct angle to ensure between 0 and 359.999999999
  426.     mfAngle = CDbl(fData) - Int(Int(CDbl(fData) / 360#) * 360#)
  427.  
  428. End Property
  429.  
  430.  
  431. Public Property Get Angle() As Single
  432.     Angle = mfAngle
  433. End Property
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441. Private Sub Class_Initialize()
  442.  
  443.     mlColor1 = mlDefColor1
  444.     mlColor2 = mlDefColor2
  445.     mfAngle = mfDefAngle
  446.     
  447. End Sub
  448.  
  449.  
  450.  
  451.  
  452.