【API Function】

[疑似AutoRedraw=True]
　Visual Basicには、「メモリ」という概念があまりなく、またそれを 知らなくてもプログラミングに影響はありません。ここで紹介している メモリDCはメモリ上のデバイスコンテキストのことで、PictureBox等の デバイスコンテキストと同様の働きをするものです。 　PictureBoxにAutoRedrawプロパティというものがありますが、 この値がFalseのときその描画領域が他のウインドウ等に隠れたりする と、そこに描かれているものは消えてしまいます。しかし、AutoRedraw =Trueのときは、他のウインドウ等に隠れたあとでも描画されたものは 消えません。これは、AutoRedraw=Trueのときは、描画されているものが メモリにコピーされているためです。 　この処理をAPIを使って実行してみます。 　まずフォームにコントロールを以下のように配置して下さい。

　それぞれのオブジェクトのプロパティ値を次のようにして下さい。

<<プロパティ表>>
Form1
ScaleMode3
Picture1
Appearance0
AutoRedrawFalse
BorderStyle0
ScaleMode3

ちょっと長い宣言コードをGeneralセクションに追加します。 

'仮想デバイスコンテキストを作る関数
Private Declare Function CreateCompatibleDC Lib "gdi32" _
        (ByVal hdc As Long) As Long
    '-------------------引数----------------------
    '(hdc) 互換性を持たせたいデバイスコンテキスト
    '      0を指定すると画面のデバイスコンテキスト
    '------------------戻り値---------------------
    '引数に指定したデバイスコンテキストと互換性をもつ
    'メモリデバイスコンテキストのハンドルが返る
    '関数が失敗すると0が返る

'仮想デバイスコンテキストを削除する関数
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc _
        As Long) As Long
    '-------------------引数----------------------
    '(hdc)  削除するデバイスコンテキスト
    '------------------戻り値---------------------
    '関数が成功すると0以外の値が返り、
    '関数が失敗すると0が返る

'指定されたデバイスコンテキストに関連するデバイスと互換性のある
'ビットマップを作成する関数
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
        (ByVal hdc As Long, ByVal nWidth As Long, _
        ByVal nHeight As Long) As Long
        '-------------------引数----------------------
    '(hdc)      互換性を持たせたいデバイスコンテキスト
    '(nWidth)   ビットマップの幅
    '(nHeight)  ビットマップの高さ
    '------------------戻り値---------------------
    '関数が成功するとビットマップのハンドルが返り、
    '関数が失敗すると0が返る

'指定されたデバイスコンテキストに、指定されたオブジェクトを設定する関数
Private Declare Function SelectObject Lib "gdi32" _
        (ByVal hdc As Long, ByVal hObject As Long) As Long
    '-------------------引数----------------------
    '(hdc)      オブジェクトを設定するデバイスコンテキスト
    '(hObject)  設定するオブジェクト
    '------------------戻り値---------------------
    '設定する前のオブジェクトが返る

'作成したオブジェクトを削除する関数
Private Declare Function DeleteObject Lib "gdi32" _
        (ByVal hObject As Long) As Long
    '-------------------引数----------------------
    '(hObject)  削除するオブジェクト
    '------------------戻り値---------------------
    '関数が成功すると0 以外の値が返り、
    '指定したハンドルが有効でないときや､デバイスコンテキストに
    '選択されているときは､0 が返る
    '**注意**　デバイスコンテキストをまず削除すること

'描画関数
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long

'点描画関数
Private Declare Sub SetPixel Lib "gdi32" (ByVal hdc As Long, _
        ByVal X As Long, ByVal Y As Long, _
        ByVal color As Long)

    Dim mhDC As Long'メモリDC
    'SourcePicの互換性のあるビットマップのハンドル
    Dim hBitmap As Long

　フォームのGeneralセクションにCopyGraphic(SourcePic As Object)， DrawGraphic(SourcePic As Object)，ReleaseMeDC()，SaveGraphic(SourcePic As Object) プロシージャを作成して下さい。このプロシージャに以下のコードを追加します。 

