【API Function】

ラバーバンディング処理

　ペイント系ソフトで見かける、上のような （これではちょっとわかりづらいですね・・・）マウスにあわせた ラバーバンド描画を行います。APIを使用しない方法と APIを使用した方法の２つを紹介しています。 どちらも十分とは言えない方法ですが、比較的簡単な処理で、 動作も非常に軽いです。

（APIを使用しない方法）

　Shape コントロールをマウスの動きにあわせて移動して、擬似的に 描画しているように見せる方法です。画面のちらつきを除けば、VBらしくて ベターな方法です。
　まず、次のようにコントロールを配置してプロパティを変更して下さい。

　配置したオブジェクトのプロパティを変更します。
（プロパティ表）
Form1
ScaleMode3-ピクセル
Picture1
Appearance0-フラット
AutoRedrawTrue
BorderStyle0-なし
ScaleMode3-ピクセル
HScroll1(0)
Max255
Min0
HScroll1(1)
Max255
Min0
HScroll1(2)
Max255
Min0

フォームのGeneralセクションに次の宣言コードを追加して下さい。

    Dim mDown As Boolean       'マウスがダウンされているか
    Dim tx As Long, ty As Long '描画開始点(マウスのダウン位置)保管
    Dim sx As Long, sy As Long '描画する領域の左上隅座標
    Dim ex As Long, ey As Long '描画する領域の右下隅座標
    Dim oldBorderColor As Long '以前の枠の色
    Dim PenColor As Long       'ペンの色

　Form_Load,Picture1_MouseDown,Picture1_MouseMove,Picture1_MouseUp イベントプロシージャに、それぞれ次のコードを追加して下さい。 

Private Sub Form_Load()
    mDown = False
    Shape1.Visible = False
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
    tx = CLng(X)
    ty = CLng(Y)
    oldBorderColor = Shape1.BorderColor
    PenColor = RGB(HScroll1(0).Value, _
                   HScroll1(1).Value, HScroll1(2).Value)
    Shape1.BorderColor = PenColor
    Shape1.Move X, Y, 0, 0
    Shape1.Visible = True
    mDown = True
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)

    If mDown = False Then Exit Sub
    If tx <= CLng(X) Then sx = tx: ex = CLng(X)
    If tx > CLng(X) Then sx = CLng(X): ex = tx
    If ty <= CLng(Y) Then sy = ty: ey = CLng(Y)
    If ty > CLng(Y) Then sy = CLng(Y): ey = ty
    Shape1.Move sx, sy, ex - sx, ey - sy
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _
                             X As Single, Y As Single)
    Dim oldFillStyle As Long

    oldFillStyle = Picture1.FillStyle
    Picture1.FillStyle = 0
    Picture1.Line (sx, sy)-(ex, ey), PenColor, BF
    mDown = False
    Shape1.Visible = False
    Picture1.FillStyle = oldFillStyle
    Shape1.BorderColor = oldBorderColor
End Sub

　なんとも邪道な方法かも知れませんが、見た目は高度っぽいかな・・・。

（APIを使用する方法）

　通常、デバイスコンテキストにあるペンで描画すると、そのペンの色で 描画されますが、SetROP2 API関数を用いると背景に依存したペン色 で描画することが可能になります。ラバーバンド描画において、 マウスが移動すると枠がそれにあわせて大きくなったり小さくなったりします。 この枠を描画したなら、背景を一回一回コピーし直して復元しなければなりません。 その方法でも問題ないのですが、処理が重くなってしまいます。 そこで、その SetROP2 を用います。この関数を用いると「前景モード」 といって、描画するペンの色を背景色に対して作成することができます。
　先に宣言定数をみていきます。
　まず、上記の(APIを使用しない方法)のようにコントロール（Shape以外） を配置して、プロパティを変更して下さい。
　次に、フォームのGeneralセクションに次の宣言コードを追加して下さい。

'APIの定義--------------------------------------------------
'===========================================================
'Rectangle   長方形を描画する
'---------引数----------------------------------------------
'hdc：描画先デバイスコンテキスト
'X1,Y1：長方形の左上隅の座標
'X2,Y2：長方形の右下隅の座標
'===========================================================
Private Declare Function Rectangle Lib "gdi32" _
            (ByVal hDC As Long, ByVal X1 As Long, _
            ByVal Y1 As Long, ByVal X2 As Long, _
            ByVal Y2 As Long) As Long

