Sample 25

グレースケールフィルター
いわゆる　グレースケール256色階調変換

DownLoad

Command1
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
'--------------------------------------------------------------
Private Sub Command1_Click()

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

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

    'グレースケールフィルターの実行
    Call export_GrayScale(Picture2.hdc, _
                                Picture1.hdc, _
                                0, _
                                0, _
                                Picture1.ScaleWidth, _
                                Picture1.ScaleHeight)
    '出力後の再描画
    Picture1.Refresh
    '
    '一部分を拡大して表示する
    '
    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)

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

    '初期設定(サンプルということで...)
　 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 'ピクセル
End Sub
'--------------------------------------------------------------
' ＲＧＢ値をＲ，Ｇ，Ｂに分割する
'--------------------------------------------------------------
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 Function export_GrayScale(ByVal imghDC&, _
                                                ByVal outhDC&, _
                                                ByVal x1&, _
                                                ByVal y1&, _
                                                ByVal x2&, _
                                                ByVal y2&) As Boolean

    Dim x&, y As Long 'ループ用
    'RGB分解用
    Dim col As Long
    Dim colR&, colG&, colB As Long
    '
    For y = y1 To y2
        For x = x1 To x2
        　'----------------------------------------------
        　' 画質を優先する場合は、変更してください。)
        　'----------------------------------------------
        'RGB読み取り分解
        Call RGB2R_G_B(GetPixel(imghDC, x, y), colR, colG, colB)
        '
        col = (colR + colG + colB) / 3 '相加平均を求める
        col = RGB(col, col, col) ' 256階調化（0〜255）
        '画像の色情報を書込む
        Call SetPixelV(outhDC, x, y, col&)
          DoEvents
    Next x , y
    export_GrayScale = True
End Function