home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / sub-pixel_20260610192006.psc / modSubPixel.bas < prev    next >
BASIC Source File  |  2006-10-20  |  3KB  |  113 lines
  1. Attribute VB_Name = "modSubPixel"
  2. Option Explicit
  3.  
  4. Type RGBColor
  5.     Red     As Integer
  6.     Green   As Integer
  7.     Blue    As Integer
  8. End Type
  9.  
  10. Private Type Pixel
  11.     x       As Long
  12.     y       As Long
  13.     Color   As Long
  14.     Area    As Single
  15. End Type
  16.  
  17. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  18. Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  19. '
  20.  
  21. Public Sub DrawPixel(DestHDC As Long, _
  22.                      x As Long, y As Long, _
  23.                      Optional Color As Long = 0)
  24.                      
  25.     SetPixel DestHDC, x, y, Color
  26.     
  27.     
  28. End Sub
  29. '
  30.  
  31. Public Sub DrawSubPixel(DestHDC As Long, _
  32.                         x As Single, y As Single, _
  33.                         Optional Color As Long = 0)
  34.     
  35.     Dim a   As Pixel
  36.     Dim b   As Pixel
  37.     Dim c   As Pixel
  38.     Dim d   As Pixel
  39.     
  40.     a.x = Int(x)
  41.     a.y = Int(y)
  42.     a.Color = GetPixel(DestHDC, a.x, a.y)
  43.     a.Area = (a.x - x + 1) * (a.y - y + 1)
  44.     
  45.     b.x = a.x + 1
  46.     b.y = a.y
  47.     b.Color = GetPixel(DestHDC, b.x, b.y)
  48.     b.Area = (x - b.x + 1) * (a.y - y + 1)
  49.     
  50.     c.x = a.x
  51.     c.y = a.y + 1
  52.     c.Color = GetPixel(DestHDC, c.x, c.y)
  53.     c.Area = (a.x - x + 1) * (y - c.y + 1)
  54.     
  55.     d.x = a.x + 1
  56.     d.y = a.y + 1
  57.     d.Color = GetPixel(DestHDC, d.x, d.y)
  58.     d.Area = (x - b.x + 1) * (y - c.y + 1)
  59.     
  60.     DrawPixel DestHDC, a.x, a.y, BlendColor(a.Color, Color, a.Area)
  61.     DrawPixel DestHDC, b.x, b.y, BlendColor(b.Color, Color, b.Area)
  62.     DrawPixel DestHDC, c.x, c.y, BlendColor(c.Color, Color, c.Area)
  63.     DrawPixel DestHDC, d.x, d.y, BlendColor(d.Color, Color, d.Area)
  64.     
  65. End Sub
  66. '
  67.  
  68. Public Function BlendColor(base As Long, blend As Long, alpha As Single) As Long
  69.         
  70.     Dim rgbBase     As RGBColor
  71.     Dim rgbBlend    As RGBColor
  72.     
  73.     rgbBase = CRGB(base)
  74.     rgbBlend = CRGB(blend)
  75.     
  76.     With rgbBase
  77.         
  78.         ' because of this (blending) formula
  79.         ' .Red, .Green and .Blue are integers (instead of Byte)
  80.         '
  81.         ' i'm not realy sure why vb complains when bytes are used...
  82.         
  83.         .Red = alpha * (rgbBlend.Red - .Red) + .Red
  84.         .Green = alpha * (rgbBlend.Green - .Green) + .Green
  85.         .Blue = alpha * (rgbBlend.Blue - .Blue) + .Blue
  86.         
  87.     End With
  88.     
  89.     BlendColor = CColor(rgbBase)
  90.     
  91. End Function
  92. '
  93.  
  94. Public Function CRGB(Color As Long) As RGBColor
  95.     
  96.     Dim hexcode As String
  97.     
  98.     hexcode = Right$("000000" + Hex$(Color), 6)
  99.     
  100.     CRGB.Red = CByte(Val("&H" + Right$(hexcode, 2)))
  101.     CRGB.Green = CByte(Val("&H" + Mid$(hexcode, 3, 2)))
  102.     CRGB.Blue = CByte(Val("&H" + Left$(hexcode, 2)))
  103.     
  104. End Function
  105. '
  106.  
  107. Public Function CColor(Color As RGBColor) As Long
  108.     
  109.     CColor = RGB(Color.Red, Color.Green, Color.Blue)
  110.  
  111. End Function
  112. '
  113.