Imports System.Runtime.InteropServices

Module ModuleGradBkG
  <StructLayout(LayoutKind.Sequential)>
  Private Structure TRIVERTEX
    Dim x As Integer
    Dim y As Integer
    Dim Red As Int16
    Dim Green As Int16
    Dim Blue As Int16
    Dim Alpha As Int16
  End Structure

  <StructLayout(LayoutKind.Sequential)>
  Private Structure GRADIENT_TRIANGLE
    Dim Vertex1 As Integer
    Dim Vertex2 As Integer
    Dim Vertex3 As Integer
  End Structure

  <StructLayout(LayoutKind.Explicit)>
  Private Structure TLongXX
    <FieldOffset(0)>
    Dim L0 As Integer

    <FieldOffset(0)>
    Dim I0 As Int16

    <FieldOffset(2)>
    Dim I1 As Int16

    <FieldOffset(0)>
    Dim Red As Byte

    <FieldOffset(1)>
    Dim Green As Byte

    <FieldOffset(2)>
    Dim Blue As Byte

    <FieldOffset(3)>
    Dim Alpha As Byte
  End Structure


  Private Enum GradientFillMode
    GRADIENT_FILL_RECT_H
    GRADIENT_FILL_RECT_V
    GRADIENT_FILL_TRIANGLE
    GRADIENT_FILL_OP_FLAG = 255
  End Enum

  Private Declare Function GradientFill Lib "msimg32" ( _
   ByVal hdc As IntPtr, ByRef pVertex As TRIVERTEX, ByVal dwNumVertex As Integer, _
   ByRef pMesh As GRADIENT_TRIANGLE, ByVal dwNumMesh As Integer, _
   ByVal dwMode As GradientFillMode) As Boolean

  Private Const TRIVERTEX_MAX_ALPHA As Int16 = -256 '&HFF00

  Private Sub SetupVerticesPlus(ByRef v0() As TRIVERTEX, ByRef v1() As TRIVERTEX, ByRef v2() As TRIVERTEX, _
   ByVal b As Integer, ByVal u As Integer, ByVal s As Integer, ByRef disablestatic As Boolean)  'установка координат узлов сетки

    Dim i, x As Integer
    Static bSetup As Boolean
    If disablestatic Then
      bSetup = False
      Exit Sub
    End If
    If bSetup Then Exit Sub
    For i = 0 To b
      x = i * s
      With v0(i) : .x = x : .y = 0 : End With
      With v0((b + 1) + i) : .x = x : .y = u - 1 : End With
      With v1(i) : .x = x : .y = u - 1 : End With
      With v1((b + 1) + i) : .x = x : .y = u * 2 - 1 : End With
      With v2(i) : .x = x : .y = u * 2 - 1 : End With
      With v2((b + 1) + i) : .x = x : .y = u * 2 : End With
    Next i
    bSetup = True
  End Sub

  Private Sub SetupTriangles(ByRef t() As GRADIENT_TRIANGLE, ByVal b As Integer, _
   ByRef disablestatic As Boolean) 'установка (списка вершин) треугольников

    Dim i As Integer
    Dim k As Integer
    Static bSetup As Boolean
    If disablestatic Then
      bSetup = False
      Exit Sub
    End If
    If bSetup Then Exit Sub
    For i = 0 To b - 1
      With t(k)
        .Vertex1 = i
        .Vertex2 = .Vertex1 + (b + 1)
        .Vertex3 = .Vertex2 + 1
      End With
      k = k + 1
      With t(k)
        .Vertex1 = i
        .Vertex2 = .Vertex1 + 1
        .Vertex3 = .Vertex2 + (b + 1)
      End With
      k = k + 1
    Next i
    bSetup = True
  End Sub

  Private Function TransientColor(ByVal TransitionCoeff As Double, _
                                  ByVal Component0 As Integer, _
                                  ByVal Component1 As Byte) As Integer
    'Степень перехода одного цвета в другой 0.0 <= TransitionCoeff <= 1.0
    Dim L As TLongXX 'TLongX1
    L.L0 = (TransitionCoeff * (CInt(Component1) - CInt(Component0)) + _
     Component0) * 256
    Return L.I0
  End Function

  Private Sub SetupColorsPlus(ByRef v0() As TRIVERTEX, ByRef v1() As TRIVERTEX, ByRef v2() As TRIVERTEX, _
   ByVal Color0 As Integer, ByVal Color1 As Integer, _
   ByVal Color2 As Integer, ByVal Color3 As Integer, _
   ByVal Color4 As Integer, ByVal Color5 As Integer, _
   ByVal Color6 As Integer, ByVal Color7 As Integer, _
   ByVal Color8 As Integer, ByVal Color9 As Integer, _
   ByVal Color10 As Integer, ByVal Color11 As Integer, _
   ByVal b As Integer) 'Установка цветов вершин

    Dim Q(0 To 11) As TLongXX
    Q(0).L0 = Color0 : Q(1).L0 = Color1 : Q(2).L0 = Color2 : Q(3).L0 = Color3
    Q(4).L0 = Color4 : Q(5).L0 = Color5 : Q(6).L0 = Color6 : Q(7).L0 = Color7
    Q(8).L0 = Color8 : Q(9).L0 = Color9 : Q(10).L0 = Color10 : Q(11).L0 = Color11

    Dim i As Integer
    Dim tc As Double
    For i = 0 To b
      tc = i / b
      With v0(0 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(0).Red, Q(1).Red)
        .Green = TransientColor(tc, Q(0).Green, Q(1).Green)
        .Blue = TransientColor(tc, Q(0).Blue, Q(1).Blue)
      End With
      With v0(1 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(2).Red, Q(3).Red)
        .Green = TransientColor(tc, Q(2).Green, Q(3).Green)
        .Blue = TransientColor(tc, Q(2).Blue, Q(3).Blue)
      End With
      With v1(0 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(4).Red, Q(5).Red)
        .Green = TransientColor(tc, Q(4).Green, Q(5).Green)
        .Blue = TransientColor(tc, Q(4).Blue, Q(5).Blue)
      End With
      With v1(1 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(6).Red, Q(7).Red)
        .Green = TransientColor(tc, Q(6).Green, Q(7).Green)
        .Blue = TransientColor(tc, Q(6).Blue, Q(7).Blue)
      End With
      With v2(0 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(8).Red, Q(9).Red)
        .Green = TransientColor(tc, Q(8).Green, Q(9).Green)
        .Blue = TransientColor(tc, Q(8).Blue, Q(9).Blue)
      End With
      With v2(1 * (b + 1) + i)
        .Alpha = TRIVERTEX_MAX_ALPHA
        .Red = TransientColor(tc, Q(10).Red, Q(11).Red)
        .Green = TransientColor(tc, Q(10).Green, Q(11).Green)
        .Blue = TransientColor(tc, Q(10).Blue, Q(11).Blue)
      End With
    Next i
  End Sub

  Public Function CreateGradientBackComplexPlus( _
   ByVal hwndRef As IntPtr, _
   ByVal Width As Integer, ByVal Height As Integer, _
   Optional ByVal Color0 As Integer = &HB89D74, _
   Optional ByVal Color1 As Integer = &HBAB381, _
   Optional ByVal Color2 As Integer = &H90672C, _
   Optional ByVal Color3 As Integer = &H94893D, _
   Optional ByVal Color4 As Integer = &H6A3D02, _
   Optional ByVal Color5 As Integer = &H6C6113, _
   Optional ByVal Color6 As Integer = &HA68A43, _
   Optional ByVal Color7 As Integer = &HA7A050, _
   Optional ByVal Color8 As Integer = 13549715, _
   Optional ByVal Color9 As Integer = 13618330, _
   Optional ByVal Color10 As Integer = 0, _
   Optional ByVal Color11 As Integer = 0) As IntPtr

    'ф-ция создает градиент в стиде Explorer с двойной полосой (светлая, черная) внизу
    'предполагается (субъективно конечно) что .cyMinChild = 33 (или 25) -нечетное число, иначе чуть ошибется

    Dim v0() As TRIVERTEX 'массив вершин верхней полосы
    Dim v1() As TRIVERTEX 'массив вершин нижней полосы
    Dim v2() As TRIVERTEX 'массив вершин полоски в самом низу
    Dim t() As GRADIENT_TRIANGLE  'массив треугольников
    Dim b As Integer 'количество клеток сетки по горизонтали
    Dim u As Integer 'шаг узлов сетки по вертикали
    Dim s As Integer 'шаг узлов сетки по горизонтали
    'Каждая клетка сетки состоит из двух треугольников

    s = 10 'шаг узлов сетки по горизонтали
    b = Width / s + 1 'количество клеток сетки по горизонтали;+1-страховка
    u = (Height - 2) / 2 'шаг узлов сетки по вертикали u = 16 две клетки,кот.растягиваем
    'подстраиваем размерности массивов
    ReDim v0(0 To b * 2 + 1) 'массив вершин верхней полосы
    ReDim v1(0 To b * 2 + 1) 'массив вершин нижней полосы
    ReDim v2(0 To b * 2 + 1) 'массив вершин полоски в самом низу
    ReDim t(0 To b * 2 - 1) 'массив треугольников

    SetupVerticesPlus(v0, v1, v2, b, u, s, True) 'отмена bSetup
    SetupTriangles(t, b, True) 'отмена bSetup

    SetupVerticesPlus(v0, v1, v2, b, u, s, False)
    SetupTriangles(t, b, False)
    SetupColorsPlus(v0, v1, v2, _
               Color0, Color1, _
               Color2, Color3, _
               Color4, Color5, _
               Color6, Color7, _
               Color8, Color9, _
               Color10, Color11, _
               b)

    Dim bmp = New Bitmap(b * s, u * 2 + 1, Imaging.PixelFormat.Format32bppArgb)
    Dim gr = Graphics.FromImage(bmp)
    ' Get the hDC from the Graphics object.
    Dim hdc As IntPtr = gr.GetHdc()
    GradientFill(hdc, v0(0), 2 * (b + 1), t(0), b * 2, GradientFillMode.GRADIENT_FILL_TRIANGLE)
    GradientFill(hdc, v1(0), 2 * (b + 1), t(0), b * 2, GradientFillMode.GRADIENT_FILL_TRIANGLE)
    GradientFill(hdc, v2(0), 2 * (b + 1), t(0), b * 2, GradientFillMode.GRADIENT_FILL_TRIANGLE)
    gr.ReleaseHdc(hdc)
    Dim hBitmap As IntPtr = bmp.GetHbitmap()
    gr.Dispose()
    bmp.Dispose()
    Return hBitmap

  End Function
End Module