Private Sub CopyGraphic(SourcePic As Object)
'------------------------------------------------------------
'プロシージャ名 ： CopyGraphic
'処理 − メモリDC上の画像を指定されたObjectにコピーする
'引数リスト
'SourcePicPic  ： コピー先のObject
'------------------------------------------------------------

    'メモリDC上の画像を指定されたObjectにコピーする
    BitBlt SourcePic.hdc, 0&, 0&, SourcePic.Width, _
           SourcePic.Height, mhDC, 0&, 0&, vbSrcCopy

End Sub


Public Sub DrawGraphic(SourcePic As Object, St As Long)
    '適当な画像をPictureBoxに描く
    'セットアップ画面？
    Dim i As Long, j As Long
    Dim pc As Long
    Dim rate As Long

    If SourcePic.ScaleHeight >= 255& Then
        rate = SourcePic.ScaleHeight \ 255& + 1 + St
    Else
        rate = 255 \ SourcePic.ScaleHeight + St
    End If

    For j = 0& To SourcePic.ScaleHeight
        pc = RGB(0, 0, 255 - CByte(j \ rate))
        For i = 0& To SourcePic.ScaleWidth
            SetPixel SourcePic.hdc, i, j, pc
        Next i
    Next j
End Sub

上の描画コードは、特に他のものでも問題ありません。 

Public Sub ReleaseMeDC()
    'まず、メモリDCから削除する
    DeleteDC mhDC
    'ビットマップも削除
    'この順番が違うと破棄できない
    DeleteObject hBitmap
End Sub


Public Sub SaveGraphic(SourcePic As Object)
'------------------------------------------------------------
'プロシージャ名 ： SaveGraphic
'処理 − メモリDCにObjectの画像を保存する
'引数リスト
'SourcePicPic ：メモリに保存する画像があるObject
'------------------------------------------------------------

    '設定する前のビットマップのハンドル
    Dim hOldBitmap As Long
    Dim spw As Long, sph As Long 'コピー元の画像の幅，高さ

    'コピー元の画像の幅，高さを得る
    spw = SourcePic.ScaleWidth
    sph = SourcePic.ScaleHeight

    'メモリDCを作成
    mhDC = CreateCompatibleDC(SourcePic.hdc)
    'SourcePicの互換性のあるビットマップを作成する
    hBitmap = CreateCompatibleBitmap(SourcePic.hdc, spw, sph)
    'それをメモリDCに設定する
    hOldBitmap = SelectObject(mhDC, hBitmap)
    'メモリDCにコピー元の画像をコピーする
    BitBlt mhDC, 0&, 0&, spw, sph, SourcePic.hdc, 0&, 0&, vbSrcCopy
End Sub

そして、最後に次のプログラムコードを、Command1_Click，Command2_Click，Picture1_Paint()， Form_Unload(Cancel As Integer)プロシージャに追加します。

Private Sub Command1_Click()
    '適当な画像をPictureBoxに描く
    Call DrawGraphic(Picture1)
    'その描画をメモリ上に保存
    Call SaveGraphic(Picture1)
End Sub


Private Sub Command2_Click()
    'メモリDC削除
    Call ReleaseMeDC
End Sub


Private Sub Picture1_Paint()
    'AutoRedraw=Trueと同じ効果
    Call CopyGraphic(Picture1)
End Sub

このPaintイベントは、フォームの一部または全部、あるいはピクチャボックスが拡大されたり、 上に重なって表示されていたウィンドウがなくなったときに発生します。

Private Sub Form_Unload(Cancel As Integer)
    'メモリDC削除
    Call ReleaseMeDC
End Sub

　なお、この方法では描画領域が最初から隠れている 場合、その描画は反映されません。
　AutoRedraw=Trueの場合は、隠れていても問題なく描画され ます。
　この解決策として、まずメモリDCに描いてからそれをコピーするという方法 と同時に2つのDCに描く方法の2つがあります。

API Functionインデックス トップ

Copyright(C)1999 Tomoya. All rights reserved.