Colour Fade

[Aomeba]

Hi there

Ive have a picture box witha single colour background, but how do you fade one colour into another, as an example vbblue -> vbgreen

thanks in advance

[kedaman]

For x=0 to picture1.scalewidth
  for y=0 to picture1.scaleheight
    a=x/picture1.scalewidth
    ColorC=(a*(ColorA mod 256)+(1-a)*(ColorB mod 256))\2+(a*((ColorA\256) mod 256)+(1-a)*(ColorB\256 mod 256))*128+(a*(ColorA\65536)+(1-a)*(ColorB\65536))*32768
    pset(x,y),ColorC
  next y
next x

J/K!

[Aomeba]

Thanks for the code, but it doesnt seem to work, the form itself starts to fade, although the fade is only the same height as the picture box, also it is very slow and the program is almost unusable.

Is it me or the code, i feel cheeky telling a guru that this does not work,

[Aomeba]

ok sorry, i got the fade into the picture box(Pset), but there are still lots of colours,(not just 2) and it is still very slow.

[redbird77]

You can call the following sub something like this:

TwoColorFade Picture1, RGB(255, 153, 0), , 1

and it would create a orange to black vertical fade on Picture1.

Public Sub TwoColorFade(objDest As Object, _
Optional StartColor As Long = vbWhite, _
Optional EndColor As Long = vbBlack, _
Optional Direction As Integer = 0)

Dim sInc(2) As Single
Dim sCol(2) As Single, sCol2(2) As Single
Dim i As Integer, j As Integer
Dim iWid As Integer, iHgt As Integer
Dim lCol As Long
Dim iTimes As Integer

With objDest
.ScaleMode = vbPixels

' this line important if using the circular fade
.DrawWidth = 2

iWid = .ScaleWidth
iHgt = .ScaleHeight
End With

' to prevent Division by zero(11) or Overflow(6) errors
If iWid = 0 Or iHgt = 0 Then Exit Sub

Select Case Direction
Case 0: iTimes = iHgt
Case 1: iTimes = iWid
Case 2: iTimes = Sqr(((iWid ^ 2) + (iHgt ^ 2)) / 4)
End Select

' populate arrays with R, G, B data based on given colors
LNGtoRGB StartColor, sCol()
LNGtoRGB EndColor, sCol2()

' calculate separate increments for R,G, and B componets
For i = 0 To 2
sInc(i) = (sCol2(i) - sCol(i)) / iTimes
Next

For i = 0 To iTimes

' get color
lCol = RGB(sCol(0), sCol(1), sCol(2))

Select Case Direction
' horizontal
Case 0: objDest.Line (0, i)-(iWid, i), lCol

' vertical
Case 1: objDest.Line (i, 0)-(i, iHgt), lCol

' circular
Case 2: objDest.Circle (iWid / 2, iHgt / 2), i, lCol
End Select

' increment the R, G, B componets of the starting color
For j = 0 To 2: sCol(j) = sCol(j) + sInc(j): Next

Next

End Sub

Public Sub LNGtoRGB(ByVal lCol As Long, ByRef sngRGB() As Single)

sngRGB(0) = lCol And &HFF
sngRGB(1) = (lCol \ &H100) And &HFF
sngRGB(2) = (lCol \ &H10000) And &HFF

End Sub