Sample 20
エンボスフィルター
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