Round Gradient Coloured Bars: Streak Line in Middle
lazarus / 39-Graphics

----------------------------------------------------------------------
Boleeman · 2024-11-10 03:14

Hi All.

I have been trying to make Round Gradient Coloured Bars but there
seems to be a 3-pixel wide Streak Line in the middle of each bar.

Was after a Totally Rounded Bar Effect

There was a ColorFade program in VB6 that made perfectly rendered
gradient bars, but using Lazarus the middle colour of each bar seems
to have a thickish 3-pixel wide line.

I also attached below a png showing the vertical and diagonal output
gradient lines for the Vb6 version.
Perhaps the middle section needs to be blurred using a TBgrabmp  to
make a totally round gradient surface ?

Also had problems implementing the diagonal directions. Not sure if
anyone can possibly help out ?

Below is the Vb6 code that I was referencing:
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i Option
Explicit Private mvarFadeStartColor As Long              'Start
ColorPrivate mvarFadeEndColor As Long                'End
Color Private fcsr As Long                            'Red
StartPrivate fcsg As Long                            'Green
StartPrivate fcsb As Long                            'Blue
Start Private fcer As Long                            'Red EndPrivate
fceg As Long                            'Green EndPrivate fceb As Long
                           'Blue End Enum ColorFadeGradientConstants 
 HorizontalGradient = 0    VerticalGradient = 1   
DiagUpperLeftGradient = 2    DiagUpperRightGradient = 3   
DiagLowerLeftGradient = 4    DiagLowerRightGradient = 5End Enum Public
Function GetFadeColor(Optional fcFadePercent As Long = 50) As Long   
GetFadeColor = DetermineFade(fcsr, fcsg, fcsb, fcer, fceg, fceb,
fcFadePercent)End Function Public Function GetFadeColor2(Optional
fcFadePercent As Long = 50, Optional fcSegments As Long = 2) As Long 
 Dim fcs As Long, fcp As Long, s As Single, p As Single    Dim np As
Long     fcs = fcSegments                'Maybe I should of ByVal'd,
but who cares?    If fcs > 100 Then fcs = 100     'More than 12
segments looks like crap    If fcs < 1 Then fcs = 1         '0
segments makes no fade here     fcp = fcFadePercent            
'Another byval waiting to happen    If fcp > 100 Then fcp = 100    
'More than 100% could cause an error    If fcp < 1 Then fcp = 1      
 'Same with less than 1% for the simple     s = CSng(100 / fcs)      
     'Get a fraction for percentage perposes.    p = CSng(Int(fcp / s)
+ 1)      'Determine the segment based on the percent     If p = 1
Then         np = fcp * fcs    Else        np = (fcp - ((p - 1) * s))
* fcs    End If        If (p / 2) = Int(p / 2) Then          
 GetFadeColor2 = DetermineFade(fcer, fceg, fceb, fcsr, fcsg, fcsb, np)
                ' Even Segment - End-Start    Else           
GetFadeColor2 = DetermineFade(fcsr, fcsg, fcsb, fcer, fceg, fceb, np)
               ' Odd Segment - Start-End    End IfEnd Function Public
Sub PaintObj(Obj As Object, Gradient As ColorFadeGradientConstants)  
 If (TypeOf Obj Is Form) Or (TypeOf Obj Is PictureBox) Then       
PaintObject Obj, Gradient                       ' Only support forms
and picture boxes    End IfEnd Sub Public Sub PaintObj2(Obj As Object,
Gradient As ColorFadeGradientConstants, Optional CycleCount As Long =
1)    If (TypeOf Obj Is Form) Or (TypeOf Obj Is PictureBox) Then     
 PaintObject2 Obj, Gradient, CycleCount          ' Only support forms
and picture boxes    End If   End Sub Private Sub PaintObject(frm As
Object, Gradient As ColorFadeGradientConstants)    Dim ScreenX As Long
                                'Screen width dimension    Dim ScreenY
As Long                                 'Screen height dimension   
Dim h As Long                                       'Object Height   
Dim w As Long                                       'Object Width   
Dim y As Long                                       'Current
Y-Position    Dim x As Long                                      
'Current X-Position    Dim a As Long                                 
    'Current Angle Offset Multiplier    Dim ax As Long               
                     'Current Angle Offset     Dim x1 As Long, x2 As
