home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Menu_360201749932006.psc / BitMapBas.bas < prev   
BASIC Source File  |  2005-06-24  |  7KB  |  166 lines
  1. Attribute VB_Name = "BitMapBas"
  2. Option Explicit
  3. Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  4. Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
  5. Private Declare Function SetBkColor& Lib "gdi32" (ByVal hdc&, ByVal crColor&)
  6. Public Declare Function GetPixel& Lib "gdi32" (ByVal hdc&, ByVal X&, ByVal Y&)
  7. Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal hdc&, ByVal nWidth&, ByVal nHeight&)
  8. Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc&)
  9. Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc&, ByVal hObject&)
  10. Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
  11. Private Declare Function CreateBitmap& Lib "gdi32" (ByVal nWidth&, ByVal nHeight&, ByVal nPlanes&, ByVal nBitCount&, ByVal lpBits As Any)
  12. Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc&)
  13.  
  14. 'Private Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
  15. 'Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
  16. 'Private Const SRCINVERT = &H660046   ' (DWORD) dest = source XOR dest
  17. Public Enum BitbltOps      ' For bitblt function
  18.     SRCCOPY = &HCC0020     ' Dest = Source
  19.     SRCAND = &H8800C6      ' Dest = Dest AND Source
  20.     SRCINVERT = &H660046   ' Dest = Dest XOR Source
  21.     DSINVERT = &H550009    '
  22.     SRCPAINT = &HEE0086    ' Dest = Dest OR  Source
  23.     SRCERASE = &H4400328   ' Dest = (XOR Dest) AND Source
  24.     WHITENESS = &HFF0062   ' Dest = vbWhite
  25.     BLACKNESS = &H42       ' Dest = vbBlack
  26.     MERGECOPY = &HC000CA   '
  27.     MERGEPAINT = &HBB0226  '
  28.     NOTSRCCOPY = &H330008  '
  29.     NOTSRCERASE = &H1100A6 '
  30. End Enum
  31. '
  32. Public Sub BitBltItNow(hDestDC As Long, lDestX, lDestY, hSourceDC As Long, lSourceW As Long, lSourceH As Long, lStartX As Long, lStartY As Long)
  33.     'Just a plain old BitBlt
  34.     
  35.     'hDestDC = were the image will be copied to
  36.     'lDestX & lDestY = the X and Y coordinates were it will end up
  37.     'lSourceW &  lSourceH = the width and height of the bitmap copied
  38.     'lSourceH = the source bitmap
  39.     'lStartX & lStartY = the X and Y coordinates of were to start copying on the source
  40.     
  41.     Dim lRet As Long
  42.     lRet = BitBlt(hDestDC, lDestX, lDestY, lSourceW, lSourceH, hSourceDC, lStartX, lStartY, SRCCOPY)
  43. End Sub
  44.  
  45. Public Sub StretchBitMap(hDestDC As Long, lDestX As Long, lDestY As Long, lDestW As Long, lDestH As Long, hSourceDC As Long, lSourceW As Long, lSourceH As Long)
  46.     'This stretches source bitmap
  47.     
  48.     'The only difference between this and BitBltItNow is the lSourceW, lSourceH arguments
  49.     'If they are larger than lDestW, lDestH the bitmap will be stretched
  50.     'If they are smaller than lDestW, lDestH the bitmap will be shrunk
  51.     Call StretchBlt(hDestDC, lDestX, lDestY, lDestW, lDestH, hSourceDC, 0, 0, lSourceW, lSourceH, SRCCOPY)
  52. End Sub
  53.  
  54. Public Sub TransTileToForm(hDestDC As Long, lDestW As Long, lDestH As Long, hSourceDC As Long, lSourceW As Long, lSourceH As Long, lTransColor As Long)
  55.         
  56.     'Same thing as TileToForm except that it calls TransBltNow instead of a basic BitBlt
  57.     Dim lRet As Long
  58.     Dim lRows As Long
  59.     Dim lCols As Long
  60.     Dim i As Long
  61.     Dim j As Long
  62.     Dim lDestX As Long
  63.     Dim lDestY As Long
  64.     
  65.     lCols = lDestW \ lSourceW
  66.     lRows = lDestH \ lSourceH
  67.  
  68.     For i = 0 To lCols
  69.         lDestX = i * lSourceW
  70.         For j = 0 To lRows
  71.             lDestY = j * lSourceH
  72.             TransBltNow hDestDC, lDestX, lDestY, lSourceW, lSourceH, hSourceDC, 0, 0, lTransColor
  73.         Next
  74.     Next
  75. End Sub
  76. Public Sub TileToForm(hDestDC As Long, lDestW As Long, lDestH As Long, hSourceDC As Long, lSourceW As Long, lSourceH As Long)
  77.  
  78.     'Tiles to source bitmap on to the destination
  79.     Dim lRet As Long
  80.     Dim lRows As Long
  81.     Dim lCols As Long
  82.     Dim i As Long
  83.     Dim j As Long
  84.     Dim lDestX As Long
  85.     Dim lDestY As Long
  86.     
  87.     'Figure out how many bitmaps will fit across
  88.     lCols = lDestW \ lSourceW
  89.     'Figure out how many bitmaps will fit down
  90.     lRows = lDestH \ lSourceH
  91.  
  92.     'A nested loop to copy rows and cols
  93.     For i = 0 To lCols
  94.         lDestX = i * lSourceW
  95.         For j = 0 To lRows
  96.             lDestY = j * lSourceH
  97.             lRet = BitBlt(hDestDC, lDestX, lDestY, lSourceW, lSourceH, hSourceDC, 0, 0, SRCCOPY)
  98.         Next
  99.     Next
  100. End Sub
  101.  
  102.  
  103. Public Sub TransBltNow(hDestDC As Long, lDestX As Long, lDestY As Long, lWidth As Long, lHeight As Long, hSourceDC As Long, lSourceX As Long, lSourceY As Long, lTransColor As Long)
  104. '   This function copies a bitmap from one device context to the other
  105. '   where every pixel in the source bitmap that matches the specified color
  106. '   becomes transparent, letting the destination bitmap show through.
  107.  
  108.     Dim lOldColor As Long
  109.     Dim hMaskDC As Long
  110.     Dim hMaskBmp As Long
  111.     Dim hOldMaskBmp As Long
  112.     Dim hTempBmp As Long
  113.     Dim hTempDC As Long
  114.     Dim hOldTempBmp As Long
  115.     Dim hDummy As Long
  116.     Dim lRet As Long
  117.  
  118.     '   The Background colors of Source and Destination DCs must
  119.     '   be the transparancy color in order to create a mask.
  120.     lOldColor = SetBkColor&(hSourceDC, lTransColor)
  121.     lOldColor = SetBkColor&(hDestDC, lTransColor)
  122.     
  123.     '   The mask DC must be compatible with the destination dc,
  124.     '   but the mask has to be created as a monochrome bitmap.
  125.     '   For this reason, we create a compatible dc and bitblt
  126.     '   the mono mask into it.
  127.     
  128.     '   Create the Mask DC, and a compatible bitmap to go in it.
  129.     hMaskDC = CreateCompatibleDC(hDestDC)
  130.     hMaskBmp = CreateCompatibleBitmap(hDestDC, lWidth, lHeight)
  131.     '   Move the Mask bitmap into the Mask DC
  132.     hOldMaskBmp = SelectObject(hMaskDC, hMaskBmp)
  133.     
  134.     '   Create a monochrome bitmap that will be the actual mask bitmap.
  135.     hTempBmp = CreateBitmap(lWidth, lHeight, 1, 1, 0&)
  136.     '   Create a temporary DC, and put the mono bitmap into it
  137.     hTempDC = CreateCompatibleDC(hDestDC)
  138.     hOldTempBmp = SelectObject(hTempDC, hTempBmp)
  139.     
  140.     '   BitBlt the Source image into the mono dc to create a mono mask.
  141.     If BitBlt(hTempDC, 0, 0, lWidth, lHeight, hSourceDC, lSourceX, lSourceY, SRCCOPY) Then
  142.         '   Copy the mono mask into our Mask DC
  143.         hDummy = BitBlt(hMaskDC, 0, 0, lWidth, lHeight, hTempDC, 0, 0, SRCCOPY)
  144.     End If
  145.     
  146.     '   Clean up temp DC and bitmap
  147.     hTempBmp = SelectObject(hTempDC, hOldTempBmp)
  148.     hDummy = DeleteObject(hTempBmp)
  149.     hDummy = DeleteDC(hTempDC)
  150.     
  151.     '   Copy the source to the destination with XOR
  152.     lRet = BitBlt(hDestDC, lDestX, lDestY, lWidth, lHeight, hSourceDC, lSourceX, lSourceY, SRCINVERT)
  153.     '   Copy the Mask to the destination with AND
  154.     lRet = BitBlt(hDestDC, lDestX, lDestY, lWidth, lHeight, hMaskDC, 0, 0, SRCAND)
  155.     '   Again, copy the source to the destination with XOR
  156.     lRet = BitBlt(hDestDC, lDestX, lDestY, lWidth, lHeight, hSourceDC, lSourceX, lSourceY, SRCINVERT)
  157.  
  158.     '   Clean up mask DC and bitmap
  159.     hMaskBmp = SelectObject(hMaskDC, hOldMaskBmp)
  160.     hDummy = DeleteObject(hMaskBmp)
  161.     hDummy = DeleteDC(hMaskDC)
  162.  
  163. End Sub
  164.  
  165.  
  166.