home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Update_wid2141181222009.psc / mBlendColorAlpha.bas < prev    next >
BASIC Source File  |  2009-01-12  |  1KB  |  46 lines
  1. Attribute VB_Name = "mBlendColorAlpha"
  2. Option Explicit
  3.  
  4. Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  5.  
  6.  
  7. Public Property Get BlendColor( _
  8.       ByVal oColorFrom As OLE_COLOR, _
  9.       ByVal oColorTo As OLE_COLOR, _
  10.       Optional ByVal alpha As Long = 128 _
  11.    ) As Long
  12. Dim lCFrom As Long
  13. Dim lCTo As Long
  14.    lCFrom = TranslateColor(oColorFrom)
  15.    lCTo = TranslateColor(oColorTo)
  16.  
  17. Dim lSrcR As Long
  18. Dim lSrcG As Long
  19. Dim lSrcB As Long
  20. Dim lDstR As Long
  21. Dim lDstG As Long
  22. Dim lDstB As Long
  23.    
  24.    lSrcR = lCFrom And &HFF
  25.    lSrcG = (lCFrom And &HFF00&) \ &H100&
  26.    lSrcB = (lCFrom And &HFF0000) \ &H10000
  27.    lDstR = lCTo And &HFF
  28.    lDstG = (lCTo And &HFF00&) \ &H100&
  29.    lDstB = (lCTo And &HFF0000) \ &H10000
  30.      
  31.    
  32.    BlendColor = RGB( _
  33.       ((lSrcR * alpha) / 255) + ((lDstR * (255 - alpha)) / 255), _
  34.       ((lSrcG * alpha) / 255) + ((lDstG * (255 - alpha)) / 255), _
  35.       ((lSrcB * alpha) / 255) + ((lDstB * (255 - alpha)) / 255) _
  36.       )
  37.  
  38. End Property
  39. Private Function TranslateColor(ByVal clr As OLE_COLOR, _
  40.                         Optional hPal As Long = 0) As Long
  41.     If OleTranslateColor(clr, hPal, TranslateColor) Then
  42.         TranslateColor = -1
  43.     End If
  44. End Function
  45.  
  46.