● デスクトップに落書きする ●
ReleaseDC の重要性を知った想い出深く懐かしのプログラム…

これをVBのお勉強のため悪戦苦闘しながら書いたのは1997年頃、しかもVBを始めて１ヶ月くらいの時期だったと思う。OS が Windows 95、ペンティアムが100Mhz、メモリーが16MB、VB のバージョンが 4.0 であった時代。書き始めの頃は ReleaseDC (の重要性)を知らなくてまったく記述していなかった。そのせいでよく OS が不安定になった。それだけでなく一度 OS が丸々ぶっ飛んでリカバリーしたこともある。OS がいかれてしまう原因はこのプログラムにあると思われたのだが、どこに原因があるのかまったくわからなかった。んで API の本を読み直したりしてあれこれと探りを入れた結果、ReleaseDC を記述していないことに気が付いた。そしてよく分からないまま ReleaseDC を記述して実行し、あれこれとデバッグをする。いつもならいきなり異常終了したりしていたのだが、それがまったく無くなったのである。心からの感動した春のひとときであった。

この一件で Get したら Release(他に挙げると Create したら Destroy、Open したら Close)しないといけない、ということを身をもって痛感し、現在に至っています。

'デスクトップのウインドウハンドルを取得する
Declare Function GetDesktopWindow Lib "user32" () As Long

'デバイスコンテキストを取得する
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

'言わずと知れたビットブリット
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

'デバイスコンテキストを開放する
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

'ウィンドウの状態(位置、サイズ、前か後ろかなど)を設定する
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Const SRCCOPY = &HCC0020
Public Const HWND_TOPMOST = -1
Public Const SWP_NOREDRAW = &H8

1.フォーム(Form1)の BorderStyleプロパティに「0 - なし」を設定する。

2.フォーム(Form1)の Load イベントに次のコードを書く。

   
Private Sub Form_Load()

    Dim hDCdesktop As Long, hWndDesktop As Long
    Dim nWidth As Integer, nHeight As Integer

    'Form1のプロパティの設定
    With Me
      .Top = 0
      .Left = 0
      .Width = Screen.Width
      .Height = Screen.Height
      .AutoRedraw = True
      .WindowState = vbMinimized
    End With

    'デスクトップのウインドウハンドルを取得する
    hWndDesktop = GetDesktopWindow()

    'デスクトップのデバイスコンテキストを取得する
    hDCdesktop = GetDC(hWndDesktop)

    'BitBltのnWidth、nHeightはピクセルでなければいけないので
    'TwipからPixelに変換してやらねばならない
    nWidth = ScaleX(Screen.Width, vbTwips, vbPixels)
    nHeight = ScaleY(Screen.Height, vbTwips, vbPixels)

    Call BitBlt(Me.hdc, 0, 0, nWidth, nHeight, hDCdesktop, 0, 0, SRCCOPY)
    'デバイスコンテキストの開放する。こうしないと、パソコンの環境
    'にもよるが、ハングアップすることがある。結構、重要！
    Call ReleaseDC(0, hDCdesktop)

    Me.WindowState = vbNormal
    Me.Show

    'フォームを常に手前に表示させる
    Call SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, nWidth, nHeight, SWP_NOREDRAW)

End Sub
3.フォーム(Form1)の"MouseDown"イベントに次のコードを書く

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

    'マウスの左ボタンをクリックしたら
    If Button = vbLeftButton Then
        Me.CurrentX = X  '現在のX座標の設定
        Me.CurrentY = Y  '現在のY座標の設定
    End If

End Sub
4.フォーム(Form1)の"MouseMove"イベントに次のコードを書く

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

    'マウスの左ボタンをクリックしている状態であれば
    If Button = vbLeftButton Then
        'CurrentX、Yの位置からX、Yまで線を表示する
        Line -(X, Y) 
    End If

End Sub

5.実行を終了させるコードを書く。これは別になんでもいい。

   
Private Sub Form_DblClick()

    'ダブルクリックしたら終了
    Unload Me

End Sub

  又は、

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    '何かキーが押されたら終了
    Unload Me

End Sub

戻る