Attribute VB_Name = "Blt"
'=====================================================
'  マスクを生成する関連関数郡
'    2004/11/11 The day of Pocky!  written by hilo
'    お約束
'      このモジュールを利用して起きたいかなる問題にも
'      私は一切責任を負いません。
'    http://hilo.s55.xrea.com/    hilo@s55.xrea.com
'=====================================================
'　How To Use
'　　この関数郡を使うと、マスク画像無しで透過転送をできるようになります。
'　　マスク画像を作成する
'　　　MaskBitBlt(描画先hDC, x , y , width , height , 描画元hDC, xSrc , ySrc)
'　　黒い部分を透過させて転送するBitBlt
'　　　MaskBitBltEx(描画先hDC, x , y , width , height , 描画元hDC, xSrc , ySrc)
'　　黒い部分を透過させて転送するStretchBlt
'　　　MaskStretchBlt(描画先hDC, x , y , width , height , 描画元hDC, xSrc , ySrc , srcWidth , srcHeight)
'=====================================================
Option Explicit

'-----------------------------------------------------
'　WindowsAPI利用宣言
'-----------------------------------------------------
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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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

'-----------------------------------------------------
'　関数名：MaskBitBlt
'　引数　：BitBltなどとほぼ同じ
'　　　　　hDestDC:描画先デバイスコンテキストハンドル x,y,nWidth,nHeight:描画先の左上の位置と高さと幅
'　　　　　hSrcDC:描画元デバイスコンテキストハンドル xSrc,ySrc:描画元の左上の位置
'　戻り値：成功は0以外。失敗は0
'　概要　：元絵画像の黒い部分を透過させるためのマスクを作成する
'-----------------------------------------------------
Public Function MaskBitBlt(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) As Long

'----Declare Parameters----
    Dim iBackColor1, iBackColor2 As Long    '色の保持
    Dim iMaskDC As Long                     'テンポラリ画像hDC
    Dim iMaskBitmap As Long                 'テンポラリ白黒画像
    Dim retNum As Long                      '戻り値用

'----Initialize----
    retNum = 0

    '転送先背景色を白にする
    iBackColor1 = SetBkColor(hDestDC, &HFFFFFF)
    'テンポラリBitmap画像のデバイスコンテキストの作成
    iMaskDC = CreateCompatibleDC(hDestDC)
    'テンポラリの白黒Bitmap画像の作成
    iMaskBitmap = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)

'----Succeeded CreateBitmap----
    If iMaskBitmap <> 0 Then
        'デバイスコンテキストとグラフィックオブジェクトを関連付ける
        SelectObject iMaskDC, iMaskBitmap
        '転送元背景色を黒にする
        iBackColor2 = SetBkColor(hSrcDC, &H0)
        'マスク画像用Bitmapに転送元の画像を転送
        BitBlt iMaskDC, 0, 0, nWidth, nHeight, hSrcDC, xSrc, ySrc, vbSrcCopy
        '転送元の背景を元に戻す
'        SetBkColor hSrcDC, iBackColor2
        '転送先にマスク画像を送る
        retNum = BitBlt(hDestDC, x, y, nWidth, nHeight, iMaskDC, 0, 0, vbSrcCopy)
        '転送先の背景色を元に戻す
'        SetBkColor hDestDC, iBackColor1
    End If

'----Terminate----
'    SelectObject iMaskDC, iMaskBitmap
    'デバイスコンテキストの削除
    DeleteDC iMaskDC
    'マスク画像の削除
    DeleteObject iMaskBitmap

'----Return----
    MaskBitBlt = retNum
    
End Function

'-----------------------------------------------------
'　関数名：MaskBitBltEx
'　引数　：BitBltなどとほぼ同じ
'　　　　　hDestDC:描画先デバイスコンテキストハンドル x,y,nWidth,nHeight:描画先の左上の位置と高さと幅
'　　　　　hSrcDC:描画元デバイスコンテキストハンドル xSrc,ySrc:描画元の左上の位置
'　戻り値：成功は0以外。失敗は0
'　概要　：描画元の黒い部分を透過させて描画先に描画
'-----------------------------------------------------
Public Function MaskBitBltEx(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) As Long
        
