gradient.cls

last chaos botlast chaos botlast chaos bot

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Gradient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Property Storage Variables
Private mlColor1    As Long
Private mlColor2    As Long
Private mfAngle     As Single

'Property Default Constants - Colors and Angle match Kath-Rock logo.
Private Const mlDefColor1   As Long = &HFFFFD0  'Very Light Blue
Private Const mlDefColor2   As Long = &H400000  'Very Dark Blue
Private Const mfDefAngle    As Single = 315     'Upper-Left to Lower-Right

'Misc Constants
Private Const PI    As Double = 3.14159265358979
Private Const RADS  As Double = PI / 180    '<Degrees> * RADS = radians

'TypeDefs
Private Type PointSng   'Internal Point structure
    x   As Single       'Uses Singles for more precision.
    y   As Single
End Type

Private Type PointAPI   'API Point structure
    x   As Long
    y   As Long
End Type

Private Type RectAPI    'API Rect structure
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

'API functions and Constants
Private Const PS_SOLID As Long = 0  'Solid Pen Style (Used for CreatePen())
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RectAPI) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long, lpPoint As PointAPI) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long

Public Function Draw(picObj As Object) As Boolean

'Note: This class uses API functions to draw. If the
'      destination object is in AutoRedraw mode, the
'      Refresh method for that object must be invoked.

'picObj can be a Form or PictureBox.

Dim lRet    As Long
Dim lIdx    As Long
Dim lTime   As Long
Dim uRect   As RectAPI

'    lTime = GetTickCount()
    
    On Error GoTo LocalError
    
    'Stop the window from updating until we're finished.
'    lRet = LockWindowUpdate(picObj.hWnd)
    
    'Get the client rect in pixels
    lRet = GetClientRect(picObj.hWnd, uRect)
    
    'Test for possible errors (GetClientRect failure or Rect < 2 pixels)
    If lRet <> 0 Then
        If uRect.Right > 1 And uRect.Bottom > 1 Then
            lIdx = DrawGradient(picObj.hDc, uRect.Right, uRect.Bottom)
            Draw = (lIdx > 0)
        End If
    End If
    
    'My P3-500 took 99 millisecs (.099 secs) to create and draw 2554 diagonal
    'lines at 315 degrees. That was frmDemo maximized on a 1280 x 1024 screen.
    'At this speed I can redraw an entire 1280px. screen over 10 times per second.
    
    'Same size rect at a 0 degree angle took 48 millisecs (.048 secs) to create and
    'draw 1278 lines. This speed can redraw a 1280px. screen 20 times per second.
    
    'Uncomment the two lines below and the lTime line at the top
    'of this function to test the times on your PC.
    
'    lTime = GetTickCount() - lTime
'    MsgBox CStr(lIdx / 2) & " lines drawn in " & CStr(lTime) & " milliseconds"
        
NormalExit:
    'Unlock the window to allow it to update now.
'    lRet = LockWindowUpdate(0)
    Exit Function
    
LocalError:
    MsgBox Err.Description, vbExclamation
    Resume NormalExit

End Function
Public Function BlendColors(ByVal lColor1 As Long, ByVal lColor2 As Long, ByVal lSteps As Long, laRetColors() As Long) As Long

'Creates an array of colors blending from
'Color1 to Color2 in lSteps number of steps.
'Returns the count and fills the laRetColors() array.

Dim lIdx    As Long
Dim lRed    As Long
Dim lGrn    As Long
Dim lBlu    As Long
Dim fRedStp As Single
Dim fGrnStp As Single
Dim fBluStp As Single

    'Stop possible error
    If lSteps < 2 Then lSteps = 2
    
    'Extract Red, Blue and Green values from the start and end colors.
    lRed = (lColor1 And &HFF&)
    lGrn = (lColor1 And &HFF00&) / &H100
    lBlu = (lColor1 And &HFF0000) / &H10000
    
    'Find the amount of change for each color element per color change.
    fRedStp = Div(CSng((lColor2 And &HFF&) - lRed), CSng(lSteps))
    fGrnStp = Div(CSng(((lColor2 And &HFF00&) / &H100&) - lGrn), CSng(lSteps))
    fBluStp = Div(CSng(((lColor2 And &HFF0000) / &H10000) - lBlu), CSng(lSteps))
    
    'Create the colors
    ReDim laRetColors(lSteps - 1)
    laRetColors(0) = lColor1            'First Color
    laRetColors(lSteps - 1) = lColor2   'Last Color
    For lIdx = 1 To lSteps - 2          'All Colors between
        laRetColors(lIdx) = CLng(lRed + (fRedStp * CSng(lIdx))) + _
            (CLng(lGrn + (fGrnStp * CSng(lIdx))) * &H100&) + _
            (CLng(lBlu + (fBluStp * CSng(lIdx))) * &H10000)
    Next lIdx
    
    'Return number of colors in array
    BlendColors = lSteps

End Function
Private Function DrawGradient(ByVal hDc As Long, ByVal lWidth As Long, ByVal lHeight As Long) As Long

Dim bDone       As Boolean
Dim iIncX       As Integer
Dim iIncY       As Integer
Dim lIdx        As Long
Dim lRet        As Long
Dim hPen        As Long
Dim hOldPen     As Long
Dim lPointCnt   As Long
Dim laColors()  As Long
Dim fMovX       As Single
Dim fMovY       As Single
Dim fDist       As Single
Dim fAngle      As Single
Dim fLongSide   As Single
Dim uTmpPt      As PointAPI
Dim uaPts()     As PointAPI
Dim uaTmpPts()  As PointSng
    
    On Error GoTo LocalError
    
    'Start with center of rect
    ReDim uaTmpPts(2)
    uaTmpPts(2).x = Int(lWidth / 2)
    uaTmpPts(2).y = Int(lHeight / 2)
    
    'Calc distance to furthest edge as if rect were square
    fLongSide = IIf(lWidth > lHeight, lWidth, lHeight)
    fDist = (Sqr((fLongSide ^ 2) + (fLongSide ^ 2)) + 2) / 2
    
    'Create points to the left and the right at a 0