Draw Arc Gradient GDI+

[LeandroA]

Hello, I was developing a function to draw a degraded arc, before asking how it would be done, I would try to do it myself, but the question remains: perhaps there was another way to do it, although this function meets my expectations, on some occasions there is a crash by GDI +, I think it is when the brush is not big enough to paint the indicated area.

the function was developed to later create something like this (not for a color palette)
Attachment 176271

my result
Attachment 176273
Attachment 176275

Option Explicit

Private Declare Function GdipDrawArcI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long, ByVal mStartAngle As Single, ByVal mSweepAngle As Single) As Long
Private Declare Function GdipCreatePen2 Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mWidth As Single, ByVal mUnit As Long, ByRef mPen As Long) As Long
Private Declare Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As Long) As Long
Private Declare Function GdipFlattenPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mMatrix As Long, ByVal mFlatness As Single) As Long
Private Declare Function GdipFillPath Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mPath As Long) As Long
Private Declare Function GdipGetPointCount Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mCount As Long) As Long
Private Declare Function GdipRotatePathGradientTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mAngle As Single, ByVal mOrder As MatrixOrder) As Long
Private Declare Function GdipTranslatePathGradientTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As MatrixOrder) As Long
Private Declare Function GdipTranslateTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As MatrixOrder) As Long
Private Declare Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal dX As Single, ByVal dY As Single, ByVal Order As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Declare Function GdipAddPathArcI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long, ByVal mStartAngle As Single, ByVal mSweepAngle As Single) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GdipSetPenEndCap Lib "GdiPlus.dll" (ByVal mPen As Long, ByVal mEndCap As LineCap) As Long
Private Declare Function GdipSetPenStartCap Lib "GdiPlus.dll" (ByVal mPen As Long, ByVal mStartCap As LineCap) As Long

Public Enum LineCap
    LineCapFlat = &H0
    LineCapSquare = &H1
    LineCapRound = &H2
    LineCapTriangle = &H3
    LineCapNoAnchor = &H10
    LineCapSquareAnchor = &H11
    LineCapRoundAnchor = &H12
    LineCapDiamondAnchor = &H13
    LineCapArrowAnchor = &H14
    LineCapCustom = &HFF
    LineCapAnchorMask = &HF0
End Enum


Private Enum MatrixOrder
    MatrixOrderPrepend = &H0
    MatrixOrderAppend = &H1
End Enum

Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              As Long
End Type
  
Private Const SmoothingModeAntiAlias    As Long = &H4

Dim GdipToken As Long
Dim Colors() As Long

Private Sub Form_Load()
    Call InitGDI
    Me.AutoRedraw = True
    
'    ReDim Colors(2)
'    Colors(0) = Color_RGBtoARGB(vbBlue, 255)
'    Colors(1) = Color_RGBtoARGB(vbGreen, 255)
'    Colors(2) = Color_RGBtoARGB(vbRed, 255)

    ReDim Colors(6)
    Colors(0) = Color_RGBtoARGB(vbRed, 255)
    Colors(1) = Color_RGBtoARGB(vbMagenta, 255)
    Colors(2) = Color_RGBtoARGB(vbBlue, 255)
    Colors(3) = Color_RGBtoARGB(vbCyan, 255)
    Colors(4) = Color_RGBtoARGB(vbGreen, 255)
    Colors(5) = Color_RGBtoARGB(vbYellow, 255)
    Colors(6) = Color_RGBtoARGB(vbRed, 255)
    
    HScroll1(0).Max = Me.ScaleWidth / 1.5 / Screen.TwipsPerPixelX / 2: HScroll1(0).Value = 5
    HScroll1(1).Max = 360: HScroll1(1).Value = 10
    HScroll1(2).Max = 360: HScroll1(2).Value = 180
    HScroll1(3).Max = 360: HScroll1(3).Value = 180
    
End Sub

