'// clsGradient.cls
Option Explicit
Private Const PI As Double = 3.14159265358979
Private Const RADS As Double = PI / 180 '<Degrees> * RADS = radians
'// Internal Point structure.Uses Singles for more precision.
Private Type PointSng
x As Single
y As Single
End Type
Private Type POINT
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'// CreatePen API nPenStyle parameter constant
Private Const PS_SOLID As Long = 0
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINT) 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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
'// 渐变一
Public Sub DrawGradient1(ByVal hDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, _
ByVal lStartColour As Long, ByVal lEndColour As Long, ByVal bVertical As Boolean)
Dim lStep As Long
Dim lPos As Long, lSize As Long
Dim bRGB(1 To 3) As Integer
Dim bRGBStart(1 To 3) As Integer
Dim dR(1 To 3) As Double
Dim dPos As Double, d As Double
Dim hBr As Long
Dim tR As RECT
tR.Left = 0
tR.Top = 0
tR.Right = lWidth
tR.Bottom = lHeight
If bVertical Then
lSize = (tR.Bottom - tR.Top)
Else
lSize = (tR.Right - tR.Left)
End If
lStep = lSize / 255
If (lStep < 3) Then
lStep = 3
End If
bRGB(1) = lStartColour And &HFF&
bRGB(2) = (lStartColour And &HFF00&) / &H100&
bRGB(3) = (lStartColour And &HFF0000) / &H10000
bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
dR(1) = (lEndColour And &HFF&) - bRGB(1)
dR(2) = ((lEndColour And &HFF00&) / &H100&) - bRGB(2)
dR(3) = ((lEndColour And &HFF0000) / &H10000) - bRGB(3)
For lPos = lSize To 0 Step -lStep
'// Draw bar:
If bVertical Then
tR.Top = tR.Bottom - lStep
Else
tR.Left = tR.Right - lStep
End If
'Debug.Print tR.Right, tR.left, (bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1))
hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
FillRect hDC, tR, hBr
DeleteObject hBr
'// Adjust colour:
dPos = ((lSize - lPos) / lSize)
If bVertical Then
tR.Bottom = tR.Top
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
Else
tR.Right = tR.Left
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
End If
Next
End Sub
'// 渐变二
Public Sub DrawGradient2(ByVal hDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, _
ByVal lStartColour As Long, ByVal lEndColour As Long, ByVal fDegrees As Single)
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 fAngle As Single
Dim fDist As Single
Dim fLongSide As Single
Dim uTmpPt As POINT
Dim uaPts() As POINT
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?angle (horizontal)
uaTmpPts(0).x = uaTmpPts(2).x - fDist
uaTmpPts(0).y = uaTmpPts(2).y
uaTmpPts(1).x = uaTmpPts(2).x + fDist
uaTmpPts(1).y = uaTmpPts(2).y
'// Angles are counter-clockwise and may be
'// any Single value from 0 to 359.999999999.
'// 135 90 45
'// / | /
'// 180 --o-- 0
'// / | /
'// 235 270 315
'Correct angle to ensure between 0 and 359.999999999
fDegrees = CDbl(fDegrees) - Int(Int(CDbl(fDegrees) / 360#) * 360#)
'// Lines will be drawn perpendicular to mfAngle so
'// add 90?and correct for 360?wrap
fAngle = CDbl(fDegrees + 90) - Int(Int(CDbl(fDegrees + 90) / 360#) * 360#)
'// Rotate second and third points to fAngle
Call RotatePoint(uaTmpPts(2), uaTmpPts(0), fAngle)
Call RotatePoint(uaTmpPts(2), uaTmpPts(1), fAngle)
'// We now have a line that crosses the center and
'//two sides of the rect at the correct angle.
'// Calc the starting quadrant, direction of and amount of first move
'// (fMovX, fMovY moves line from center to starting edge)
'// and direction of each incremental move (iIncX, iIncY).
Select Case fDegrees
Case 0 To 90
'Left Bottom
If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
'Move line to left edge; Draw left to right
fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, -uaTmpPts(0).x, -uaTmpPts(1).x)
fMovY = 0
iIncX = 1
iIncY = 0
Else
'Move line to bottom edge; Draw bottom to top
fMovX = 0
fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, lHeight - uaTmpPts(1).y, lHeight - uaTmpPts(0).y)
iIncX = 0
iIncY = -1
End If
Case 90 To 180
'Right Bottom
If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
'Move line to right edge; Draw right to left
fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, lWidth - uaTmpPts(1).x, lWidth - uaTmpPts(0).x)
fMovY = 0
iIncX = -1
iIncY = 0
Else
'Move line to bottom edge; Draw bottom to top
fMovX = 0
fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, lHeight - uaTmpPts(1).y, lHeight - uaTmpPts(0).y)
iIncX = 0
iIncY = -1
End If
Case 180 To 270
'Right Top
If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
'Move line to right edge; Draw right to left
fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, lWidth - uaTmpPts(1).x, lWidth - uaTmpPts(0).x)
fMovY = 0
iIncX = -1
iIncY = 0
Else
'Move line to top edge; Draw top to bottom
fMovX = 0
fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, -uaTmpPts(0).y, -uaTmpPts(1).y)
iIncX = 0
iIncY = 1
End If
Case Else '(270 to 360)
'Left Top
If Abs(uaTmpPts(0).x - uaTmpPts(1).x) <= Abs(uaTmpPts(0).y - uaTmpPts(1).y) Then
'Move line to left edge; Draw left to right
fMovX = IIf(uaTmpPts(0).x > uaTmpPts(1).x, -uaTmpPts(0).x, -uaTmpPts(1).x)
fMovY = 0
iIncX = 1
iIncY = 0
Else
'Move line to top edge; Draw top to bottom
fMovX = 0
fMovY = IIf(uaTmpPts(0).y > uaTmpPts(1).y, -uaTmpPts(0).y, -uaTmpPts(1).y)
iIncX = 0
iIncY = 1
End If
End Select
'// At this point we could calculate where the lines will cross the rect edges, but
'// this would slow things down. The picObj clipping region will take care of this.
'// Start with 1000 points and add more if needed. This increases
'// speed by not re-dimming the array in each loop.
ReDim uaPts(999)
'Set the first two points in the array
uaPts(0).x = uaTmpPts(0).x + fMovX
uaPts(0).y = uaTmpPts(0).y + fMovY
uaPts(1).x = uaTmpPts(1).x + fMovX
uaPts(1).y = uaTmpPts(1).y + fMovY
lIdx = 2
'// Create the rest of the points by incrementing both points
'// on each line iIncX, iIncY from the previous line's points.
'// Where we stop depends on the direction of travel.
'// We'll continue until both points in a set reach the end.
Do While Not bDone
uaPts(lIdx).x = uaPts(lIdx - 2).x + iIncX
uaPts(lIdx).y = uaPts(lIdx - 2).y + iIncY
lIdx = lIdx + 1
Select Case True
Case iIncX > 0 'Moving Left to Right
bDone = uaPts(lIdx - 1).x > lWidth And uaPts(lIdx - 2).x > lWidth
Case iIncX < 0 'Moving Right to Left
bDone = uaPts(lIdx - 1).x < 0 And uaPts(lIdx - 2).x < 0
Case iIncY > 0 'Moving Top to Bottom
bDone = uaPts(lIdx - 1).y > lHeight And uaPts(lIdx - 2).y > lHeight
Case iIncY < 0 'Moving Bottom to Top
bDone = uaPts(lIdx - 1).y < 0 And uaPts(lIdx - 2).y < 0
End Select
If (lIdx Mod 1000) = 0 Then
ReDim Preserve uaPts(UBound(uaPts) + 1000)
End If
Loop
'// Free excess memory (may have 1001 points dimmed to 2000)
ReDim Preserve uaPts(lIdx - 1)
'// Create the array of colors blending from lStartColour to lEndColour
lRet = BlendColors(lStartColour, lEndColour, lIdx / 2, laColors)
'// Now draw each line in it's own color
For lIdx = 0 To UBound(uaPts) - 1 Step 2
'// Move to next point
lRet = MoveToEx(hDC, uaPts(lIdx).x, uaPts(lIdx).y, uTmpPt)
'// Create the colored pen and select it into the DC
hPen = CreatePen(PS_SOLID, 1, laColors(Int(lIdx / 2)))
hOldPen = SelectObject(hDC, hPen)
'// Draw the line
lRet = LineTo(hDC, uaPts(lIdx + 1).x, uaPts(lIdx + 1).y)
'// Get the pen back out of the DC and destroy it
lRet = SelectObject(hDC, hOldPen)
lRet = DeleteObject(hPen)
Next lIdx
'DrawGradient2 = lIdx
NormalExit:
'// Free the memory
Erase laColors
Erase uaPts
Erase uaTmpPts
Exit Sub
LocalError:
MsgBox Err.Description, vbExclamation, "Gradient"
'DrawGradient = 0
Resume 'NormalExit
End Sub
'// Creates an array of colors blending from
'// Color1 to Color2 in lSteps number of steps.
'// Returns the count and fills the laRetColors() array.
Private Function BlendColors(ByVal lColor1 As Long, ByVal lColor2 As Long, ByVal lSteps As Long, laRetColors() As Long) As Long
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 Sub RotatePoint(uAxisPt As PointSng, uRotatePt As PointSng, fDegrees As Single)
Dim fDX As Single
Dim fDY As Single
Dim fRadians As Single
fRadians = fDegrees * RADS
fDX = uRotatePt.x - uAxisPt.x
fDY = uRotatePt.y - uAxisPt.y
uRotatePt.x = uAxisPt.x + ((fDX * Cos(fRadians)) + (fDY * Sin(fRadians)))
uRotatePt.y = uAxisPt.y + -((fDX * Sin(fRadians)) - (fDY * Cos(fRadians)))
End Sub
'// Divides dNumer by dDenom if dDenom <> 0
'// Eliminates 'Division By Zero' error.
Private Function Div(ByVal dNumer As Double, ByVal dDenom As Double) As Double
If dDenom <> 0 Then
Div = dNumer / dDenom
Else
Div = 0
End If
End Function