градиент

[Naked]

никак не получается правильно вывести градиент. При изменении значений переменных r,g,b вообще получается не понятно что. Что нужно изменить, чтобы получился переход определенного цвета от темного к светлому?

[BV]

Типа того...

[Naked]

ну да, типа этого. Но зачем мне сторонняя библа, я так же мог воспользоваться услугами shlwapi.
хоца ручками сварганить

[alibek]

Код: Выделить всё

Public Enum APISystemColors
  scScrollbar = 0
  scBackground = 1
  scActiveCaption = 2
  scInactiveCaption = 3
  scMenu = 4
  scWindow = 5
  scWindowFrame = 6
  scMenuText = 7
  scWindowText = 8
  scCaptionText = 9
  scActiveBorder = 10
  scInactiveBorder = 11
  scAppWorkspace = 12
  scHighlight = 13
  scHighlightText = 14
  scBtnFace = 15
  scBtnShadow = 16
  scGrayText = 17
  scBtnText = 18
  scInactiveCaptionText = 19
  scBtnHighlight = 20
  sc3DDkShadow = 21
  sc3DLight = 22
  scInfoText = 23
  scInfoBackground = 24
  scHotLight = 26
  scGradientActiveCaption = 27
  scGradientInactiveCaption = 28
  scDesktop = scBackground
  sc3DFace = scBtnFace
  sc3DShadow = scBtnShadow
  sc3DHighlight = scBtnHighlight
  sc3DHilight = scBtnHighlight
  scBtnHilight = scBtnHighlight
End Enum
Public Declare Function GetSysColor Lib "user32.dll" (ByVal ColorIndex As APISystemColors) As Long

Public Type TRIVERTEX
  X As Long
  Y As Long
  Red As Integer
  Green As Integer
  Blue As Integer
  Alpha As Integer
End Type
Public Type GRADIENT_TRIANGLE
  Vertex1 As Long
  Vertex2 As Long
  Vertex3 As Long
End Type
Public Type GRADIENT_RECT
  UpperLeft As Long
  LowerRight As Long
End Type
Public Enum GradientFillModes
  GRADIENT_FILL_RECT_H = &H0&
  GRADIENT_FILL_RECT_V = &H1&
  GRADIENT_FILL_TRIANGLE = &H2&
  GRADIENT_FILL_OP_FLAG = &HFF&
End Enum
Public Declare Function GradientFill Lib "msimg32.dll" (ByVal hDC As Long, ptVertex As TRIVERTEX, ByVal VertexCount As Long, ptGradient As Any, ByVal GradientCount As Long, ByVal Mode As GradientFillModes) As Long

Public Function ReturnVertex(ByVal X As Long, ByVal Y As Long, ByVal Color As Long, Optional ByVal Alpha As Byte) As TRIVERTEX
Dim R As Byte, G As Byte, B As Byte, A As Byte
Const UnsignedWord As Long = &H10000, UnsignedSlide As Long = &H100&, UnsignedMask As Long = &HFFFF&
R = (Color And &HFF&)
G = ((Color And &HFF00&) \ &H100&)
B = ((Color And &HFF0000) \ &H10000)
A = ((Color And &HFF000000) \ &H1000000)
If Alpha > 0 Then A = Alpha
With ReturnVertex
  .X = X
  .Y = Y
  .Alpha = A * UnsignedSlide - IIf(A < 128, 0, UnsignedWord)
  .Red = R * UnsignedSlide - IIf(R < 128, 0, UnsignedWord)
  .Green = G * UnsignedSlide - IIf(G < 128, 0, UnsignedWord)
  .Blue = B * UnsignedSlide - IIf(B < 128, 0, UnsignedWord)
End With
End Function

Private Sub DrawGradientText(Control As PictureBox)
Dim S As String, C1 As Long, C2 As Long, ret As Long
Dim V() As TRIVERTEX, R As GRADIENT_RECT
C1 = GetSysColor(sc3DHighlight)
C2 = GetSysColor(sc3DFace)
ReDim V(0 To 1)
V(0) = ReturnVertex(Control.ScaleLeft, Control.ScaleTop + 1, C1)
V(1) = ReturnVertex(Control.ScaleLeft + Control.ScaleWidth, Control.ScaleTop + Control.ScaleHeight - 1, C2)
R.UpperLeft = 0
R.LowerRight = 1
Control.Cls
On Error Resume Next
Call GradientFill(Control.hDC, V(0), ByVal 2&, R, ByVal 1&, GRADIENT_FILL_RECT_H)
If Err.Number <> 0 Then Control.BackColor = C1
On Error GoTo 0
S = Control.Tag
Control.CurrentY = Control.ScaleTop + Fix(Control.ScaleHeight / 2) - Control.TextHeight(S) / 2
Control.CurrentX = 4
Control.Print S;
End Sub


