home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD88428112000.psc / Transparency.bas < prev   
Encoding:
BASIC Source File  |  1998-08-04  |  6.0 KB  |  159 lines
  1. Attribute VB_Name = "Transparency"
  2.    'this module:
  3.    ' (c) 1999 Hobbit (hobbz@ncweb.com)
  4.    
  5.    'API Constants, Types, and Functions (Declares)
  6.    Public Const SRCCOPY = &HCC0020
  7.    Private Const SRCINVERT = &H660046
  8.    Private Const SRCAND = &H8800C6
  9.    Private Const CCHDEVICENAME = 32
  10.    Private Const CCHFORMNAME = 32
  11.  
  12.  
  13.    Private Type DEVMODE
  14.        dmDeviceName As String * CCHDEVICENAME
  15.        dmSpecVersion As Integer
  16.        dmDriverVersion As Integer
  17.        dmSize As Integer
  18.        dmDriverExtra As Integer
  19.        dmFields As Long
  20.        dmOrientation As Integer
  21.        dmPaperSize As Integer
  22.        dmPaperLength As Integer
  23.        dmPaperWidth As Integer
  24.        dmScale As Integer
  25.        dmCopies As Integer
  26.        dmDefaultSource As Integer
  27.        dmPrintQuality As Integer
  28.        dmColor As Integer
  29.        dmDuplex As Integer
  30.        dmYResolution As Integer
  31.        dmTTOption As Integer
  32.        dmCollate As Integer
  33.        dmFormName As String * CCHFORMNAME
  34.        dmUnusedPadding As Integer
  35.        dmBitsPerPel As Long
  36.        dmPelsWidth As Long
  37.        dmPelsHeight As Long
  38.        dmDisplayFlags As Long
  39.        dmDisplayFrequency As Long
  40.        End Type
  41.  
  42.  
  43.    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  44.  
  45.  
  46.    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  47.  
  48.  
  49.    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  50.  
  51.  
  52.    Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
  53.  
  54.  
  55.    Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
  56.  
  57.  
  58.    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  59.  
  60.  
  61.    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  62.  
  63.  
  64.    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  65.  
  66.  
  67.    Public 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
  68.  
  69.                                                    
  70.  
  71.    Public Function TransBitBlt(ByVal hDstDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, Optional ByVal dwRop As Long = 0) As Boolean
  72.  
  73.  
  74.        'Purpose Extends capabilites of BitBlt to inlude
  75.        ' transparency. This function will treat all
  76.        ' pure black pixels in the source image as
  77.        ' transparent.
  78.        '
  79.        
  80.        'NotesLike BitBlt, it is necessary to call the "Refresh"
  81.        ' method of your destination control after using this
  82.        ' function. Until you call "Refresh", the transparent
  83.        ' image will not appear.
  84.        ' For Example, if your souce was called picSprite,
  85.        'and your destination was picBack:
  86.        'your code might look like this
  87.        ' Call TransBitBlt(Form1.PicBack.hdc, 0, 0, 40, 40, Form1.PicSpri
  88.        '     te.hdc, 320, 210)
  89.        ' PicBack.Refresh
  90.        
  91.        'Inputs
  92.        ' hDstDC -- The destination hDC to copy to
  93.        ' X,Y-- The top-left point in destination to copy to
  94.        ' nWidth, nHeight -- The size of the area to be copied
  95.        ' hSrcDC -- The source hDC to copy from
  96.        ' xSrc, ySrc-- The top-left point in the source to start copying
  97.        '     from
  98.        ' dwRop -- NOT USED (Included for compatibility w/ BitBlt code)
  99.        
  100.        'Outputs
  101.        ' True -- Operation was successful
  102.        ' False -- Operation failed
  103.        '
  104.        
  105.        'Variables
  106.        Dim MaskDC As Long 'Holds the DC For the mask
  107.        Dim MaskBitmap As Long 'Holds the bitmap reference For the mask
  108.        
  109.        
  110.        On Error GoTo Err 'If there is any error, goto Err
  111.        MaskDC = CreateCompatibleDC(hSrcDC) 'Get a DC
  112.       
  113.  
  114.        If MaskDC Then 'If successful in getting a DC...
  115.            MaskBitmap = CreateBitmap(nWidth, nHeight, 1, 1, 0&) 'Get a bitmap, same size as Src, 1 bit/pixel, 1 colour plane, don't initialize.
  116.  
  117.  
  118.            If MaskBitmap Then 'If successful in getting a bitmap...
  119.                
  120.                MaskBitmap = SelectObject(MaskDC, MaskBitmap) 'Select 2 colour bitmap into DC.
  121.                
  122.                Call SetBkColor(hSrcDC, QBColor(0)) 'Set the sources background color to black
  123.                Call BitBlt(MaskDC, 0, 0, nWidth, nHeight, hSrcDC, xSrc, ySrc, SRCCOPY) 'Copy the source to the monochrome mask
  124.                Call SetBkColor(hDstDC, QBColor(15)) 'Set the destinations background color to white
  125.                
  126.            Else 'If unsuccessful in getting a bitmap..
  127.                
  128.                Call DeleteDC(MaskDC) 'Free the DC
  129.                MaskDC = 0 'Set the DC reference to 0
  130.                GoTo Err 'Goto Error handler
  131.                
  132.            End If 'End bitmap success conditional
  133.  
  134.  
  135.        Else 'If unsuccessful in getting a DC
  136.            MaskDC = 0 'Set the reference to 0
  137.            GoTo Err 'Goto Error handler
  138.        End If 'End DC Success conditional
  139.  
  140.  
  141.        
  142.        Call BitBlt(hDstDC, X, Y, nWidth, nHeight, MaskDC, 0, 0, SRCAND) 'AND mask With Dst.
  143.        Call BitBlt(hDstDC, X, Y, nWidth, nHeight, hSrcDC, xSrc, ySrc, SRCINVERT) 'XOR Src With Dst
  144.        iMaskBitmap = SelectObject(MaskDC, MaskBitmap) 'Select the bitmap into the DC.
  145.        DeleteObject MaskBitmap  'Free the bitmap
  146.        DeleteDC MaskDC 'Free the DC
  147.     
  148.    
  149.            
  150.        TransBitBlt = True 'Return True (No Error)
  151.        Exit Function 'Exit the function
  152.        
  153. Err:        'Error Handler
  154.        TransBitBlt = False 'Return False (Error)
  155.  
  156.    End Function
  157.  
  158.  
  159.