Private Function ShiftColor(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal Proportion As Long) As Long
  
    Dim clrFore(3) As Byte
    Dim clrBack(3) As Byte
    Dim cResult(3) As Byte
    Dim R As Long
    
    clrFore(0) = (clrFirst And &HFF)
    clrFore(1) = (clrFirst And &HFF00&) \ &H100
    clrFore(2) = (clrFirst And &HFF0000) \ &H10000
    clrFore(3) = (clrFirst And &HFF000000) \ &H1000000 And &HFF

    clrBack(0) = (clrSecond And &HFF)
    clrBack(1) = (clrSecond And &HFF00&) \ &H100
    clrBack(2) = (clrSecond And &HFF0000) \ &H10000
    clrBack(3) = (clrSecond And &HFF000000) \ &H1000000 And &HFF

    R = (&HFF - Proportion)
    cResult(0) = (clrFore(0) * Proportion + clrBack(0) * R) / &HFF
    cResult(1) = (clrFore(1) * Proportion + clrBack(1) * R) / &HFF
    cResult(2) = (clrFore(2) * Proportion + clrBack(2) * R) / &HFF
    cResult(3) = (clrFore(3) * Proportion + clrBack(3) * R) / &HFF
    
    If cResult(3) < 128& Then
        ShiftColor = cResult(3) * &H1000000
    Else
        ShiftColor = (cResult(3) - 128&) * &H1000000 Or &H80000000
    End If
    ShiftColor = ShiftColor Or CLng(cResult(2)) * &H10000 Or CLng(cResult(1)) * &H100 Or cResult(0)

End Function
  
Private Sub Form_Unload(Cancel As Integer)
    Call TerminateGDI
End Sub

Public Function DrawGradientArc(ByVal hdc As Long, _
                                ByRef lColors() As Long, _
                                ByVal X As Long, ByVal Y As Long, _
                                ByVal Width As Long, ByVal Height As Long, _
                                ByVal PenWidth As Long, ByVal ColorsAngle As Long, _
                                ByVal mStartAngle As Single, ByVal mSweepAngle As Single, _
                                Optional ByVal LineCap As LineCap = LineCapFlat) As Boolean
  
    Dim hGraphics As Long
    Dim mPath As Long
    Dim hBrush As Long
    Dim hPen As Long
    Dim pColors() As Long
    Dim lCount As Long
    Dim num_pts  As Long
    Dim index As Integer
    Dim i As Integer, j As Integer, n As Integer, T As Integer
    Dim PenM As Integer
    
    PenM = PenWidth / 2
    
    If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
        GdipCreatePath &H0, mPath
        If ColorsAngle <> 0 Then
            GdipAddPathEllipseI mPath, 0, 0, -Width, -Height
        Else
            GdipAddPathEllipseI mPath, X, Y, Width, Height
        End If
        GdipFlattenPath mPath, 0, 0.1
        GdipCreatePathGradientFromPath mPath, hBrush
        GdipGetPointCount mPath, lCount
        GdipDeletePath mPath
        
        num_pts = (lCount - 1) / UBound(lColors)
        ReDim pColors(lCount - 1)
     
        For i = 0 To UBound(lColors) - 1
            If i < UBound(lColors) - 1 Then n = (i + 1) * num_pts Else n = lCount - 1
            T = n - index
            For j = 0 To T
                pColors(index) = ShiftColor(lColors(i + 1), lColors(i), j * 255& / T)
                index = index + 1
            Next
        Next

        GdipSetPathGradientSurroundColorsWithCount hBrush, pColors(0), lCount - 1

        If ColorsAngle <> 0 Then
            GdipRotatePathGradientTransform hBrush, ColorsAngle + 180, MatrixOrderAppend
            GdipTranslatePathGradientTransform hBrush, Width / 2, Height / 2, MatrixOrderPrepend
            GdipTranslateWorldTransform hGraphics, X + Width / 2, Y + Height / 2, MatrixOrderPrepend
            GdipCreatePen2 hBrush, PenWidth - 1, &H2, hPen '-1 is for prevent some crash error
            If LineCap <> LineCapFlat Then
                GdipSetPenStartCap hPen, LineCap
                GdipSetPenEndCap hPen, LineCap
            End If
            GdipDrawArcI hGraphics, hPen, -Width / 2 + PenM, -Height / 2 + PenM, Width - PenWidth, Height - PenWidth, mStartAngle, mSweepAngle
            GdipDeletePen hPen
            'GdipFillEllipseI hGraphics, hBrush, Width / 2, Height / 2, -Width, -Height
        Else
            GdipCreatePen2 hBrush, PenWidth - 1, &H2, hPen '-1 is for prevent some crash error
            If LineCap <> LineCapFlat Then
                GdipSetPenStartCap hPen, LineCap
                GdipSetPenEndCap hPen, LineCap
            End If
            GdipDrawArcI hGraphics, hPen, X + PenM, Y + PenM, Width - PenWidth, Height - PenWidth, mStartAngle, mSweepAngle
            GdipDeletePen hPen
            'GdipFillEllipseI hGraphics, hBrush, X, Y, Width, Height
        End If
        
        GdipDeleteBrush hBrush
        GdipDeleteGraphics hGraphics
    End If
  
