I have seen in the past in MS Access 2003 you can apply a color gradient to a form. In VB6 is it possible to apply a color gradient to the back color of a shape or a frame?
Check this. Object maybe a PictureBox or a Form
f& ans t& are the two colors
You can define two points as a frame, to place portion of gradient or fill frame with full gradient (check boolean all).
Code:
Function RMAX(ByVal q As Single, ByVal w As Single) As Single
If q > w Then
RMAX = q
Else
RMAX = w
End If
End Function
Function RMIN(ByVal q As Single, ByVal w As Single) As Single
If q < w Then
RMIN = q
Else
RMIN = w
End If
End Function
Sub Gradient(TheObject As Object, ByVal f&, ByVal t&, ByVal xx1&, ByVal xx2&, ByVal yy1&, ByVal yy2&, ByVal hor As Boolean, ByVal all As Boolean)
Dim Redval&, Greenval&, Blueval&
Dim r1&, g1&, b1&, sr&, SG&, sb&
f& = f& Mod &H1000000
t& = t& Mod &H1000000
Redval& = f& And &H10000FF
Greenval& = (f& And &H100FF00) / &H100
Blueval& = (f& And &HFF0000) / &H10000
r1& = t& And &H10000FF
g1& = (t& And &H100FF00) / &H100
b1& = (t& And &HFF0000) / &H10000
sr& = (r1& - Redval&) * 1000 / 127
SG& = (g1& - Greenval&) * 1000 / 127
sb& = (b1& - Blueval&) * 1000 / 127
Redval& = Redval& * 1000
Greenval& = Greenval& * 1000
Blueval& = Blueval& * 1000
Dim Step&, Reps&, FillTop As Single, FillLeft As Single, FillRight As Single, FillBottom As Single
If hor Then
yy2& = TheObject.Height - yy2&
If all Then
Step = ((yy2& - yy1&) / 127)
Else
Step = (TheObject.Height / 127)
End If
If all Then
FillTop = yy1&
Else
FillTop = 0
End If
FillLeft = xx1&
FillRight = TheObject.width - xx2&
FillBottom = FillTop + Step * 2
Else ' vertical
xx2& = TheObject.width - xx2&
If all Then
Step = ((xx2& - xx1&) / 127)
Else
Step = (TheObject.width / 127)
End If
If all Then
FillLeft = xx1&
Else
FillLeft = 0
End If
FillTop = yy1&
FillBottom = TheObject.Height - yy2&
FillRight = FillLeft + Step * 2
End If
For Reps = 1 To 127
If hor Then
If FillTop <= yy2& And FillBottom >= yy1& Then
TheObject.Line (FillLeft, RMAX(FillTop, yy1&))-(FillRight, RMIN(FillBottom, yy2&)), rgb(Redval& / 1000, Greenval& / 1000, Blueval& / 1000), BF
End If
Redval& = Redval& + sr&
Greenval& = Greenval& + SG&
Blueval& = Blueval& + sb&
FillTop = FillBottom
FillBottom = FillTop + Step
Else
If FillLeft <= xx2& And FillRight >= xx1& Then
TheObject.Line (RMAX(FillLeft, xx1&), FillTop)-(RMIN(FillRight, xx2&), FillBottom), rgb(Redval& / 1000, Greenval& / 1000, Blueval& / 1000), BF
End If
Redval& = Redval& + sr&
Greenval& = Greenval& + SG&
Blueval& = Blueval& + sb&
FillLeft = FillRight
FillRight = FillRight + Step
End If
Next
End Sub
Option Explicit
Private Type TRIVERTEX
PxX As Long
PxY As Long
RedLow As Byte
Red As Byte
GreenLow As Byte
Green As Byte
BlueLow As Byte
Blue As Byte
AlphaLow As Byte
Alpha As Byte
End Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private Declare Function GradientFill Lib "msimg32" ( _
ByVal hDC As Long, _
ByRef Vertex As TRIVERTEX, _
ByVal nVertex As Long, _
ByRef Mesh As GRADIENT_RECT, _
ByVal nMesh As Long, _
ByVal Mode As Long) As Long
Private Sub LetVertex( _
ByRef TRIVERTEX As TRIVERTEX, _
ByVal PxX As Long, _
ByVal PxY As Long, _
ByVal COLORREF As Long)
With TRIVERTEX
.PxX = PxX
.PxY = PxY
.Red = COLORREF And &HFF&
.Green = (COLORREF And &HFF00&) \ &H100&
.Blue = COLORREF \ &H10000
End With
End Sub
Private Sub GradientFillForm(ByVal StartRGBx As Long, ByVal EndRGBx As Long)
Const GRADIENT_FILL_RECT_H = &H0&
Const GRADIENT_FILL_RECT_V = &H1&
Dim TRIVERTEX(0 To 1) As TRIVERTEX
Dim GRADIENT_RECT As GRADIENT_RECT
With GRADIENT_RECT
.UpperLeft = 0
.LowerRight = 1
End With
LetVertex TRIVERTEX(0), 0, 0, StartRGBx
LetVertex TRIVERTEX(1), _
ScaleX(ScaleWidth, ScaleMode, vbPixels), _
ScaleY(ScaleHeight, ScaleMode, vbPixels), _
EndRGBx
AutoRedraw = True
Cls
GradientFill hDC, TRIVERTEX(0), 2, GRADIENT_RECT, 1, GRADIENT_FILL_RECT_V
AutoRedraw = False
End Sub
Private Sub Form_Resize()
If WindowState <> vbMinimized Then GradientFillForm &H80C0FF, &HFFFFC0
End Sub
Maximize, resize, etc. it keeps up as well as about anything.
GeorgeKar,
I tried your code and could only get it to work on the form - not on the picturebox. I did change the code "Me.hDC to Me.Picture1.hDc", etc for the height and width parameters.
I was pretty sure I gave you what you need to crack open the good old MSDN Library docs that come with VB6 and do this yourself. But here's an example:
There we have a UserControl named Container with an instance Container1 on a Form. On the Form I have added some controls to Container1 much as you might a Frame, PictureBox, etc.
If you check the "Run" CheckBox Container1 will run around the Form. If you click on Command1 a status message will be shown and the gradient colors flipped.
GeorgeKar,
I tried your code and could only get it to work on the form - not on the picturebox. I did change the code "Me.hDC to Me.Picture1.hDc", etc for the height and width parameters.
Hi,
try this..
Code:
Option Explicit
'Makes the Form (or PictureBox) gradient
'Author: unknown, found Dec. 2001
'Syntax: Call Gradient(Object, R1, G1, B1, R2, G2, B2, Angle)
'
'Object: Form or PictureBox (must support the line-method)
'R1: Red component of the starting color
'G1: Green component of the starting color
'B1: Blue component of the starting color
'R2: Red component of the ending color
'G2: Green component of the ending color
'B2: Blue component of the ending color
'Angle: True or False
' True: Gradient from left to right
' False: Gradient from top to bottom
'
'Note:
'* The Object must be in ScaleMode = 3 (Pixels) and AutoRedraw = true
'* By setting the starting values of R, G, and B bigger than the
' ending values, you create a negative ColBar.
'* The values of R, G, and B must not exceed 255.
'* For better calculations the values Of R1...B2 are Single.
'
'Examples:
'
'Call Gradient(Form1, 0, 50, 64, 0, 64, 255, True)
'Call Gradient(Picture1, 200, 60, 255, 184, 255, 55, False)
Private Sub Command1_Click()
Call Gradient(Picture1, 200, 60, 255, 184, 255, 55, False)
End Sub
Public Sub Gradient(Obj As Object, R1 As Single, G1 As Single, B1 As Single, R2 As Single, G2 As Single, B2 As Single, Angle As Boolean)
Dim R, G, B As Single
Dim Wi%
Obj.AutoRedraw = True
Obj.ScaleMode = 3
If Angle = False Then
R = (R2 - R1) / Obj.ScaleHeight
G = (G2 - G1) / Obj.ScaleHeight
B = (B2 - B1) / Obj.ScaleHeight
For Wi = 0 To Obj.ScaleHeight - 1
Obj.Line (0, Wi)-(Obj.ScaleWidth - 1, Wi), RGB(R1, G1, B1)
R1 = R1 + R
G1 = G1 + G
B1 = B1 + B
Next Wi
Exit Sub
End If
If Angle = True Then
R = (R2 - R1) / Obj.ScaleWidth
G = (G2 - G1) / Obj.ScaleWidth
B = (B2 - B1) / Obj.ScaleWidth
For Wi = 0 To Obj.ScaleWidth - 1
Obj.Line (Wi, 0)-(Wi, Obj.ScaleHeight - 1), RGB(R1, G1, B1)
R1 = R1 + R
G1 = G1 + G
B1 = B1 + B
Next Wi
Exit Sub
End If
End Sub
regards
Chris
to hunt a species to extinction is not logical !
since 2010 the number of Tigers are rising again in 2016 - 3900 were counted. with Baby Callas it's 3901, my wife and I had 2-3 months the privilege of raising a Baby Tiger.
OK. So I was able to make a color gradient in a picturebox. In design time I also added 3 labels at different vertical positions in the picurebox. In design time I also filled the label boxes with captions. The program worked correctly.
So I took it to the next step. I filled the labels boxes in run time. The labels were no longer transparent. I saw the data but the rest of the label controls were opaque. To make matters worse when I put a timer on the form to get new data, all the labels disappeared, only the gradient remained.
Option Explicit
Private Type TRIVERTEX
PxX As Long
PxY As Long
RedLow As Byte
Red As Byte
GreenLow As Byte
Green As Byte
BlueLow As Byte
Blue As Byte
AlphaLow As Byte
Alpha As Byte
End Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private Declare Function GradientFill Lib "msimg32" ( _
ByVal hDC As Long, _
ByRef Vertex As TRIVERTEX, _
ByVal nVertex As Long, _
ByRef Mesh As GRADIENT_RECT, _
ByVal nMesh As Long, _
ByVal Mode As Long) As Long
Private Sub LetVertex( _
ByRef TRIVERTEX As TRIVERTEX, _
ByVal PxX As Long, _
ByVal PxY As Long, _
ByVal COLORREF As Long)
With TRIVERTEX
.PxX = PxX
.PxY = PxY
.Red = COLORREF And &HFF&
.Green = (COLORREF And &HFF00&) \ &H100&
.Blue = COLORREF \ &H10000
End With
End Sub
Private Sub GradientFillForm(ByVal StartRGBx As Long, ByVal EndRGBx As Long)
Const GRADIENT_FILL_RECT_H = &H0&
Const GRADIENT_FILL_RECT_V = &H1&
Dim TRIVERTEX(0 To 1) As TRIVERTEX
Dim GRADIENT_RECT As GRADIENT_RECT
With GRADIENT_RECT
.UpperLeft = 0
.LowerRight = 1
End With
LetVertex TRIVERTEX(0), 0, 0, StartRGBx
LetVertex TRIVERTEX(1), _
ScaleX(ScaleWidth, ScaleMode, vbPixels), _
ScaleY(ScaleHeight, ScaleMode, vbPixels), _
EndRGBx
AutoRedraw = True
Cls
GradientFill hDC, TRIVERTEX(0), 2, GRADIENT_RECT, 1, GRADIENT_FILL_RECT_V
AutoRedraw = False
End Sub
Private Sub Form_Resize()
If WindowState <> vbMinimized Then GradientFillForm &H80C0FF, &HFFFFC0
End Sub
Maximize, resize, etc. it keeps up as well as about anything.
Hi there,
So, it's a few year old post, but the code still working great, but how could it be extended to be able to set the gradient Angle too?
I don't see any easy answer for that in GDI32. You might try playing with rotation transforms, but you'll need to span a larger rectangle to get full coverage.
Looking at my old code, it seems that a way to do this is to just apply some trigonometry to derive the proper values for the TRIVERTEX array in GradientFillDiagonal().
It is just drawing two filled triangles to cover the rectangle, so that shouldn't be too hard to adjust.