'----Declare Parameters----
    Dim iMaskDC As Long         'テンポラリ画像hDC
    Dim iMaskBitmap As Long     'テンポラリ白黒画像
    Dim retNum As Long          '戻り値用

'----Initialize----
    retNum = 0
    'デバイスコンテキストの作成
    iMaskDC = CreateCompatibleDC(hDestDC)
    'カラー画像の作成
    iMaskBitmap = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
    
'----Succeeded CreateBitmap----
    If (iMaskBitmap <> 0) Then
        'デバイスコンテキストとオブジェクトの関連付け
        SelectObject iMaskDC, iMaskBitmap
        'マスク作成
        MaskBitBlt iMaskDC, 0, 0, nWidth, nHeight, hSrcDC, xSrc, ySrc
        '透過転送　And->Or
        'マスク転送
        BitBlt hDestDC, x, y, nWidth, nHeight, iMaskDC, 0, 0, vbSrcAnd
        '元絵転送
        retNum = BitBlt(hDestDC, x, y, nWidth, nHeight, hSrcDC, xSrc, ySrc, vbSrcPaint)
    End If
    
'----Terminate----
'    SelectObject iMaskDC, iMaskBitmap
    'デバイスコンテキストの削除
    DeleteDC iMaskDC
    'マスク画像の削除
    DeleteObject iMaskBitmap
    
'----Return----
    MaskBitBltEx = retNum
    
End Function

'-----------------------------------------------------
'　関数名：MaskStretchBltEx
'　引数　：BitBltなどとほぼ同じ
'　　　　　hDestDC:描画先デバイスコンテキストハンドル x,y,nWidth,nHeight:描画先の左上の位置と高さと幅
'　　　　　hSrcDC:描画元デバイスコンテキストハンドル xSrc,ySrc,nSrcWidth,nSrcHeight:描画元の左上の位置と高さと幅
'　戻り値：成功は0以外。失敗は0
'　概要　：描画元の黒い部分を透過させて描画先に描画。描画先のサイズが可変
'-----------------------------------------------------
Public Function MaskStretchBltEx(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 nSrcWidth As Long, ByVal nSrcHeight As Long) As Long
        
    '----Declare Parameters----
    Dim iMaskDC As Long         'テンポラリ画像hDC
    Dim iMaskBitmap As Long     'テンポラリ白黒画像
    Dim retNum As Long          '戻り値用

    '----Initialize----
    retNum = 0
    'デバイスコンテキスト作成
    iMaskDC = CreateCompatibleDC(hSrcDC)
    'マスク用カラー画像
    iMaskBitmap = CreateCompatibleBitmap(hSrcDC, nSrcWidth, nSrcHeight)
    
    '----Succeeded CreateBitmap----
    If (iMaskBitmap <> 0) Then
        'デバイスコンテキストとオブジェクトの関連付け
        SelectObject iMaskDC, iMaskBitmap
        'マスク作成
        MaskBitBlt iMaskDC, 0, 0, nSrcWidth, nSrcHeight, hSrcDC, xSrc, ySrc
        '透過転送 And->Or
        'マスク転送
        StretchBlt hDestDC, x, y, nWidth, nHeight, iMaskDC, 0, 0, nSrcWidth, nSrcHeight, vbSrcAnd
        '元絵転送
        retNum = StretchBlt(hDestDC, x, y, nWidth, nHeight, hSrcDC, xSrc, ySrc, nSrcWidth, nSrcHeight, vbSrcPaint)
    End If
    
    '----Terminate----
'    SelectObject iMaskDC, iMaskBitmap
    'デバイスコンテキスト削除
    DeleteDC iMaskDC
    'マスク画像削除
    DeleteObject iMaskBitmap
    
    '----Return----
    MaskStretchBltEx = retNum
    
End Function