Sample 20

エンボスフィルター

DownLoad


Command1
Text1(0)〜Text1(8)
List1
Picture1
Picture2
Picture3

をフォームに貼り付けて、以下のコードを、フォームのソースコードへコピーして貼り付けてください。

Picture2 にお好きな画像を貼り付ければ実行できます。

VB4以降であれば、問題なく実行可能なはずです。


Option Explicit

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 GetPixel Lib "gdi32" _
                     (ByVal hdc As Long, _
                      ByVal x As Long, _
                      ByVal y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" _
                     (ByVal hdc As Long, _
                      ByVal x As Long, _
                      ByVal y As Long, _
                      ByVal crColor As Long) As Long
'mask(9)の中身はこんな並び
' 1, 0, 0, _
  0, 0, 0, _
  0, 0, -1

Private mask(8) As Long 'Longの方が若干高速なので...

'--------------------------------------------------------------
Private Sub Command1_Click()

    '
    'マウスポインターを砂時計にする
    Screen.MousePointer = 11

    '画像データのサイズに合わせる
    Picture1.Height = Picture2.Height
    Picture1.Width = Picture2.Width

    'エンボスフィルターの実行
    Call export_EffEmboss(Picture2.hdc, _
                                Picture1.hdc, _
                                0, _
                                0, _
                                Picture1.ScaleWidth, _
                                Picture1.ScaleHeight)
    '出力後の再描画
    Picture1.Refresh
    '
    '一部分を拡大して表示する
    '

   '===========================================
   'ここから2000年11月22日修正
    Call StretchBlt(Picture3.hdc, _
                            0, 0, _
                            Picture3.ScaleWidth \ 2, Picture3.ScaleHeight, _
                            Picture1.hdc, _
                            0, 0, _
                            Picture3.ScaleWidth \ 4, Picture3.ScaleHeight \ 2, _
                            vbSrcCopy)

    Call StretchBlt(Picture3.hdc, _
                            Picture3.ScaleWidth \ 2, 0, _
                            Picture3.ScaleWidth, Picture3.ScaleHeight, _
                            Picture2.hdc, _
                            0, 0, _
                            Picture3.ScaleWidth \ 2, Picture3.ScaleHeight \ 2, _
                            vbSrcCopy)

   'ここまで2000年11月22日修正
   'ダウンロードできるサンプルには、反映されてません。
   '===========================================

    '拡大部分の再描画
    Picture3.Refresh
    'マウスポインターを通常に
    Screen.MousePointer = 0
End Sub

'--------------------------------------------------------------
Private Sub Form_Load()
    Dim i As Integer 'ループカウンタ

   '===========================================
   '2000年11月22日修正
   Me.ScaleMode = vbPixels
'ピクセル
   '
===========================================
    '初期設定(サンプルということで...)

    Picture1.AutoSize = False 
    Picture1.AutoRedraw = True 
    Picture1.BorderStyle = 0 
    Picture1.ScaleMode = vbPixels 'ピクセル

    Picture2.AutoSize = True
    Picture2.AutoRedraw = True
    Picture2.BorderStyle = 0
    Picture2.ScaleMode = vbPixels 'ピクセル

    Picture3.AutoSize = False
    Picture3.AutoRedraw = True
    Picture3.BorderStyle = 0
    Picture3.ScaleMode = vbPixels 'ピクセル
    '
    '

    For i = 0 To Text1.Count - 1
        Text1(i).Enabled = False
        Text1(i).Text = "1"
    Next i
    '
    'リストへ、エンボス方向を追加

    List1.Clear

    List1.AddItem "左"
    List1.AddItem "左上"
    List1.AddItem "上"
    List1.AddItem "右上"
    List1.AddItem "右"
    List1.AddItem "右下"
    List1.AddItem "下"
    List1.AddItem "左下"

    List1.ListIndex = 0
End Sub

'---------------------------------------------------
Private Sub List1_Click()
    '
    ' エンボス用のマスクフィルターをセットする
    '

    Call EmbossMaskList(List1.ListIndex)
End Sub

'--------------------------------------------------------------
' RGB値をR,G,Bに分割する
'--------------------------------------------------------------

Private Sub RGB2R_G_B(ByVal lngRGB As Long, _
                                ByRef lngR As Long, _
                                ByRef lngG As Long, _
                                ByRef lngB As Long)
    lngR = lngRGB And &HFF&
    lngG = (lngRGB And &HFF00&) \ &H100
    lngB = (lngRGB And &HFF0000) \ &H10000 'B
End Sub

'--------------------------------------------------------------
'フィルターの値をセットする
'--------------------------------------------------------------

Private Sub SetFiler9(index As Integer, p As Integer)
    mask(index) = p
End Sub

'--------------------------------------------------------------
' エンボスフィルター
'
' わかりやすくするため、最適化していません。
'--------------------------------------------------------------

Private Function export_EffEmboss(ByVal imghDC&, _
                                                ByVal outhDC&, _
                                                ByVal x1&, _
                                                ByVal y1&, _
                                                ByVal x2&, _
                                                ByVal y2&) As Boolean

    'mask用のカウント
    Dim sadr As Long
    'ループ用
    Dim x&, y As Long  
    Dim xx&, yy As Long
    'RGB計算用
    Dim lngR As Long, lngG As Long, lngB As Long
    'RGB分解用
    Dim col As Long
    Dim colR&, colG&, colB As Long
    '
    For y = y1 To y2
        '    
        For x = x1 To x2
            '3x3 のサイズに対してフィルターを使用します。
            For yy = 0 To 2
                For xx = 0 To 2
                    '---------------------------
                    ' 画像の色を読込む
                '    ---------------------------


                    '   取得した色をRGB分解します('-')
                    ' 分解してから計算しないとちゃんとした結果はできませんです。

                    Call RGB2R_G_B(GetPixel(imghDC, x + xx - 1, y + yy - 1), colR, colG, colB)

                    '指定フィルターを使用する
                    ' 分解したものを、前回のものと足していきます

                    lngR = lngR + colR * mask(sadr)
                    lngG = lngG + colG * mask(sadr)
                    lngB = lngB + colB * mask(sadr)
                    sadr = sadr + 1
            Next xx, yy

          '灰色にするために +127している 127なのは(255の半分)
          lngR = lngR + 127
          lngG = lngG + 127
          lngB = lngB + 127
          '
            '各マスクフィルター値の総和は0なので、割る必要はないが、
            '負の数にもなるので、負の場合は0にしてやる
            '

            If lngR < 0 Then lngR = 0
            If lngG < 0 Then lngG = 0
            If lngB < 0 Then lngB = 0
            col = RGB(lngR, lngG, lngB)
            '画像の色情報を書込む
            Call SetPixelV(outhDC, x, y, col&)
            '初期化
            sadr = 0
            lngR = 0
            lngG = 0
            lngB = 0
            '
            DoEvents
        Next x
    Next y

    export_EffEmboss = True
End Function

'--------------------------------------------
' エンボスのマスクフィルター値をセットする
'--------------------------------------------

Private Sub EmbossMaskList(ByVal Index As Long)
    Dim i As Integer
    '
    ' 初期化する
    '

    For i = 0 To 8
        mask(i) = 0
    Next i

    ' 光源はどこ?
    '

    Select Case Index
        Case 0 '左
            mask(3) = 1 '正は光源
            mask(5) = -1 '負は方向
        Case 1 '左上
            mask(0) = 1
            mask(8) = -1
        Case 2 '上
            mask(1) = 1
            mask(7) = -1
        Case 3 '右上
            mask(2) = 1
            mask(6) = -1
        Case 4 '右
            mask(5) = 1
            mask(3) = -1
        Case 5 '右下
            mask(0) = -1
            mask(8) = 1
        Case 6 '下
            mask(1) = -1
            mask(7) = 1
        Case 7 '左下
            mask(2) = -1
            mask(6) = 1
    End Select
    '
    'マスクフィルターの内容がわかるように表示を更新しておく
    '

    For i = 0 To 8
        Text1(i).Text = mask(i)
    Next i
End Sub