home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Basic / Visual Basic.60 / COMMON / TOOLS / VB / UNSUPPRT / SSAVER / PAINTSUP.BAS < prev    next >
Encoding:
BASIC Source File  |  1997-01-16  |  10.7 KB  |  234 lines
  1. Attribute VB_Name = "PaintSup"
  2. Option Explicit
  3.  
  4. '-----------------------------------------------------------------
  5. Public Function ShrinkBmp(dispHdc As Long, hBmp As Long, RatioX As Single, RatioY As Single) As Long
  6. '-----------------------------------------------------------------
  7.     Dim hBmpOut As Long                             ' output bitmap handle
  8.     Dim bm1 As BITMAP, bm2 As BITMAP                ' temporary bitmap structs
  9.     Dim hdcMem1 As Long, hdcMem2 As Long            ' temporary memory bitmap handles...
  10. '-----------------------------------------------------------------
  11.     hdcMem1 = CreateCompatibleDC(dispHdc)           ' create mem DC compatible to the display DC
  12.     hdcMem2 = CreateCompatibleDC(dispHdc)           ' create mem DC compatible to the display DC
  13.   
  14.     GetObject hBmp, LenB(bm1), bm1                  ' select bitmap object
  15.   
  16.     LSet bm2 = bm1                                  ' copy bitmap object
  17.   
  18.     bm2.bmWidth = CLng(bm2.bmWidth * RatioX)        ' scale output bitmap width
  19.     bm2.bmHeight = CLng(bm2.bmHeight * RatioY)      ' scale output bitmap height
  20.     bm2.bmWidthBytes = ((((bm2.bmWidth * bm2.bmBitsPixel) + 15) \ 16) * 2) ' calculate bitmap width bytes
  21.  
  22.     hBmpOut = CreateBitmapIndirect(bm2)             ' create handle to output bitmap indirectly from new bm2
  23.     
  24.     SelectObject hdcMem1, hBmp                      ' select original bitmap into mem dc
  25.     SelectObject hdcMem2, hBmpOut                   ' select new bitmap into mem dc
  26.  
  27.     ' stretch old bitmap into new bitmap
  28.     StretchBlt hdcMem2, 0, 0, bm2.bmWidth, bm2.bmHeight, _
  29.                hdcMem1, 0, 0, bm1.bmWidth, bm1.bmHeight, vbSrcCopy
  30.     
  31.     DeleteDC hdcMem1                                ' delete memory dc
  32.     DeleteDC hdcMem2                                ' delete memory dc
  33.  
  34.     ShrinkBmp = hBmpOut                             ' return handle to new bitmap
  35. '-----------------------------------------------------------------
  36. End Function
  37. '-----------------------------------------------------------------
  38.  
  39. '-----------------------------------------------------------------
  40. Public Sub InitDeskDC(OutHdc As Long, OutBmp As BITMAP, DispRec As RECT)
  41. '-----------------------------------------------------------------
  42.     Dim DskHwnd As Long                     ' hWnd of desktop
  43.     Dim DskRect As RECT                     ' rect size of desktop
  44.     Dim DskHdc As Long                      ' hdc of desktop
  45.     Dim hOutBmp As Long                     ' handle to output bitmap
  46.     Dim rc As Long                          ' function return code
  47. '-----------------------------------------------------------------
  48.     DskHwnd = GetDesktopWindow()            ' Get src - HWND of Desktop
  49.     DskHdc = GetWindowDC(DskHwnd)           ' Get src HDC - Handle to device context
  50.     rc = GetWindowRect(DskHwnd, DskRect)    ' Get src Rectangle dimentions
  51.     
  52.     With DispRec
  53.         ' Create handle to compatible output bitmap
  54.         hOutBmp = CreateCompatibleBitmap(DskHdc, (.Right - .Left + 1), (.Bottom - .Top + 1))
  55.     
  56.         rc = GetObject(hOutBmp, Len(OutBmp), OutBmp)    ' Get handle to bitmap
  57.         OutHdc = CreateCompatibleDC(DskHdc)             ' Create compatible hdc
  58.         rc = SelectObject(OutHdc, hOutBmp)              ' copy bitmap structure into output dc
  59.                 
  60.         rc = StretchBlt(OutHdc, 0, 0, _
  61.                        (.Right - .Left + 1), _
  62.                        (.Bottom - .Top + 1), _
  63.                         DskHdc, 0, 0, _
  64.                        (DskRect.Right - DskRect.Left + 1), _
  65.                        (DskRect.Bottom - DskRect.Top + 1), _
  66.                         vbSrcCopy)          ' Paint bitmap desk dc to output dc
  67.     End With
  68.     
  69.     rc = DeleteObject(hOutBmp)              ' delete handle to output bitmap
  70.     rc = ReleaseDC(DskHwnd, DskHdc)         ' Clean up - Release src HDC
  71. '-----------------------------------------------------------------
  72. End Sub
  73. '-----------------------------------------------------------------
  74.  
  75. '-----------------------------------------------------------------
  76. Public Sub PaintDeskDC(InHdc As Long, InBmp As BITMAP, OutHwnd As Long)
  77. '-----------------------------------------------------------------
  78.     Dim OutRect As RECT                     ' rect. size of output window
  79.     Dim OutHdc As Long                      ' hdc of output window
  80.     Dim rc As Long                          ' function return code
  81. '-----------------------------------------------------------------
  82.     rc = GetClientRect(OutHwnd, OutRect)    ' Get Dest Rectangle dimentions
  83.     OutHdc = GetWindowDC(OutHwnd)           ' get Dest HDC
  84.         
  85.     With OutRect
  86.         ' Paint the desktop picture to the output window...
  87.         rc = StretchBlt(OutHdc, 0, 0, _
  88.                        (.Right - .Left + 1), _
  89.                        (.Bottom - .Top + 1), _
  90.                        InHdc, 0, 0, _
  91.                        InBmp.bmWidth, InBmp.bmHeight, vbSrcCopy)
  92.     End With
  93.     
  94.     rc = ReleaseDC(OutHwnd, OutHdc)         ' Clean up - Release src HDC
  95. '-----------------------------------------------------------------
  96. End Sub
  97. '-----------------------------------------------------------------
  98.  
  99. '-----------------------------------------------------------------
  100. Public Sub DelDeskDC(OutHdc As Long)
  101. '-----------------------------------------------------------------
  102.     Dim rc As Long
  103. '-----------------------------------------------------------------
  104.     
  105.     rc = DeleteDC(OutHdc)          ' Clean up - Release src HDC
  106. '-----------------------------------------------------------------
  107. End Sub
  108. '-----------------------------------------------------------------
  109.  
  110. '-----------------------------------------------------------------
  111. Public Sub DrawTransparentBitmap(lHDCDest As Long, _
  112.                                  lBmSource As Long, _
  113.                                  lMaskColor As Long, _
  114.                                  Optional lDestStartX As Long, _
  115.                                  Optional lDestStartY As Long, _
  116.                                  Optional lDestWidth As Long, _
  117.                                  Optional lDestHeight As Long, _
  118.                                  Optional lSrcStartX As Long, _
  119.                                  Optional lSrcStartY As Long, _
  120.                                  Optional BkGrndHdc As Long)
  121. '-----------------------------------------------------------------
  122.     Dim udtBitMap As BITMAP
  123.     Dim lColorRef As Long 'COLORREF
  124.     Dim lBmAndBack As Long 'HBITMAP
  125.     Dim lBmAndObject As Long
  126.     Dim lBmAndMem As Long
  127.     Dim lBmSave As Long
  128.     Dim lBmBackOld As Long
  129.     Dim lBmObjectOld As Long
  130.     Dim lBmMemOld As Long
  131.     Dim lBmSaveOld As Long
  132.     Dim lHDCMem As Long 'HDC
  133.     Dim lHDCBack As Long
  134.     Dim lHDCObject As Long
  135.     Dim lHDCTemp As Long
  136.     Dim lHDCSave As Long
  137.     Dim udtSize As POINTAPI 'POINT
  138.     Dim x As Long, y As Long
  139. '-----------------------------------------------------------------
  140.     lHDCTemp = CreateCompatibleDC(lHDCDest)     'Create a temporary HDC compatible to the Destination HDC
  141.     SelectObject lHDCTemp, lBmSource             'Select the bitmap
  142.     GetObject lBmSource, Len(udtBitMap), udtBitMap
  143.     
  144.     With udtSize
  145.         .x = udtBitMap.bmWidth                  'Get width of bitmap
  146.         .y = udtBitMap.bmHeight                 'Get height of bitmap
  147.         'Use passed width and height parameters
  148.         If lDestWidth <> 0 Then .x = lDestWidth
  149.         If lDestHeight <> 0 Then .y = lDestHeight
  150.         x = .x
  151.         y = .y
  152.     End With
  153.     
  154.     'Create some DCs to hold temporary data
  155.     lHDCBack = CreateCompatibleDC(lHDCDest)
  156.     lHDCObject = CreateCompatibleDC(lHDCDest)
  157.     lHDCMem = CreateCompatibleDC(lHDCDest)
  158.     lHDCSave = CreateCompatibleDC(lHDCDest)
  159.     
  160.     'Create a bitmap for each DC.  DCs are required for
  161.     'a number of GDI functions
  162.     
  163.     'Monochrome DC
  164.     lBmAndBack = CreateBitmap(x, y, 1&, 1&, 0&)
  165.     'Monochrome DC
  166.     lBmAndObject = CreateBitmap(x, y, 1&, 1&, 0&)
  167.     'Compatible DC's
  168.     lBmAndMem = CreateCompatibleBitmap(lHDCDest, x, y)
  169.     lBmSave = CreateCompatibleBitmap(lHDCDest, x, y)
  170.  
  171.     'Each DC must select a bitmap object to store pixel data.
  172.     lBmBackOld = SelectObject(lHDCBack, lBmAndBack)
  173.     lBmObjectOld = SelectObject(lHDCObject, lBmAndObject)
  174.     lBmMemOld = SelectObject(lHDCMem, lBmAndMem)
  175.     lBmSaveOld = SelectObject(lHDCSave, lBmSave)
  176.     
  177.     'Set proper mapping mode.
  178.     SetMapMode lHDCTemp, GetMapMode(lHDCDest)
  179.     
  180.     'Save the bitmap sent here, because it will be overwritten
  181.     BitBlt lHDCSave, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcCopy
  182.     
  183.     'Set the background color of the source DC to the color
  184.     'contained in the parts of the bitmap that should be transparent
  185.     lColorRef = SetBkColor(lHDCTemp, lMaskColor)
  186.     
  187.     'Create the object mask for the bitmap by performaing a BitBlt
  188.     'from the source bitmap to a monochrome bitmap.
  189.     BitBlt lHDCObject, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcCopy
  190.     
  191.     'Set the background color of the source DC back to the original color
  192.     SetBkColor lHDCTemp, lColorRef
  193.     
  194.     'Create the inverse of the object mask.
  195.     BitBlt lHDCBack, 0&, 0&, x, y, lHDCObject, 0&, 0&, vbNotSrcCopy
  196.     
  197.     'Copy the background of the main DC to the destination
  198.     If (BkGrndHdc <> 0) Then
  199.         BitBlt lHDCMem, 0&, 0&, x, y, BkGrndHdc, lDestStartX, lDestStartY, vbSrcCopy
  200.     Else
  201.         BitBlt lHDCMem, 0&, 0&, x, y, lHDCDest, lDestStartX, lDestStartY, vbSrcCopy
  202.     End If
  203.     
  204.     'Mask out the places where the bitmap will be placed
  205.     BitBlt lHDCMem, 0&, 0&, x, y, lHDCObject, 0&, 0&, vbSrcAnd
  206.     
  207.     'Mask out the transparent colored pixels on the bitmap
  208.     BitBlt lHDCTemp, lSrcStartX, lSrcStartY, x, y, lHDCBack, 0&, 0&, vbSrcAnd
  209.     
  210.     'XOR the bitmap with the background on the destination DC
  211.     BitBlt lHDCMem, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcPaint
  212.     
  213.     'Copy the destination to the screen
  214.     BitBlt lHDCDest, lDestStartX, lDestStartY, x, y, lHDCMem, 0&, 0&, vbSrcCopy
  215.     
  216.     'Place the original bitmap back into the bitmap sent here
  217.     BitBlt lHDCTemp, lSrcStartX, lSrcStartY, x, y, lHDCSave, 0&, 0&, vbSrcCopy
  218.     
  219.     'Delete memory bitmaps
  220.     DeleteObject SelectObject(lHDCBack, lBmBackOld)
  221.     DeleteObject SelectObject(lHDCObject, lBmObjectOld)
  222.     DeleteObject SelectObject(lHDCMem, lBmMemOld)
  223.     DeleteObject SelectObject(lHDCSave, lBmSaveOld)
  224.     
  225.     'Delete memory DC's
  226.     DeleteDC lHDCMem
  227.     DeleteDC lHDCBack
  228.     DeleteDC lHDCObject
  229.     DeleteDC lHDCSave
  230.     DeleteDC lHDCTemp
  231. '-----------------------------------------------------------------
  232. End Sub
  233. '-----------------------------------------------------------------
  234.