Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Function LineGradient(ByVal pDC As Long, ByVal pWidth As Long, pHeight As Long, ByVal pStartColor As Long, ByVal pEndColor As Long, Optional pVertical As Boolean = False) As Boolean
Dim lDC As Long ' handle to temporary dc to draw gradient
Dim lBMP As Long, lOrigBMP As Long
Dim lPen As Long, lOrigPen As Long
Dim bytCS(3) As Byte, bytCE(3) As Byte
Dim nRChg As Double, nGChg As Double, nBChg As Double
Dim ptCurLine(0 To 1) As POINTAPI
Dim ict As Long
Dim lEnd As Long
' create the temporary DC
lDC = CreateCompatibleDC(pDC)
If Not lDC = 0 Then
' create the bitmap to draw to
lBMP = CreateCompatibleBitmap(pDC, pWidth, pHeight)
If Not lBMP = 0 Then
lOrigBMP = SelectObject(lDC, lBMP)
'retrieve the red, green, and blue bytes from the Color
CopyMemory bytCS(0), pStartColor, 3
CopyMemory bytCE(0), pEndColor, 3
' determine direction to draw
If pVertical = True Then lEnd = pHeight Else lEnd = pWidth
' retrieve the values to change each RGB value through each iteration of the drawing loop
nRChg = (CInt(bytCE(0)) - CInt(bytCS(0))) / lEnd
nGChg = (CInt(bytCE(1)) - CInt(bytCS(1))) / lEnd
nBChg = (CInt(bytCE(2)) - CInt(bytCS(2))) / lEnd
lPen = CreatePen(0, 1, pStartColor)
lOrigPen = SelectObject(lDC, lPen)
For ict = 0 To lEnd
If pVertical = True Then
' describe current vertical line
ptCurLine(0).x = 0: ptCurLine(0).y = ict
ptCurLine(1).x = pWidth: ptCurLine(1).y = ict
Else
' describe current horizontal line
ptCurLine(0).x = ict: ptCurLine(0).y = 0
ptCurLine(1).x = ict: ptCurLine(1).y = pHeight
End If
' draw line to the temporary DC
Polyline lDC, ptCurLine(0), 2
' change the pen to the next color in the gradient
lPen = CreatePen(0, 1, RGB(bytCS(0) + (nRChg * ict), bytCS(1) + (nGChg * ict), bytCS(2) + (nBChg * ict)))
' remove the previous pen from memory
DeleteObject SelectObject(lDC, lPen)
Next ict
' display the gradient to the DC expected
If BitBlt(pDC, 0, 0, pWidth, pHeight, lDC, 0, 0, vbSrcCopy) Then
LineGradient = True
Else
LineGradient = False
End If
' free memory
DeleteObject SelectObject(lDC, lOrigPen)
DeleteObject SelectObject(lDC, lOrigBMP)
DeleteDC lDC
Else
LineGradient = False
End If
Else
LineGradient = False
End If
End Function
Private Sub Form_Load()
Me.AutoRedraw = False
End Sub
Private Sub Form_Paint()
LineGradient Me.hdc, Me.Width \ Screen.TwipsPerPixelX, Me.Height \ Screen.TwipsPerPixelY, RGB(255, 0, 255), RGB(255, 255, 0), True
End Sub
Private Sub Form_Resize()
Form_Paint
End Sub