End Function

Public Function Color_RGBtoARGB(ByVal RGBColor As Long, ByVal Opacity As Long) As Long
    'By LaVople
    ' GDI+ color conversion routines. Most GDI+ functions require ARGB format vs standard RGB format
    ' This routine will return the passed RGBcolor to RGBA format
    ' Passing VB system color constants is allowed, i.e., vbButtonFace
    ' Pass Opacity as a value from 0 to 255

    If (RGBColor And &H80000000) Then RGBColor = GetSysColor(RGBColor And &HFF&)
    Color_RGBtoARGB = (RGBColor And &HFF00&) Or (RGBColor And &HFF0000) \ &H10000 Or (RGBColor And &HFF) * &H10000
    If Opacity < 128 Then
        If Opacity < 0& Then Opacity = 0&
        Color_RGBtoARGB = Color_RGBtoARGB Or Opacity * &H1000000
    Else
        If Opacity > 255& Then Opacity = 255&
        Color_RGBtoARGB = Color_RGBtoARGB Or (Opacity - 128&) * &H1000000 Or &H80000000
    End If
    
End Function

'Inicia GDI+
Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = 1&
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
  
'Termina GDI+
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub

Private Sub Draw()
    Dim Size As Long
    
    Size = Me.ScaleWidth / 1.5 / Screen.TwipsPerPixelX
    Cls
        
    DrawGradientArc Me.hdc, Colors, 50, 10, Size, Size, _
        HScroll1(0).Value, HScroll1(1).Value, HScroll1(2).Value, _
        HScroll1(3).Value, IIf(Check1.Value, LineCapRound, LineCapFlat)
        
    Me.Refresh
End Sub

Private Sub HScroll1_Change(index As Integer)
    Draw
End Sub

Private Sub HScroll1_Scroll(index As Integer)
    Draw
End Sub

Private Sub Check1_Click()
    Draw
End Sub

PD: Something is wrong with forum attachments

[LaVolpe]

Unless GdipCreatePen2 is documented somewhere as having problems crashing, that may just be a symptom and not the reason. From my experience, GDI+ crashes due to not being shutdown properly, passing param ByVal vs. ByRef or vice versa, and/or passing an object that has been destroyed or deleting an object that wasn't created (didn't check API return values). One thing I would suggest is to verify your path, pen, & brush are created, no errors. As nutty as it sounds, sometimes intermittent crashing is due to CopyMemory usage elsewhere in the project. In those cases, the IDE doesn't crash all the time, but when compiled, the crashes are more frequent or always.

Double check your ByRef/ByVal parameters. For example, the count in GdipSetPathGradientSurroundColorsWithCount is ByRef per your API declaration and you appear to be passing it like ByVal. In your case, since it's an expression, maybe VB creates a temp variable internally and passes a pointer to that temp variable?

Out of curiosity, what is the value of PenWidth when crashes occur? And by the way, the parameter is Single though you are passing Long, but that shouldn't be reason for crashing since the parameter is ByVal. This was just an FYI item.