home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Real_Photo2163309242009.psc / AlphaBlendMask.bas < prev    next >
BASIC Source File  |  2009-06-17  |  10KB  |  287 lines
  1. Attribute VB_Name = "ABM"
  2. 'Thanx to "Tecc" of PSC
  3.  
  4. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  5. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  6. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  7. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
  8. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  9. Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
  10. Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
  11. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  12. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  13. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  14. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  15.  
  16. Private Const BI_RGB = 0&
  17. Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
  18. Private Type BITMAP '14 bytes
  19.     bmType As Long
  20.     bmWidth As Long
  21.     bmHeight As Long
  22.     bmWidthBytes As Long
  23.     bmPlanes As Integer
  24.     bmBitsPixel As Integer
  25.     bmBits As Long
  26. End Type
  27.  
  28. Private Type BITMAPINFOHEADER '40 bytes
  29.     biSize As Long
  30.     biWidth As Long
  31.     biHeight As Long
  32.     biPlanes As Integer
  33.     biBitCount As Integer
  34.     biCompression As Long
  35.     biSizeImage As Long
  36.     biXPelsPerMeter As Long
  37.     biYPelsPerMeter As Long
  38.     biClrUsed As Long
  39.     biClrImportant As Long
  40. End Type
  41. Private Type RGBQUAD
  42.     rgbBlue As Byte
  43.     rgbGreen As Byte
  44.     rgbRed As Byte
  45.     rgbReserved As Byte
  46. End Type
  47. Private Type BITMAPINFO
  48.     bmiHeader As BITMAPINFOHEADER
  49.     bmiColors As RGBQUAD
  50. End Type
  51.  
  52. Private W As Long
  53. Private H As Long
  54.  
  55. Private msk As Long, MSKO1 As Long, MSKI As BITMAPINFO, MSKBITS() As Byte
  56. Private nSRC As Long, nSRCO1 As Long, nSRCI As BITMAPINFO, SRCBITS() As Byte
  57. Private DST As Long, DSTO1 As Long, DSTI As BITMAPINFO, DSTBITS() As Byte
  58. Private BB As Long, BBO As Long
  59.  
  60. Private LX As Long, LY As Long
  61.  
  62. Public Sub ModMask_Setup(ByRef PicSRC As PictureBox, ByRef PicTar As PictureBox, ByRef Target As PictureBox)
  63. Dim S1 As Long
  64. Dim S2 As Long
  65. S1 = PicSRC.hDC
  66. S2 = PicTar.hDC
  67.  
  68. 'set the width and height
  69. W = PicSRC.ScaleWidth
  70. H = PicSRC.ScaleHeight
  71. 'set bitmap info for the source, mask, and destination
  72. 'bitmaps
  73. With MSKI.bmiHeader
  74.     .biBitCount = 24 '24 bits per pixel (R,G,B per pixel)
  75.     .biSize = Len(MSKI) 'size of this information
  76.     .biHeight = H 'height
  77.     .biWidth = W 'width
  78.     .biPlanes = 1 'bitmap planes (2D, so 1)
  79.     .biCompression = BI_RGB 'Type of color compression
  80. End With
  81. 'the following is the same for all bitmaps
  82. With DSTI.bmiHeader
  83.     .biBitCount = 24
  84.     .biSize = Len(DSTI)
  85.     .biHeight = H
  86.     .biWidth = W
  87.     .biPlanes = 1
  88.     .biCompression = BI_RGB
  89. End With
  90. With nSRCI.bmiHeader
  91.     .biBitCount = 24
  92.     .biSize = Len(nSRCI)
  93.     .biHeight = H
  94.     .biPlanes = 1
  95.     .biWidth = W
  96.     .biCompression = BI_RGB
  97. End With
  98.  
  99. 'create the device contexts
  100. msk = CreateCompatibleDC(GetDC(0))
  101. nSRC = CreateCompatibleDC(GetDC(0))
  102. DST = CreateCompatibleDC(GetDC(0))
  103. BB = CreateCompatibleDC(GetDC(0))
  104.  
  105. 'variable that defines how many color bits there
  106. 'are in one bit array
  107. '[Width * Height] (all pixels) [* 3] (R,G,B - 3 values)
  108. 'per pixel
  109. Dim nl As Long
  110. nl = ((W + 1) * (H + 1)) * 3
  111.  
  112. 'redimension the bit color information arrays to
  113. 'fit all the color information
  114. ReDim MSKBITS(1 To nl)
  115. ReDim SRCBITS(1 To nl)
  116. ReDim DSTBITS(1 To nl)
  117.  
  118. 'create a DIB section based on the bitmapinfo we
  119. 'provided above. this is like creating a
  120. 'compatible bitmap, but used for modifying bitmap
  121. 'bits
  122. MSKO1 = CreateDIBSection(GetDC(0), MSKI, DIB_RGB_COLORS, 0, 0, 0)
  123. nSRCO1 = CreateDIBSection(GetDC(0), nSRCI, DIB_RGB_COLORS, 0, 0, 0)
  124. DSTO1 = CreateDIBSection(GetDC(0), DSTI, DIB_RGB_COLORS, 0, 0, 0)
  125.  
  126. 'create a permanent image of the form, so we can
  127. 'restore drawn-over parts
  128. BBO = CreateCompatibleBitmap(GetDC(0), Target.ScaleWidth, Target.ScaleHeight)
  129.  
  130. 'link the device contexts to thier bitmap objects
  131. SelectObject msk, MSKO1
  132. SelectObject DST, DSTO1
  133. SelectObject nSRC, nSRCO1
  134. SelectObject BB, BBO
  135.  
  136. 'we want to blt from the form, so make sure it
  137. 'is visible
  138. 'target.Show
  139. Target.Refresh
  140.  
  141. 'blt the mask and source images into the bitmap
  142. 'object so we can copy the color information
  143. BitBlt msk, 0, 0, W, H, S2, 0, 0, vbSrcCopy
  144. BitBlt nSRC, 0, 0, W, H, S1, 0, 0, vbSrcCopy
  145. BitBlt BB, 0, 0, Target.ScaleWidth, Target.ScaleHeight, Target.hDC, 0, 0, vbSrcCopy
  146.  
  147. 'load the color information into arrays
  148. 'we only do this once because the source and mask
  149. 'images never change, but the destination image
  150. 'will change frequently, depending on where the mouse
  151. 'is on the form, so we have to update the DST bit array
  152. 'every time we alphablt.
  153. GetDIBits msk, MSKO1, 0, H, MSKBITS(1), MSKI, DIB_RGB_COLORS
  154. GetDIBits nSRC, nSRCO1, 0, H, SRCBITS(1), nSRCI, DIB_RGB_COLORS
  155.  
  156. End Sub
  157.  
  158. Public Sub ModMask_CleanUp()
  159. 'cleanup all the memory space we have used
  160. DeleteDC msk
  161. DeleteDC nSRC
  162. DeleteDC DST
  163. DeleteDC BB
  164.  
  165. DeleteObject BBO
  166. DeleteObject MSKO1
  167. DeleteObject nSRCO1
  168. DeleteObject DSTO1
  169.  
  170. 'erase any array data left over
  171. Erase MSKBITS
  172. Erase SRCBITS
  173. Erase DSTBITS
  174. End Sub
  175.  
  176. Public Sub ModMask_BLTIT(ByVal x As Long, ByVal y As Long, Target As PictureBox)
  177. 'set the cursor in the middle of the alpha-blitted
  178. 'bitmap
  179. x = x - W / 2
  180. y = y - H / 2
  181.  
  182. ''if the area is off the form, move it back
  183.  
  184. 'This is like a bug in borders
  185. 'From V7.6 Removed!
  186.  
  187. 'If x >= Target.ScaleWidth - (W + 1) Then
  188. '    x = Target.ScaleWidth - (W + 1)
  189. 'End If
  190. 'If y >= Target.ScaleHeight - (H + 1) Then
  191. '    y = Target.ScaleHeight - (H + 1)
  192. 'End If
  193. 'If y <= 0 Then
  194. '    y = 0
  195. 'End If
  196. 'If x <= 0 Then
  197. '    x = 0
  198. 'End If
  199.  
  200.  
  201.  
  202. 'copy image from the permanant image of the form
  203. 'to the destination bitmap, so we have a 'background'
  204. 'to alphablt to. This is so that we will blt to the
  205. 'area where the cursor is
  206. BitBlt DST, 0, 0, W, H, BB, x, y, vbSrcCopy
  207.  
  208. 'copy the destination image data into its bit array
  209. 'so we can process it
  210. GetDIBits DST, DSTO1, 0, H, DSTBITS(1), DSTI, DIB_RGB_COLORS
  211.  
  212. 'some processing variables
  213. Dim SrcC(2) As Integer
  214. Dim DstC(2) As Integer
  215. Dim Alpha(2) As Integer
  216. Dim tmp(2) As Integer
  217.  
  218. 'temporary bit array
  219. Dim tmpBits() As Byte
  220.  
  221. 'make the temporary bit array large enough to hold
  222. 'all the color information from the resulting alpha
  223. 'blitted bitmap
  224. ReDim tmpBits(UBound(SRCBITS))
  225.  
  226. 'a for loop to loop through the pixels of the bitmaps
  227. 'we do step3 because for every pixel, there are RED,
  228. 'GREEN, and BLUE color values in the bit array
  229. For i = 1 To UBound(SRCBITS) Step 3
  230.     'pixel: (i) to (i+2)
  231.     SrcC(0) = SRCBITS(i) 'blue value
  232.     SrcC(1) = SRCBITS(i + 1) 'green value
  233.     SrcC(2) = SRCBITS(i + 2) 'red value
  234.     
  235.     Alpha(0) = MSKBITS(i)
  236.     Alpha(1) = MSKBITS(i + 1)
  237.     Alpha(2) = MSKBITS(i + 2)
  238.     
  239.     DstC(0) = DSTBITS(i)
  240.     DstC(1) = DSTBITS(i + 1)
  241.     DstC(2) = DSTBITS(i + 2)
  242.     
  243.     'create alpha values based on color information
  244.     'the transparency level is based on the current mask
  245.     'pixel, the function DOES calculate green, red and blue
  246.     'alpha channels, but in this example, only GRAYSCALE
  247.     'is used (because the mask BMP is black and white).
  248.     'but there is a true 32bit alpha channel available with
  249.     'no decrease in speed.
  250.     
  251.     'when we use a GRAYSCALE mask, all alpha
  252.     'values are the same. with a full color mask,
  253.     'alpha values differ and so depending on a certain pixel,
  254.     'more green, blue, or red can be forced transparent
  255.     
  256.     'say you have a source pixel, RGB(100,0,0)
  257.     'a mask pixel, RGB(200,0,0)
  258.     'and a destination pixel RGB(0,100,255)
  259.     'the alpha pixel would be RGB(78,0,0) showing
  260.     'only a red pixel, because in the mask, only
  261.     'red has a visible value (200). Some very
  262.     'interesting effects are available for you to
  263.     'experiment with.
  264.     tmp(0) = SrcC(0) + (((DstC(0) - SrcC(0)) / 255) * Alpha(0))
  265.     tmp(1) = SrcC(1) + (((DstC(1) - SrcC(1)) / 255) * Alpha(1))
  266.     tmp(2) = SrcC(2) + (((DstC(2) - SrcC(2)) / 255) * Alpha(2))
  267.     
  268.     'set the alpha values into the temporary bit
  269.     'array
  270.     tmpBits(i) = tmp(0) 'Alpha Blue
  271.     tmpBits(i + 1) = tmp(1) 'Alpha Green
  272.     tmpBits(i + 2) = tmp(2) 'Alpha Red
  273. Next
  274.  
  275. 'copy the previous image over where we alphablitted
  276. 'last, so we clear only that part of the screen.
  277. BitBlt Target.hDC, LX, LY, W, H, BB, LX, LY, vbSrcCopy
  278.  
  279. 'blt the alpha values to the screen
  280. SetDIBitsToDevice Target.hDC, x, y, W, H, 0, 0, 0, H, tmpBits(1), nSRCI, DIB_RGB_COLORS
  281.  
  282. 'set the Last X and Last Y values so we know where
  283. 'tp clear the screen next time.
  284. LX = x
  285. LY = y
  286. End Sub
  287.