任意指定透明色的繪圖方法

來源:互聯網
上載者:User
透明
透明位元影像繪製方法在網上見得很多,多數是採用事先做好一個Mask圖,這方法優點是速度快,但就是太麻煩,靈活性差。
任意指定透明色,當然經常也要用到,為此,API提供了一個函數TransparentBlt,可這個函數,非常讓人遺憾,VB的API瀏覽器中不帶它是有道理的,因為,它在Win98下有嚴重記憶體漏洞,你若有98系統,可試一下:
for i=1 to 20000
TransparentBlt ....
next
同樣的圖片,在我的XP下16毫秒可完成,但在98下用了14秒,而且,提示系統資源不足,當機了!

下面我寫了一個函數就是可以代替TransparentBlt的一種方法,速度當然會慢些,但在任何系統下都可放心使用。

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y 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

Public Function TranBlt(DestHdc As Long, X As Long, y As Long, w As Long, h As Long, srcHdcOrBmp As Long, Optional srcX As Long, Optional srcY As Long, Optional srcW As Long, Optional srcH As Long, Optional tc As Long = -1, Optional IsBmp As Boolean) As Long
    'srcHdcOrBmp參數 傳入的可以是hdc也可以是Bmp對象的Handle,
    'IsBmp參數 為真時srcHdcOrBmp代表Bmp對象的Handle,為假時代表hdc
    '傳回值 成功時返回透明色,不成功時返回-1
    Dim tHdc(3) As MemHdc
    Dim j As Long, oc As Long, i As Long, Bm As BITMAP, cc As Long, NewDc As Long
    Dim sw As Long, sh As Long, sBmp As Long, sHdc As Long, obm As Long, NewX As Long, NewY As Long
    If DestHdc = 0 Or srcHdcOrBmp = 0 Or w = 1 And h = 1 Then GoTo fail
    If IsBmp Then   '若傳入的是Bmp控制代碼,需為其建立一個臨時DC
        sBmp = srcHdcOrBmp
        tHdc(3) = NewMyHdc(DestHdc, 0, 0, srcHdcOrBmp)
        sHdc = tHdc(3).hdc
    Else
        sHdc = srcHdcOrBmp
        If srcW = 0 Then sBmp = GetCurrentObject(sHdc, 7)
    End If
    If sHdc = 0 Or sBmp = 0 Then GoTo fail
    If srcW = 0 Then    '若沒有提供源圖大小,需取得整個源圖大小
        GetObj sBmp, Len(Bm), Bm
        sw = Bm.bmWidth - srcX
        sh = Bm.bmHeight - srcY
    Else
        sw = srcW
        sh = srcH
    End If
    If sw < 1 Or sh < 1 Then GoTo fail
    If tc = -1 Then
        cc = GetPixel(sHdc, srcX, srcY)       '將左上方第一個像素作為源圖背景色,用於透明
    Else
        cc = tc
    End If
    If w <> sw Or h <> sh Then
        tHdc(2) = NewMyHdc(DestHdc, w, h)
        StretchBlt tHdc(2).hdc, 0, 0, w, h, sHdc, srcX, srcY, sw, sh, vbSrcCopy
        '先將源圖縮放,下面步驟就一樣了。
        NewDc = tHdc(2).hdc
    Else
        NewDc = sHdc
        NewX = srcX
        NewY = srcY
    End If
    BitBlt DestHdc, X, y, w, h, NewDc, NewX, NewY, vbSrcInvert
    '將源圖先反色(XOR)繪入靶心圖表,若源圖背景為黑色,此步可省
       
    '下面是製作Mask圖的方法
    i = CreateBitmap(w, h, 1, 1, ByVal 0&)  '建立單色位元影像
    tHdc(0) = NewMyHdc(DestHdc, 0, 0, i)       '為單色圖建立新DC,並選入
    tHdc(1) = NewMyHdc(DestHdc, w, h)          '另建一個彩色圖及DC,用於存放Mask圖
    oc = SetBkColor(NewDc, cc)              '將源圖背景色改為透明色
    BitBlt tHdc(0).hdc, 0, 0, w, h, NewDc, NewX, NewY, vbSrcCopy
    '先將源圖繪入單色DC,由此產生只有正反的Mask圖,背景色(透明色)為黑,其它為白
    SetBkColor NewDc, oc                    '恢複源圖背景色,不是必須的,但這是個好習慣。
    BitBlt tHdc(1).hdc, 0, 0, w, h, tHdc(0).hdc, 0, 0, vbSrcCopy
    '單色DC必須複製進彩色DC才能進行後面的的AND運算
    'Mask圖完成,並已放入彩色DC
       
    BitBlt DestHdc, X, y, w, h, tHdc(1).hdc, 0, 0, vbSrcAnd    '標準透明繪圖:選將Mask圖用And運算繪入,
    BitBlt DestHdc, X, y, w, h, NewDc, NewX, NewY, vbSrcInvert '再將源圖以反色(XOR)繪入一次
   
    DelMyHdc tHdc(0)
    DelMyHdc tHdc(1)
   
    If tHdc(2).hdc <> 0 Then DelMyHdc tHdc(2)
    If tHdc(3).hdc <> 0 Then DelMyHdc tHdc(3)
    TranBlt = cc
    Exit Function
fail:
    If tHdc(3).hdc <> 0 Then DelMyHdc tHdc(3)
    TranBlt = -1
End Function

Private Function NewMyHdc(dHdc As Long, w As Long, h As Long, Optional Bm As Long) As MemHdc
    With NewMyHdc
        .hdc = CreateCompatibleDC(dHdc)
        If Bm = 0 Then
            .Bmp = CreateCompatibleBitmap(dHdc, w, h)
        Else
            .Bmp = Bm
        End If
        .obm = SelectObject(.hdc, .Bmp)
    End With
End Function
Private Function DelMyHdc(MyHdc As MemHdc, Optional nobmp As Boolean) As MemHdc
    With MyHdc
        If .hdc <> 0 And .obm <> 0 Then SelectObject .hdc, .obm
        If nobmp = False And .Bmp <> 0 Then DeleteObject .Bmp
        If .hdc <> 0 Then DeleteDC .hdc
    End With
End Function

Private Sub Command1_Click()
    TranBlt Picture1.hdc, 0, 0, Image1.Width, Image1.Height, Image1.Picture.handle, , , , , , True
End Sub

Private Sub Form_Load()
    Me.ScaleMode = 3
End Sub

本篇中的公用函數NewMyHdc、DelMyHdc及相關結構與API聲明,可在以下文章中找到
http://blog.csdn.net/homezj/archive/2005/04/14/348001.aspx


相關文章

E-Commerce Solutions

Leverage the same tools powering the Alibaba Ecosystem

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。