tpt_blt.bas

来自「电话本信息 基本上实现电话功能 自己下载侃侃吧」· BAS 代码 · 共 70 行

Attribute VB_Name = "TransparentGDI"
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
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
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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
Private 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
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCPAINT = &HEE0086

Public Function TransparentBlt(ByVal dHdc As Long, ByVal nX0 As Integer, ByVal nY0 As Integer, _
    ByVal nW0 As Integer, ByVal nH0 As Integer, ByVal sHDC As Long, ByVal nX1 As Integer, _
    ByVal nY1 As Integer, ByVal nW1 As Integer, ByVal nH1 As Integer, ByVal tColor As Long)
'==============================================
'TransparentBlt透明位图
'dHDC 目标DC
'nX0,nY0 目标偏移
'nW0,nH0 目标宽高度
'sHDC 源DC
'nX1,int nY1 源起点
'nW1,int nH1 源宽高度
'tColor 透明色
'==============================================

    Dim hBMP As Long, mBMP As Long
    Dim hdc As Long, mDC As Long
    Dim oldBMP As Long, oldmBMP As Long

    '建立图形资源
    hBMP = CreateCompatibleBitmap(dHdc, nW0, nH0)
    mBMP = CreateBitmap(nW0, nH0, 1, 1, Null)
    hdc = CreateCompatibleDC(dHdc)
    mDC = CreateCompatibleDC(dHdc)
    oldBMP = SelectObject(hdc, hBMP)
    oldmBMP = SelectObject(mDC, mBMP)

    '拷贝或压缩拷贝源DC中的位图到临时hDC中
    If nW0 = nW1 And nH0 = nH1 Then
        BitBlt hdc, 0, 0, nW0, nH0, sHDC, nX1, nY1, SRCCOPY
    Else
        StretchBlt hdc, 0, 0, nW0, nH0, sHDC, nX1, nY1, nW1, nH1, SRCCOPY
    End If

    '生成掩码位图
    SetBkColor hdc, tColor
    BitBlt mDC, 0, 0, nW0, nH0, hdc, 0, 0, SRCCOPY
    SetBkColor hdc, RGB(0, 0, 0)
    SetTextColor hdc, RGB(255, 255, 255)
    BitBlt hdc, 0, 0, nW0, nH0, mDC, 0, 0, SRCAND
    SetBkColor dHdc, RGB(255, 255, 255)
    SetTextColor dHdc, RGB(0, 0, 0)

    '透明显示
    BitBlt dHdc, nX0, nY0, nW0, nH0, mDC, 0, 0, SRCAND
    BitBlt dHdc, nX0, nY0, nW0, nH0, hdc, 0, 0, SRCPAINT

    '以下为释放资源
    SelectObject hdc, oldBMP
    DeleteDC hdc
    SelectObject mDC, oldmBMP
    DeleteDC mDC
    DeleteObject hBMP
    DeleteObject mBMP
End Function