投稿時間：2007/05/10(Thu) 15:21
投稿者名：なな
Ｅメール：
ＵＲＬ ：
タイトル：エンボス加工で色は白と黒にしたい
先日はお世話になりました。
VB歴３年のPGです。
環境:VB6(SP5) WinXp
今回は、画像のエンボス処理をVBで行っています。
他のサイトにサンプルソースがありましたので。参考にさせていただきましたが。
カラーの画像をエンボス加工すると、カラーが多少残るようです。
色は白か黒にしたいです。
なんとか解決したいと思いますので よろしくお願いします。
------------------------------------------------------------
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)の中身はこんな並び
' 0, 0, 0, _
1, 0, -1, _
0, 0, 0
Private mask(8) As Long 'Longの方が若干高速なので...
'--------------------------------------------------------------
Private Sub Command1_Click()
Dim i As Integer 'ループカウント
'
'マウスポインターを砂時計にする
Screen.MousePointer = 11
'画像データのサイズに合わせる
Picture1.Height = Picture2.Height
Picture1.Width = Picture2.Width
'-------------------------------
'Text1 の値は、反映されません。
'各mask(*)値に代入してください。
'-------------------------------
'エンボスフィルターの実行
Call export_EffEmboss(Picture2.hdc, _
Picture1.hdc, _
0, _
0, _
Picture1.ScaleWidth, _
Picture1.ScaleHeight)
'出力後の再描画
Picture1.Refresh
'マウスポインターを通常に
Screen.MousePointer = 0
End Sub
'--------------------------------------------------------------
Private Sub Form_Load()
Dim i As Integer 'ループカウンタ
'初期設定(サンプルということで...)
Picture1.AutoSize = False '
Picture1.AutoRedraw = True '
Picture1.BorderStyle = 0 '
Picture1.ScaleMode = vbPixels 'ピクセル
Picture2.AutoSize = True
Picture2.AutoRedraw = True
Picture2.BorderStyle = 0
Picture2.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 = 3
Picture2.Picture = LoadPicture("C:\TEST.BMP")
End Sub
'---------------------------------------------------
Private Sub List1_Click()
'
' エンボス用のマスクフィルターをセットする
'
Call EmbossMaskList(List1.ListIndex)
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 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
Dim i As Integer
'RGB計算用
Dim lngR As Long
Dim lngG As Long
Dim 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
Next yy
'灰色にするために +255している
lngR = lngR + 255
lngG = lngG + 255
lngB = lngB + 255
'
'各マスクフィルター値の総和は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
|