Long                          'Left and Right of the object    Dim y1
As Long, y2 As Long                          'Top and Bottom of the
object    Dim i As Long                                       'Loop
Counter    Dim j As Long                                       'Loop
Counter    Dim c As Long                                       'Cycles
or other value        ScreenX = Screen.TwipsPerPixelX                
   'Determine the horizontal screen dimension    ScreenY =
Screen.TwipsPerPixelY                     'Determine the vertical
screen dimension     x1 = 0: x2 = (frm.Width / ScreenX)              
  'Get the pixel width of the object    y1 = 0: y2 = (frm.Height /
ScreenY)                 'Get the pixel height of the object    ax =
(y2 / 2)      Select Case Gradient        Case HorizontalGradient    
      For i = y1 To y2                y = (i / y2) * 100             
 frm.Line (x1 * ScreenX, i * ScreenY)-(x2 * ScreenX, i * ScreenY),
Me.GetFadeColor(y)            Next i                    Case
VerticalGradient            For i = x1 To x2                x = (i /
x2) * 100                frm.Line (i * ScreenX, y1 * ScreenY)-(i *
ScreenX, y2 * ScreenY), Me.GetFadeColor(x)            Next i         
         Case DiagLowerLeftGradient            For i = x1 - ax To x2 +
ax                x = (i / x2) * 100                frm.Line ((i - ax)
* ScreenX, y1 * ScreenY)-((i + ax) * ScreenX, y2 * ScreenY),
Me.GetFadeColor(x)            Next i                Case
DiagUpperLeftGradient            For i = x2 + ax To x1 - ax Step -1  
            x = (i / x2) * 100                frm.Line ((i + ax) *
ScreenX, y1 * ScreenY)-((i - ax) * ScreenX, y2 * ScreenY),
Me.GetFadeColor(x)            Next i                    Case
DiagUpperRightGradient            For i = x1 - ax To x2 + ax         
     x = 100 - ((i / x2) * 100)                frm.Line ((i - ax) *
ScreenX, y1 * ScreenY)-((i + ax) * ScreenX, y2 * ScreenY),
Me.GetFadeColor(x)            Next i                    Case
DiagLowerRightGradient            For i = x2 + ax To x1 - ax Step -1 
             x = 100 - ((i / x2) * 100)                frm.Line ((i +
ax) * ScreenX, y1 * ScreenY)-((i - ax) * ScreenX, y2 * ScreenY),
Me.GetFadeColor(x)            Next i                    Case Else    
      ' The gradient is not found!    End SelectEnd Sub Private Sub
PaintObject2(frm As Object, Gradient As ColorFadeGradientConstants,
Optional CycleCount As Long = 1)    Dim ScreenX As Long              
                 'Screen dimension    Dim ScreenY As Long            
                   'Screen dimension    Dim h As Long                
                     'Object Height    Dim w As Long                 
                    'Object Width    Dim y As Long                   
                  'Current Y-Position    Dim x As Long               
                      'Current X-Position    Dim a As Long           
                          'Current Angle Offset Multiplier    Dim ax
As Long                                      'Current Angle Offset   
       Dim x1 As Long, x2 As Long                          'Left and
Right of the object    Dim y1 As Long, y2 As Long                    
    'Top and Bottom of the object        Dim i As Long               
                      'Loop Counter    Dim j As Long                 
                    'Loop Counter    Dim c As Long                   
                  'Cycles or other value        ScreenX =
Screen.TwipsPerPixelX                     'Determine the horizontal
screen dimension    ScreenY = Screen.TwipsPerPixelY                  
 'Determine the vertical screen dimension     x1 = 0: x2 = (frm.Width
/ ScreenX)                  'Get the pixel width of the object    y1 =
0: y2 = (frm.Height / ScreenY)                 'Get the pixel height
of the object                  c = CycleCount    If c < 1 Then c = 1 
                              'Capping the cycle count for slower
computers    If c > 12 Then c = 12     c = c * 2                     
                    'Double it for the rounded effect.        Select