Код: Выделить всё

Picture1.Tag = "test"
RedrawModeLabel Picture1

[keks-n]

Naked
Сам когда-то давно столкнулся с проблемой. Код из API-Guide делал некия неясные преобразования, однако, когда я залез в MSDN оказалось, что вся структура неправильна. Функция использует 2 байта на цвет, а не один. Соответствено нас интересует лишь один из них - второй обнуляем.
Вот код, делающий правильную конвертацию из OLE_COLOR(его возвращает RGB), ну и соответственно сама функция- переходник. Может быть тут что-то и криво, однако код успешно юзался во многих проектах и показал себя вполне работоспособным.

Код: Выделить всё

Option Explicit


Private Type URGBA
    Ignore1 As Byte
    Red As Byte
    Ignore2 As Byte
    Green As Byte 'Ushort value
    Ignore3 As Byte
    Blue As Byte 'ushort value
    Alpha As Integer 'ushort
End Type
Private Type TRIVERTEX
    x As Long
    y As Long
    color As URGBA
End Type
Private Type GRADIENT_RECT
    UpperLeft As Long  'In reality this is a UNSIGNED Long
    LowerRight As Long 'In reality this is a UNSIGNED Long
End Type

Const GRADIENT_FILL_RECT_H As Long = &H0 'In this mode, two endpoints describe a rectangle. The rectangle is
Const GRADIENT_FILL_RECT_V  As Long = &H1 'In this mode, two endpoints describe a rectangle. The rectangle
Const GRADIENT_FILL_OP_FLAG As Long = &HFF
Private 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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Sub GradFill(hdc As Long, X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, UpColor As OLE_COLOR, DownColor As OLE_COLOR, Optional Horizontal As Boolean)
    Dim vert(1) As TRIVERTEX
    Dim gRect As GRADIENT_RECT
    With vert(0)
        .x = X1
        .y = Y1
        .color = RGB2URGBA(UpColor)
        End With
    With vert(1)
        .x = X2
        .y = Y2
        .color = RGB2URGBA(DownColor)
    End With
    gRect.UpperLeft = 0
    gRect.LowerRight = 1
    If Horizontal Then
    GradientFillRect hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_H
    Else
    GradientFillRect hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_V
    End If
End Sub
Private Function RGB2URGBA(color As Long) As URGBA
Dim ret As URGBA
ret.Red = Long2Bytes(color)(0)
ret.Green = Long2Bytes(color)(1)
ret.Blue = Long2Bytes(color)(2)
RGB2URGBA = ret
End Function
Private Function Long2Bytes(ByVal InVar As Long) As Byte()
Dim ret(3) As Byte
CopyMemory ret(0), InVar, 4
Long2Bytes = ret
End Function

Private Sub Form_Paint()
GradFill Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / _
Screen.TwipsPerPixelY, RGB(128, 15, 200), RGB(0, 248, 56)
End Sub

[Viper]

Вот еще вариант вытащенный из пыльного архива (код 96 года примерно). Файл MGradient.bas. Процедура FadeGradient моя (рисует градиенты в любом направлении - слева-направо, сверху-вниз, по диагонали и так далее). Процедура Fade позаимствована у Брюса МакКинни. Мой код с 96 года не менялся (так что могут быть всякие корявости и неоптимальность реализации, ибо писался практически новичком в VB), но работает.

[keks-n]

И где же код?

[Naked]

не, ребят, мне бы хотелось стандартными средствами сделать, без HLSToRGB GradientFill

Код: Выделить всё

r = 255
g = 0
b = 0

For ly6 = 0 To Pic.ScaleHeight

nCol = RGB(r - (ly6 * (r - 255)) / Pic.ScaleHeight, g - (ly6 * (g - 255)) / Pic.ScaleHeight, b - (ly6 * (b - 255)) / Pic.ScaleHeight)
           