'===========================================================
'SetROP2    前景モードを設定します。
'           前景モードとは、描画する色と画面上にある色を
'           どのように組み合わせるかを指定するものです。
'---------引数----------------------------------------------
'hdc：前景モード指定先デバイスコンテキスト
'nDrawMode：前景モード
'===========================================================
Private Declare Function SetROP2 Lib "gdi32" _
              (ByVal hDC As Long, _
               ByVal nDrawMode As Long) As Long

    ' Binary raster ops(描画されるペンの色は？)
    Private Const R2_BLACK = 1&
    Private Const R2_NOTMERGEPEN = 2&
    Private Const R2_MASKNOTPEN = 3&
    Private Const R2_NOTCOPYPEN = 4&
    Private Const R2_MASKPENNOT = 5&
    '背景の色を反転した色です。
    Private Const R2_NOT = 6&
    '描画する色と､背景の色との排他的論理和の色
    Private Const R2_XORPEN = 7&
    Private Const R2_NOTMASKPEN = 8&
    Private Const R2_MASKPEN = 9&
    'R2_XORPENを反転した色
    Private Const R2_NOTXORPEN = 10&
    Private Const R2_NOP = 11&
    Private Const R2_MERGENOTPEN = 12&
    '通常のペンの色です
    Private Const R2_COPYPEN = 13&
    Private Const R2_MERGEPENNOT = 14&
    Private Const R2_MERGEPEN = 15&
    Private Const R2_WHITE = 16&
'------------------------------------------------------------

Dim mDown As Boolean       'マウスがダウンされているか
Dim mDraw As Boolean       '最初の描画であるか
Dim tx As Long, ty As Long '描画開始点(マウスのダウン位置)保管
Dim sx As Long, sy As Long '描画する領域の左上隅座標
Dim ex As Long, ey As Long '描画する領域の右下隅座標
Dim oldFillColor As Long   '以前の塗りつぶし色
Dim oldForeColor As Long   '以前のペンの色

　上記の定数を見て下さい。SetROP2 関数のデフォルトは当然 R2_COPYPEN = 13& で、通常のペンの色に設定されています。そこで、この 設定をラバーバンドが可能なものにしてやればいいわけです。 ラバーバンド描画は、「一度描いた枠をもう一度描くとその枠が消えて背景に戻る」 と解釈できます。ということは、結論から言って、 R2_NOT = 6&,R2_XORPEN =7&,R2_NOTXORPEN = 10& の３つがこの処理に向いています。 例えば、R2_NOT = 6&であれば、背景色を反転したペン色で描くわけですから、 もう一度描けば、元の背景→反転→反転→元の背景のように戻ります。 他の２つもこれと同様な考えです。この処理は、論理演算のペンバージョン なので、画像コピーの処理と同様に考えると、非常にわかりやすいです。
　では、それぞれのイベントプロシージャに次のコードを追加して下さい。 

Private Sub Form_Load()
    mDown = False
    mDraw = False
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
    'マウス位置を保管
    tx = CLng(X)
    ty = CLng(Y)
    'マウスダウン
    mDown = True
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
                               X As Single, Y As Single)
    Dim oldROPoption As Long '以前の前景モード
    Dim hDC As Long '描画先デバイスコンテキスト
    
    'マウスがダウンされていない場合、プロシージャを抜ける
    If mDown = False Then Exit Sub
    hDC = Picture1.hDC
    '前景モードを
    'R2_NOTXORPEN or R2_NOT or R2_XORPEN にする(論理演算の応用)
    oldROPoption = SetROP2(hDC, R2_NOTXORPEN)
    '塗りつぶし色の保管と変更
    oldFillColor = Picture1.FillColor
    oldForeColor = Picture1.ForeColor
    Picture1.FillColor = RGB(HScroll1(0).Value, _
                   HScroll1(1).Value, HScroll1(2).Value)
    Picture1.ForeColor = RGB(HScroll1(0).Value, _
                   HScroll1(1).Value, HScroll1(2).Value)
    '最初の描画でなければ、以前の描画を消す
    If mDraw = True Then
        Rectangle hDC, sx, sy, ex, ey
    End If
    '描画領域の指定
    If tx <= CLng(X) Then sx = tx: ex = CLng(X)
    If tx > CLng(X) Then sx = CLng(X): ex = tx
    If ty <= CLng(Y) Then sy = ty: ey = CLng(Y)
    If ty > CLng(Y) Then sy = CLng(Y): ey = ty
    'ラバーバンドを描画
    Rectangle hDC, sx, sy, ex, ey
    '以前の前景モードの設定
    SetROP2 hDC, oldROPoption
    Picture1.Refresh
    mDraw = True
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _
                             X As Single, Y As Single)
    Dim oldFillStyle As Long '以前の塗りつぶしタイプ
    
    '塗りつぶしタイプの保管と変更
    oldFillStyle = Picture1.FillStyle
    Picture1.FillStyle = 0
    mDown = False
    mDraw = False
    '最後に塗りつぶす
    Rectangle Picture1.hDC, sx, sy, ex, ey
    Picture1.Refresh
    Picture1.FillStyle = oldFillStyle
    Picture1.FillColor = oldFillColor
    Picture1.ForeColor = oldForeColor
End Sub

わかりにくい説明ですみません。流れ的にもうちょっとうまくいかないかなぁ。

(参考書)
『Windows95APIパワフルテクニック大全集』
Matthew Telles/Andrew Cooke 著
羽山　博 監訳
テクニカルコア 訳編
インプレス出版

API Functionインデックス トップ

Copyright(C)2000 Tomoya. All rights reserved.