Option Explicit

'ピクセル色を取得する
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

'ピクセル色を描画する
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor 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 hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

'オブジェクトを選択する
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

'オブジェクトを開放する
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'指定したDCとコンパチなDCを作る
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

'DCを削除する
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

'指定したDCに割り当てられているものと互換のBitmapオブジェクトを作る
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nheight As Long) As Long

'キャンセルフラグです
Private mCancel As Boolean

Public Event mPer(ByVal Per As Integer)

'処理をキャンセルします
Sub Cancel()
    mCancel = True
End Sub

'ぼかし関数です
Sub Shade(ByVal srcDC As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal dstDC As Long, ByVal Influence As Integer)
    Dim lngRet          As Long
    Dim lngSrcHDC       As Long
    Dim lngDstHDC       As Long
    Dim lngSrcHBITMAP   As Long
    Dim lngDstHBITMAP   As Long
    
    '仮想hDCの収得
    lngSrcHDC = CreateCompatibleDC(srcDC)
    lngDstHDC = CreateCompatibleDC(srcDC)
    
    '仮想ビットマップを作成します
    lngSrcHBITMAP = CreateCompatibleBitmap(srcDC, srcWidth, srcHeight)
    lngDstHBITMAP = CreateCompatibleBitmap(srcDC, srcWidth, srcHeight)
    
    'lngSrcHDCへ仮想ビットマップを割付します
    lngRet = SelectObject(lngSrcHDC, lngSrcHBITMAP)
    'lngDstHDCへ仮想ビットマップを割付します
    lngRet = SelectObject(lngDstHDC, lngDstHBITMAP)
    
    'lngSrcHDCへ画像をコピーします
    lngRet = BitBlt(lngSrcHDC, 0, 0, srcWidth, srcHeight, srcDC, 0, 0, vbSrcCopy)
    
    QuickShade lngSrcHDC, srcWidth, srcHeight, lngDstHDC, Influence
    
    '処理がキャンセルされていれば
    '処理中の画像を反映しないようにします
    If mCancel = False Then
        lngRet = BitBlt(dstDC, 0, 0, srcWidth, srcHeight, lngDstHDC, 0, 0, vbSrcCopy)
    Else
        mCancel = False
    End If
    
    '仮想DCを削除します
    lngRet = DeleteDC(lngSrcHDC)
    lngRet = DeleteDC(lngDstHDC)
    '仮想ビットマップを削除します
    lngRet = DeleteObject(lngSrcHBITMAP)
    lngRet = DeleteObject(lngDstHBITMAP)
    
End Sub

'ぼかし処理をします
Private Sub QuickShade(ByVal srcHDC As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal dstHDC As Long, ByVal inf As Integer)
    Dim jx              As Integer
    Dim jy              As Integer
    Dim jxMax           As Integer
    Dim jyMax           As Integer
    Dim lngBuffer(2)    As Long
    Dim lngRefColor     As Long
    Dim lngSetColor     As Long
    Dim kx              As Integer
    Dim ky              As Integer
    Dim cnt             As Long
    
    Dim flg             As Integer
    Dim kx2             As Long
    Dim kx2Max          As Long
    Dim lngSaveRed      As Long
    Dim lngSaveGreen    As Long
    Dim lngSaveBlue     As Long
    Dim lngSaveCount    As Long
    
    'ピクチャボックスのサイズを設定します
    jxMax = srcWidth
    jyMax = srcHeight
    
    'ぼかし処理をします
    For jy = 0 To jyMax
        For jx = 0 To jxMax
            
            'インクリメント用の変数なので
            'ここで初期化しておきます
            lngBuffer(0) = 0: lngBuffer(1) = 0: lngBuffer(2) = 0
            
            If jx = inf And jy >= inf And jy <= jyMax - inf Then
                '内側の処理へ入る前の処理です
                '左側のエリアの平均色を求めます
                flg = 1
                GoSub SubShade
                GoSub SubShade2
                
            ElseIf jx >= inf And jx <= jxMax - inf And jy >= inf And jy <= jyMax - inf Then
                '内側の処理です
                '右側のピクセルの平均色を求めます
                flg = 2
                GoSub SubShade
                GoSub SubShade2
                
            Else
                '外側の処理です
                '通常のぼかし処理をします
                flg = 0
                GoSub SubShade
            End If
            
            '最終的にlngSetColorの色を描画します
            SetPixel dstHDC, jx, jy, lngSetColor
        Next jx
        DoEvents
        RaiseEvent mPer((jy / jyMax) * 100)
        If mCancel = True Then Exit Sub
    Next jy
        
    Exit Sub
    
SubShade:
    cnt = 0
    
    'フラグに応じて
    'ピクセル色を取得するエリアを限定します
    If flg = 0 Then
        kx2 = -inf
        kx2Max = inf
    ElseIf flg = 1 Then
        kx2 = -inf
        kx2Max = inf - 1
    ElseIf flg = 2 Then
        kx2 = inf - 1
        kx2Max = inf
    End If
    
    'ピクセル色の取得をします
    For ky = -inf To inf
        For kx = kx2 To kx2Max
            If (jx >= kx And jx <= jxMax - kx) And (jy >= ky And jy <= jyMax - ky) Then
                lngRefColor = GetPixel(srcHDC, jx + kx, jy + ky)
                If Not (lngRefColor <= -1) Then
                    lngBuffer(0) = lngBuffer(0) + lngRefColor Mod &H100
                    lngBuffer(1) = lngBuffer(1) + (lngRefColor Mod &H10000) \ &H100
                    lngBuffer(2) = lngBuffer(2) + lngRefColor \ &H10000
                    cnt = cnt + 1
                End If
            End If
    Next kx, ky
    If cnt = 0 Then Stop
    
    '取得したピクセルを保存しておきます
    If Not (flg = 0) Then
        lngSaveRed = lngBuffer(0)
        lngSaveGreen = lngBuffer(1)
        lngSaveBlue = lngBuffer(2)
        lngSaveCount = cnt
    End If
    
    '描画するピクセル色を決定します
    lngSetColor = RGB(lngBuffer(0) ¥ cnt, lngBuffer(1) ¥ cnt, lngBuffer(2) ¥ cnt)
    Return
    
SubShade2:
    
    '右端ピクセルだけを取得します
    cnt = 0
    For ky = -inf To inf
        lngRefColor = GetPixel(srcHDC, jx + inf, jy + ky)
        lngBuffer(0) = lngBuffer(0) + lngRefColor Mod &H100
        lngBuffer(1) = lngBuffer(1) + (lngRefColor Mod &H10000) \ &H100
        lngBuffer(2) = lngBuffer(2) + lngRefColor \ &H10000
        cnt = cnt + 1
    Next
    If cnt = 0 Then Stop
    
    '保存しておいた値と、
    '今取得した値の平均値を出してRGBに変換します
    lngSetColor = RGB( _
              (lngBuffer(0) ¥ cnt + lngSaveRed) ¥ (lngSaveCount + 1) _
            , (lngBuffer(1) ¥ cnt + lngSaveGreen) ¥ (lngSaveCount + 1) _
            , (lngBuffer(2) ¥ cnt + lngSaveBlue) ¥ (lngSaveCount + 1))
    
    '次に使用するときのために保存しておきます
    lngSaveRed = lngBuffer(0)
    lngSaveGreen = lngBuffer(1)
    lngSaveBlue = lngBuffer(2)
    lngSaveCount = cnt
    Return
    
End Sub