nCol = RGB(r - (ly6 * r) / Pic.ScaleHeight, g - (ly6 * g) / Pic.ScaleHeight, b - (ly6 * b) / Pic.ScaleHeight)

Pic.Line (-1, -1)-(Pic.ScaleWidth, ly6), nCol, B
next


вот как бы их объеденить одной формулой

[Viper]

Ндя... файл не прицепился, а щас при попытке прицепить файл выплывает ошибка типа страница недоступна... Что за глюки?

Добавлено:

Код от Брюса Мак Кинни

Код: Выделить всё

Sub Fade(obj As Object, Optional vRed As Variant, _
         Optional vGreen As Variant, Optional vBlue As Variant, _
         Optional vVert As Variant, Optional vHoriz As Variant, _
         Optional vLightToDark As Variant)
    ' Give all optional arguments default values
    If IsMissing(vRed) Then vRed = False
    If IsMissing(vBlue) Then vBlue = False
    If IsMissing(vGreen) Then vGreen = False
    If Not vRed And Not vGreen Then vBlue = True ' Color required
    If IsMissing(vVert) Then vVert = False
    If IsMissing(vHoriz) Then vHoriz = False: vVert = True
    If IsMissing(vLightToDark) Then vLightToDark = True

    ' Trap errors
    On Error Resume Next
    With obj
        ' Save properties
        Dim fAutoRedraw As Boolean, ordDrawStyle As Integer
        Dim ordDrawMode As Integer, iDrawWidth As Integer
        Dim ordScaleMode As Integer
        Dim rScaleWidth As Single, rScaleHeight As Single
        fAutoRedraw = .AutoRedraw: iDrawWidth = .DrawWidth
        ordDrawStyle = .DrawStyle: ordDrawMode = .DrawMode
        rScaleWidth = .ScaleWidth: rScaleHeight = .ScaleHeight
        ordScaleMode = .ScaleMode
        ' Err set if object lacks one of previous properties
        If Err Then Exit Sub
        ' If you get here, object is OK (Printer lacks AutoRedraw)
        On Error GoTo 0
        fAutoRedraw = .AutoRedraw
       
        ' Set properties required for fade
        .AutoRedraw = True
        .DrawWidth = 2   ' Required for dithering
        .DrawStyle = vbInsideSolid: .DrawMode = vbCopyPen
        .ScaleMode = vbPixels
        .ScaleWidth = 256 * 2: .ScaleHeight = 256 * 2
       
        Dim clr As Long, i As Integer, x As Integer, y As Integer
        Dim iRed As Integer, iGreen As Integer, iBlue As Integer
        For i = 0 To 255
            ' Set line color
            If vLightToDark Then
                If vRed Then iRed = 255 - i
                If vBlue Then iBlue = 255 - i
                If vGreen Then iGreen = 255 - i
            Else
                If vRed Then iRed = i
                If vBlue Then iBlue = i
                If vGreen Then iGreen = i
            End If
            clr = RGB(iRed, iGreen, iBlue)
            ' Draw each line of fade
            If vVert Then
                obj.Line (0, y)-(.ScaleWidth, y + 2), clr, BF
                y = y + 2
            End If
            If vHoriz Then
                obj.Line (x, 0)-(x + 2, .ScaleHeight), clr, BF
                x = x + 2
            End If
        Next
        ' Put things back the way you found them
        .AutoRedraw = fAutoRedraw: .DrawWidth = iDrawWidth
        .DrawStyle = ordDrawStyle: .DrawMode = ordDrawMode
        .ScaleMode = ordScaleMode
        .ScaleWidth = rScaleWidth: .ScaleHeight = rScaleHeight
    End With
End Sub

тут главное смысл идеи понять

[keks-n]

Мдя. Жутко шустро. Особенно через Line.

[BV]

ну да, типа этого. Но зачем мне сторонняя библа, я так же мог воспользоваться услугами shlwapi.
хоца ручками сварганить

Библа не сторонняя, библа моя. Могу дать функции преобразований RGB->HSL/HSL->RGB на VB...

[Naked]

BV а у меня есть такие, работают не так как хотелось бы

[Naked]

ну что, мыслей больше нет, как это сделать?

[BV]

Naked, ты, видимо, так и не понял.

Правильную яркость цвета можно задать только через YUV/HSL модели.