Attribute VB_Name = "ModBorders"
Option Explicit

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
        X As Long
        Y As Long
End Type


Public Const BDR_INNER = &HC
Public Const BDR_OUTER = &H3
Public Const BDR_RAISED = &H5 '**********
Public Const BDR_RAISEDINNER = &H4 '**********
Public Const BDR_RAISEDOUTER = &H1
Public Const BDR_SUNKEN = &HA '**********
Public Const BDR_SUNKENINNER = &H8 '**********
Public Const BDR_SUNKENOUTER = &H2

' Combinaisons des constantes BRD_
Public Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Public Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Public Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Public Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)

' Constantes du parametre grfFlags
Public Const BF_FLAT = &H4000
Public Const BF_LEFT = &H1
Public Const BF_MONO = &H8000
Public Const BF_MIDDLE = &H800
Public Const BF_RIGHT = &H4
Public Const BF_SOFT = &H1000
Public Const BF_TOP = &H2
Public Const BF_ADJUST = &H2000
Public Const BF_BOTTOM = &H8
Public Const BF_DIAGONAL = &H10

Public Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Public Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
Public Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Public Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Public Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Public Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Public Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Public Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Public Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)

Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long


Public Type Type_RGB
    R As Integer
    G As Integer
    B As Integer
End Type

Public Type TRIVERTEX
    X As Long
    Y As Long
    R As Integer
    G As Integer
    B As Integer
    Alpha As Integer
End Type

Public Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type

Public cGrad1 As Type_RGB
Public cGrad2 As Type_RGB
Public cGrad3 As Type_RGB

Public Const GRADIENT_FILL_RECT_H As Long = &H0
Public Const GRADIENT_FILL_RECT_V  As Long = &H1

Public Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long 'OK
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long


'//Position=0 ColorOut   --> en dehors
'//Position=1 ColorIn     -> sur l'object
'//Position=2 ColorDown  --> position mouseDown sur 'object
Public Sub DrawArrowBox(Obj As Object, Position As Integer, ColorOut As Long, ColorIn As Long, ColorDown As Long)
On Error Resume Next
    Dim lhdc As Long
    Dim lcw As Long, lch As Long
    Dim hPen As Long, hPenOld As Long
    Dim pt As POINTAPI
    Dim MyColor As Long
    Dim nHe As Long, nWi As Long
    
Dim R As RECT
Dim m_DebColor As Long, m_EndColor As Long, m_MidColor As Long
    
    Obj.Cls
    Obj.ScaleMode = 3
    lcw = Obj.ScaleWidth - 5
    lch = Obj.ScaleHeight / 2
    lhdc = Obj.hDC
    nHe = Obj.ScaleHeight
    nWi = Obj.ScaleWidth

On Error Resume Next
  
  m_EndColor = &HD5C0B3  ' &HC7AD9C
  m_MidColor = &HFEFFFF
  
  cGrad1 = GetRGBtoHexa(GetColorToLong(m_EndColor))
  cGrad3 = GetRGBtoHexa(GetColorToLong(m_MidColor))
          
SetRect R, 0, 6, nWi - 1, nHe
   DrawFromToGrad Obj.hDC, R, cGrad3, cGrad1, GRADIENT_FILL_RECT_V
    
    
    
   If Position = 0 Then
      MyColor = ColorOut
   ElseIf Position = 1 Then
      MyColor = ColorIn
   ElseIf Position = 2 Then
      MyColor = ColorDown
   End If
    
   hPen = CreatePen(0, 1, MyColor)
    
    hPenOld = SelectObject(lhdc, hPen)
    MoveToEx lhdc, lcw - 4, lch - 1, pt
    LineTo lhdc, lcw + 3, lch - 1
    MoveToEx lhdc, lcw - 3, lch, pt
    LineTo lhdc, lcw + 2, lch
    MoveToEx lhdc, lcw - 2, lch + 1, pt
    LineTo lhdc, lcw + 1, lch + 1
    MoveToEx lhdc, lcw - 1, lch + 2, pt
    LineTo lhdc, lcw, lch + 2
    SelectObject lhdc, hPenOld
    DeleteObject hPen
    DeleteObject hPenOld
    
End Sub

Private Sub GetRGB(ByVal Color As Long, ByRef R, ByRef G, ByRef B)
    Color = OleColorToRGB(Color)
    B = ((((Color \ 65536) And 255) * 50) + (((Color \ 65536) And 255) * 50)) \ 100
    G = ((((Color \ 256) And 255) * 50) + (((Color \ 256) And 255) * 50)) \ 100
    R = (((Color And 255) * 50) + ((Color And 255) * 50)) \ 100
End Sub
Public Function OleColorToRGB(ByVal Color As OLE_COLOR) As Long
    If Color And &H80000000 Then
        OleColorToRGB = GetSysColor(Color Xor &H80000000)
    Else
        OleColorToRGB = Color
    End If
End Function

Public Function GetRGBtoHexa(Color As Long) As Type_RGB
    Dim HexColor As String
    
    HexColor = String(6 - Len(Hex(Color)), "0") & Hex(Color)
    GetRGBtoHexa.R = "&H" & Mid(HexColor, 5, 2) & "00"
    GetRGBtoHexa.G = "&H" & Mid(HexColor, 3, 2) & "00"
    GetRGBtoHexa.B = "&H" & Mid(HexColor, 1, 2) & "00"
End Function

Public Function GetColorToLong(Color As Long) As Long
    If Color And &H80000000 Then
       GetColorToLong = GetSysColor(Color And &H7FFFFFFF)
    Else
       GetColorToLong = Color
    End If
End Function


Public Sub DrawFromToGrad(ByVal hDC As Long, R As RECT, _
                        Color1 As Type_RGB, Color2 As Type_RGB, _
                        Direction As Long)

    Dim V(1) As TRIVERTEX
    Dim GRct As GRADIENT_RECT
    
    '// de
    With V(0)
        .X = R.Left
        .Y = R.Top
        .R = Color1.R
        .G = Color1.G
        .B = Color1.B
        .Alpha = 0
    End With
    '// à
    With V(1)
        .X = R.Right
        .Y = R.Bottom
        .R = Color2.R
        .G = Color2.G
        .B = Color2.B
        .Alpha = 0
    End With
    
    GRct.UpperLeft = 0
    GRct.LowerRight = 1

    GradientFillRect hDC, V(0), 2, GRct, 1, Direction

End Sub
















