Circle Color Gradient

Category:

Screen/Graphics

Type:

Snippets

Difficulty:

Intermediate

Author:

Arkadiy Olovyannikov

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

This snippet uses the GradientFillTri API function to draw a circle color gradient. As you can see by running the comparison function included, it results in a smoother gradient, with no dithering, as compared to the "standard" VB way of doing this, which would be to use the Circle method.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Private Type RGBType r As Byte g As Byte b As Byte Filler As Byte End Type Private Type RGBLongType clr 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_TRIANGLE Vertex1 As Long Vertex2 As Long Vertex3 As Long End Type Const GRADIENT_FILL_TRIANGLE As Long = &H2 Private Declare Function GradientFillTri Lib "msimg32" Alias "GradientFill" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_TRIANGLE, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long

Code:

Private Sub Form_Load()
  BackColor = vbWhite
  ScaleMode = vbPixels
  AutoRedraw = True
  Caption = "Circle gradient sample"
  DrawCircleGradient 100, ScaleWidth / 2, ScaleHeight / 2, vbRed, BackColor
'  DrawCircleGradient2 100, ScaleWidth / 2, ScaleHeight / 2, vbRed, BackColor
End Sub

Private Sub DrawCircleGradient(ByVal Radius As Long, ByVal xCentre As Long, ByVal yCentre As Long, ByVal CentreClr As Long, ByVal BoundClr As Long)
   'Perform smooth circle gradient dithering centre color to bound color
   Dim i As Long
   Dim vert(36) As TRIVERTEX
   Dim gTri(35) As GRADIENT_TRIANGLE
   Dim CentreRGB As RGBType, BoundRGB As RGBType
   CentreRGB = LongClrToRgb(CentreClr)
   BoundRGB = LongClrToRgb(BoundClr)
   vert(36).Red = ByteToUShort(CentreRGB.r)
   vert(36).Green = ByteToUShort(CentreRGB.g)
   vert(36).Blue = ByteToUShort(CentreRGB.b)
   vert(36).X = xCentre
   vert(36).y = yCentre
   vert(36).Alpha = 0&
   For i = 0 To 35
       vert(i).Red = ByteToUShort(BoundRGB.r)
       vert(i).Green = ByteToUShort(BoundRGB.g)
       vert(i).Blue = ByteToUShort(BoundRGB.b)
       vert(i).X = xCentre + Radius * Sind(i * 10)
       vert(i).y = yCentre - Radius * Cosd(i * 10)
       vert(i).Alpha = 0&
       gTri(i).Vertex1 = 36
       gTri(i).Vertex2 = i
       gTri(i).Vertex3 = (i + 1) Mod 36
   Next i
   Call GradientFillTri(Me.hDC, vert(0), 37, gTri(0), 36, GRADIENT_FILL_TRIANGLE)
End Sub

Private Function ByteToUShort(ByVal bt As Byte) As Integer
   If bt < 128 Then
      ByteToUShort = CInt(CLng("&H" & Hex(bt) & "00"))
   Else
      ByteToUShort = CInt(CLng("&H" & Hex(bt) & "00") - &H10000)
   End If
End Function

Private Function LongClrToRgb(ByVal lClr As Long) As RGBType
   Dim lRgb As RGBLongType
   lRgb.clr = lClr
   LSet LongClrToRgb = lRgb
End Function

Private Function Rad(ByVal X As Double) As Double
  Rad = X * Atn(1) / 45#
End Function

Private Function Sind(ByVal X As Double) As Double
   Sind = Sin(Rad(X))
End Function

Private Function Cosd(ByVal X As Double) As Double
   Cosd = Cos(Rad(X))
End Function

'Just for comparison - simple way
Private Sub DrawCircleGradient2(ByVal Radius As Long, ByVal xCentre As Long, ByVal yCentre As Long, ByVal CentreClr As Long, ByVal BoundClr As Long)
   'Simple way, but due to VB circle isn't a "pure" circle, but poligon some background pixels will be visible,
   'so you'll get "Red & White" circle instead of red
   Dim i As Long
   Dim CentreRGB As RGBType, BoundRGB As RGBType
   Dim r As Integer, g As Integer, b As Integer
   CentreRGB = LongClrToRgb(CentreClr)
   BoundRGB = LongClrToRgb(BoundClr)
   For i = 1 To Radius
       r = CentreRGB.r + (BoundRGB.r - CentreRGB.r) * i / Radius
       g = CentreRGB.g + (BoundRGB.g - CentreRGB.g) * i / Radius
       b = CentreRGB.b + (BoundRGB.b - CentreRGB.b) * i / Radius
       Circle (xCentre, yCentre), i, RGB(r, g, b)
   Next i
End Sub