Case Gradient        Case HorizontalGradient            x1 = 0: x2 =
frm.Width            y1 = 1: y2 = Int(frm.Height / (ScreenY * 100)) +
1                For j = y1 To y2                For i = 1 To 100    
              frm.Line (x1, y)-(x2, y), Me.GetFadeColor2(i, c)       
           y = (((ScreenY * 100) * (j - 1)) + (i * ScreenY))         
     Next i            Next j                Case VerticalGradient   
       x1 = 1: x2 = Int(frm.Width / (ScreenX * 100)) + 1            y1
= 0: y2 = frm.Height                For j = x1 To x2               
For i = 1 To 100                    frm.Line (x, y1)-(x, y2),
Me.GetFadeColor2(i, c)                    x = (((ScreenX * 100) * (j -
1)) + (i * ScreenX))                Next i            Next j         
     Case DiagUpperRightGradient, DiagLowerLeftGradient            x1
= 1: x2 = Int(frm.Width / (ScreenX * 100)) + 1            y1 = 0: y2 =
frm.Height                        ax = Int(((y2 / (ScreenY * 100)) +
1) / 2) + 1            a = (y2 / 2)                        For j = x1
- ax To x2 + ax                For i = 1 To 100                   
frm.Line (x - a, y1)-(x + a, y2), Me.GetFadeColor2(i, c)             
     x = (((ScreenX * 100) * (j - 1)) + (i * ScreenX))               
Next i            Next j                Case DiagUpperLeftGradient,
DiagLowerRightGradient            x1 = 1: x2 = Int(frm.Width /
(ScreenX * 100)) + 1            y1 = 0: y2 = frm.Height              
        ax = Int(((y2 / (ScreenY * 100)) + 1) / 2) + 1            a =
(y2 / 2)                        For j = x1 - ax To x2 + ax           
   For i = 1 To 100                    frm.Line (x + a, y1)-(x - a,
y2), Me.GetFadeColor2(i, c)                    x = (((ScreenX * 100) *
(j - 1)) + (i * ScreenX))                Next i            Next j   
End SelectEnd Sub Public Property Let FadeEndColor(ByVal vData As
Long)           'Sets the fade end color and the individual RGB values
   mvarFadeEndColor = vData    Call DetermineRGB(vData, fcer, fceg,
fceb)End Property Public Property Get FadeEndColor() As Long         
           'Returns the fade end color    FadeEndColor =
mvarFadeEndColorEnd Property Public Property Let FadeStartColor(ByVal
vData As Long)         'Sets the fade end color and the individual RGB
values    mvarFadeStartColor = vData    Call DetermineRGB(vData, fcsr,
fcsg, fcsb)End Property Public Property Get FadeStartColor() As Long 
 FadeStartColor = mvarFadeStartColor                         'Returns
the fade start color.End Property Private Sub DetermineRGB(varRGB As
Long, varRed As Long, varGreen As Long, varBlue As Long)      Dim rs$
'String to hold the hex of the color    rs$ = Hex(varRGB)        While
Len(rs$) < 6        rs$ = "0" & rs$    Wend        varRed = Val("&H" &
Mid(rs$, 5, 2))     varGreen = Val("&H" & Mid(rs$, 3, 2))     varBlue
= Val("&H" & Mid(rs$, 1, 2)) End Sub Private Function DetermineFade(R1
As Long, G1 As Long, B1 As Long, R2 As Long, G2 As Long, B2 As Long,
Percent As Long) As Long        Dim fcr As Long     'Red        Dim
fcg As Long     'Green        Dim fcb As Long     'Blue        Dim fcp
As Long     'Percentage                fcp = Percent         If fcp >
100 Then fcp = 100        If fcp < 0 Then fcp = 0                    
          fcr = MidPoint(R1, R2, fcp)             'Interpolate       
fcg = MidPoint(G1, G2, fcp)             'Interpolate        fcb =
MidPoint(B1, B2, fcp)             'Interpolate        DetermineFade =
RGB(fcr, fcg, fcb)      'Return a long number.End Function Private
Function MidPoint(x1 As Long, x2 As Long, p As Long) As Long       '
Interpolation to find a midpoint number based on percentage        If
x1 > x2 Then            MidPoint = x1 - ((x1 - x2) * (p / 100))      
Else            MidPoint = ((x2 - x1) * (p / 100)) + x1        End
IfEnd Function