VB利用API画线性渐变矩形

'API相关定义
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TRIVERTEX
x As Long
y As Long
Red As Integer
Green As Integer
Blue As Integer
Alpha As Integer
End Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const GRADIENT_FILL_RECT_V As Long = &H1
'\\创建圆角矩形区域的API
Private Declare Function CreateRoundRectRgn Lib “gdi32” (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
'\\设置窗口区域的API
Private Declare Function SetWindowRgn Lib “user32” (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'\\设置指定矩形的内容
Private Declare Function SetRect Lib “user32” (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'\\绘制颜色块Api
Private Declare Function GradientFillRect Lib “msimg32” Alias “GradientFill” (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
'\\释放系统资源
Private Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long

‘回调函数

'绘画渐变矩形(目标DC,左距,顶距,宽度,高度,A颜色,B颜色,渐变方向)
Private Sub shadeRECT(hDC As Long, x As Long, y As Long, Width As Long, Height As Long, StartColor As Long, EndColor As Long, Optional Direction As Long)
Dim DotPlace(1) As TRIVERTEX, PropRECT As GRADIENT_RECT, Area As RECT, Nsrt As Long
Nsrt = SetRect(Area, x, y, Width, Height) '设置指定矩形的内容
With DotPlace(0)
.x = Area.Left
.y = Area.Top
.Red = DissectRGB(StartColor, 0)
.Green = DissectRGB(StartColor, 1)
.Blue = DissectRGB(StartColor, 2)
.Alpha = 0&
End With
With DotPlace(1)
.x = Area.Right
.y = Area.Bottom
.Red = DissectRGB(EndColor, 0)
.Green = DissectRGB(EndColor, 1)
.Blue = DissectRGB(EndColor, 2)
.Alpha = 0&
End With
PropRECT.UpperLeft = 1
PropRECT.LowerRight = 0
GradientFillRect hDC, DotPlace(0), 2, PropRECT, 1, IIf(Direction > 0, GRADIENT_FILL_RECT_V, GRADIENT_FILL_RECT_H)
Call DeleteObject(Nsrt)
End Sub
'对颜色分解成RGB函数
Private Function DissectRGB(ByVal ColorValue As Long, Optional RGBindex As Integer = 0) As Integer
Dim R As Double, G As Double, B As Double
R = CLng((ColorValue And &HFF&) * 256)
G = CLng(((ColorValue And &HFF00&) \ &H100&) * 256)
B = CLng(((ColorValue And &HFF0000) \ &H10000) * 256)
DissectRGB = IIf(RGBindex = 0, IIf(R < 32768, Int®, Int(R - &H10000)), IIf(RGBindex = 1, IIf(G < 32768, Int(G), Int(G - &H10000)), IIf(B < 32768, Int(B), Int(B - &H10000))))
End Function

'调用
Private Sub Form_Load()
Me.AutoRedraw = True
Me.ScaleMode = vbPixels
Call shadeRECT(Me.hDC, 5, 5, Me.ScaleWidth - 5, 50, RGB(255, 0, 0), RGB(255, 255, 0)) '水平渐变
Call shadeRECT(Me.hDC, 5, 60, Me.ScaleWidth - 5, 110, RGB(0, 255, 0), RGB(0, 0, 255), 1) '垂直渐变
End Sub