home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Ultraconta21647710102009.psc / UltraContainer / mod_Gradient.bas < prev    next >
BASIC Source File  |  2009-10-10  |  4KB  |  145 lines
  1. Attribute VB_Name = "mod_Gradient"
  2. Option Explicit
  3.  
  4. Public Type RECT
  5.         Left As Long
  6.         Top As Long
  7.         Right As Long
  8.         Bottom As Long
  9. End Type
  10.  
  11. Const CLR_INVALID = -1
  12.  
  13. Public Declare Function SetWindowRgn Lib "user32" _
  14.     (ByVal hwnd As Long, ByVal hRgn As Long, _
  15.     ByVal blnRedraw As Boolean) As Long
  16.  
  17. Public Declare Function CreateRoundRectRgn Lib "gdi32" _
  18.     (ByVal RectX1 As Long, ByVal RectY1 As Long, ByVal RectX2 As Long, _
  19.     ByVal RectY2 As Long, ByVal EllipseWidth As Long, _
  20.     ByVal EllipseHeight As Long) As Long
  21.     
  22. Public Declare Function FillRect Lib "user32" ( _
  23.    ByVal hDC As Long, lpRect As RECT, _
  24.    ByVal hBrush As Long) As Long
  25. Public Declare Function DeleteObject Lib "gdi32" ( _
  26.    ByVal hObject As Long) As Long
  27.  
  28. Public Declare Function CreateSolidBrush Lib "gdi32" ( _
  29.    ByVal crColor As Long) As Long
  30.    
  31.  
  32. Private Declare Function GradientFill Lib "msimg32" ( _
  33.    ByVal hDC As Long, _
  34.    pVertex As TRIVERTEX, _
  35.    ByVal dwNumVertex As Long, _
  36.    pMesh As GRADIENT_RECT, _
  37.    ByVal dwNumMesh As Long, _
  38.    ByVal dwMode As Long) As Long
  39.  
  40. Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" ( _
  41.    ByVal OLE_COLOR As Long, _
  42.    ByVal HPALETTE As Long, _
  43.    pccolorref As Long) As Long
  44.    
  45. Public Type TRIVERTEX
  46.    x As Long
  47.    y As Long
  48.    Red As Integer
  49.    Green As Integer
  50.    Blue As Integer
  51.    alpha As Integer
  52. End Type
  53.  
  54. Public Type GRADIENT_RECT
  55.     UpperLeft As Long
  56.     LowerRight As Long
  57. End Type
  58.  
  59.  
  60. Public Const LWA_COLORKEY = 1
  61. Public Const LWA_ALPHA = 2
  62. Public Const LWA_BOTH = 3
  63. Public Const WS_EX_LAYERED = &H80000
  64. Public Const GWL_EXSTYLE = -20
  65. Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal Color As Long, ByVal x As Byte, ByVal alpha As Long) As Boolean
  66. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  67. Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  68.  
  69. Public Sub GradientFillRect( _
  70.       ByVal lHDC As Long, _
  71.       tR As RECT, _
  72.       ByVal oStartColor As OLE_COLOR, _
  73.       ByVal oEndColor As OLE_COLOR, _
  74.       ByVal eDir As Long _
  75.    )
  76. Dim hBrush As Long
  77. Dim lStartColor As Long
  78. Dim lEndColor As Long
  79.    
  80.    ' Use GradientFill:
  81.    lStartColor = TranslateColor(oStartColor)
  82.    lEndColor = TranslateColor(oEndColor)
  83.  
  84.    Dim tTV(0 To 1) As TRIVERTEX
  85.    Dim tGR As GRADIENT_RECT
  86.    
  87.    setTriVertexColor tTV(0), lStartColor
  88.    tTV(0).x = tR.Left
  89.    tTV(0).y = tR.Top
  90.    setTriVertexColor tTV(1), lEndColor
  91.    tTV(1).x = tR.Right
  92.    tTV(1).y = tR.Bottom
  93.    
  94.    tGR.UpperLeft = 0
  95.    tGR.LowerRight = 1
  96.    
  97.    GradientFill lHDC, tTV(0), 2, tGR, 1, eDir
  98.       
  99.    If (Err.Number <> 0) Then
  100.       ' Fill with solid brush:
  101.       hBrush = CreateSolidBrush(TranslateColor(oEndColor))
  102.       FillRect lHDC, tR, hBrush
  103.       DeleteObject hBrush
  104.    End If
  105.    
  106. End Sub
  107.  
  108.  
  109. Public Function TranslateColor( _
  110.     ByVal oClr As OLE_COLOR, _
  111.     Optional hPal As Long = 0 _
  112.     ) As Long
  113.     ' Convert Automation color to Windows color
  114.     If OleTranslateColor(oClr, hPal, TranslateColor) Then
  115.         TranslateColor = CLR_INVALID
  116.     End If
  117. End Function
  118.  
  119. Private Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
  120.     Dim lRed As Long
  121.     Dim lGreen As Long
  122.     Dim lBlue As Long
  123.    lRed = (lColor And &HFF&) * &H100&
  124.    lGreen = (lColor And &HFF00&)
  125.    lBlue = (lColor And &HFF0000) \ &H100&
  126.    setTriVertexColorComponent tTV.Red, lRed
  127.    setTriVertexColorComponent tTV.Green, lGreen
  128.    setTriVertexColorComponent tTV.Blue, lBlue
  129. End Sub
  130.  
  131. Private Sub setTriVertexColorComponent( _
  132.    ByRef iColor As Integer, _
  133.    ByVal lComponent As Long _
  134.    )
  135.    If (lComponent And &H8000&) = &H8000& Then
  136.       iColor = (lComponent And &H7F00&)
  137.       iColor = iColor Or &H8000
  138.    Else
  139.       iColor = lComponent
  140.    End If
  141. End Sub
  142.  
  143.  
  144.  
  145.