微妙技術者の実験

VBAを中心にした忘備録

邪魔なグラフウィンドウ

前回作成したグラフウィンドウですが、移動したいと思っても移動できなくて邪魔くさいです。
それで移動できるように変更してみましょう。
移動はウィンドウ内をドラッグすることで移動することを考えてみます。
ドラッグでの移動はドラッグを開始したときのマウス座標に対してドラッグ中のマウス座標がどんな位置かを元のウィンドウ位置に足してあげればOKです。
ドラッグ中の判定はマウスで押したらドラッグ中になり、離したらドラッグ解除にすればいい。

    Case WM_MOUSEMOVE
        If blMouseDown Then
            ptMv.x = LWORD(Clng(lParam))
            ptMv.y = HWORD(Clng(lParam))
            lngRet = ClientToScreen(hwnd, ptMv)
            lngRet = SetWindowPos(hwnd, HWND_TOPMOST, ptMv.x - ptStart.x, ptMv.y - ptStart.y, 0, 0, SWP_NOSIZE)
        End If
    Case WM_LBUTTONDOWN
        blMouseDown = True
        ptStart.x = LWORD(Clng(lParam))
        ptStart.y = HWORD(Clng(lParam))
    Case WM_LBUTTONUP
        blMouseDown = False

これでドラッグにより移動できるようになるのですが、移動できるようになると描画の問題点も発覚します。
というのはドラッグして画面外に出た部分の描画が消えてしまうのですね。
Windowsではこのような場合、都度再描画してやらなければなりません。
とはいってもどういう時に再描画する必要があるのかですが、Windowsでは再描画する必要がある場合はシステムがWM_PAINTメッセージを投げてくることになっています。
そのタイミングで毎回描画しても良いのですが、毎回同じものを描画するのもスマートじゃないですね。
実はこういう場合の常套手段がありまして、描画はメモリに作成したデバイスコンテキストに一回だけ描画して、後は再描画の度にそれをウィンドウに転送すれば良いのです。
まず、メモリにウィンドウと互換のデバイスコンテキストを作成するプロシージャを作成します。

Private Function GetMemDC(hWnd As LongPtr, lngWidth As Long, lngHeight As Long) As LongPtr

    Dim hDc As LongPtr
    Dim memDC As LongPtr
    Dim memBMP As LongPtr

    hDc = GetDC(hWnd)
    memDC = CreateCompatibleDC(hDc)
    memBMP = CreateCompatibleBitmap(hDc, lngWidth, lngHeight)
    Call ReleaseDC(hWnd, hDc)
    
    Call SelectObject(memDC, memBMP)

    GetMemDC = memDC
End Function

次にウィンドウ作成後、ウィンドウのデバイスコンテキストに描画する代わりに
メモリのデバイスコンテキストに描画します。

    'ウィンドウに描画
'    hDc = GetDC(hWnd)
'    Call DrawGraph(hDc, "", 500, 500, 50, 50, varRng, 200)
'    Call UpdateWindow(hWnd)
    
    'メモリに作成したデバイスコンテキストに描画するように変更
    hMemDC = GetMemDC(hWnd, 600, 600)
    Call DrawGraph(hMemDC, "", 500, 500, 50, 50, varRng, 200)

最後にWM_PAINTメッセージの度にhMemDCからhDCに転送するだけです。

    '再描画毎にメモリDCから転送
    Case WM_PAINT
        hDc = BeginPaint(hWnd, tPaint)
        lngRet = BitBlt(hDc, 0, 0, tPaint.rcPaint.Right, tPaint.rcPaint.Bottom, hMemDC, 0, 0, SRCCOPY)
        Call EndPaint(hWnd, tPaint)

最後に全体のソースを示します。

Option Explicit

Public Const WS_VISIBLE = &H10000000
Public Const WS_POPUP = &H80000000
Public Const WS_DLGFRAME = &H400000
Public Const WM_CLOSE = &H10
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_MOUSEMOVE = &H200
Public Const WM_PAINT = &HF
Public Const CS_DBLCLKS = &H8
Public Const HWND_TOP = 0
Public Const SWP_NOSIZE = &H1

Public Const SRCCOPY = &HCC0020 '(DWORD) dest = source

'背景用
Public Const WHITE_BRUSH = 0
Public Const BLACK_BRUSH = 4
Public Const PS_SOLID = 0

Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Type LOGPEN
        lopnStyle As Long
        lopnWidth As POINTAPI
        lopnColor As Long
End Type
Public Type MSG
    hWnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type
Public Type WNDCLASSEX
    cbSize As Long
    style As Long
    lpfnWndProc As LongPtr
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As LongPtr
    hIcon As LongPtr
    hCursor As LongPtr
    hbrBackground As LongPtr
    lpszMenuName As String
    lpszClassName As String
    hIconSm As LongPtr
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type PAINTSTRUCT
    hDc As LongPtr
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type

Public Declare PtrSafe Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" _
    (ByVal dwExStyle As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String, _
    ByVal dwStyle As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hWndParent As LongPtr, _
    ByVal hMenu As LongPtr, _
    ByVal hInstance As LongPtr, _
    lpParam As Any) As LongPtr

Public Declare PtrSafe Function RegisterClassEx Lib "USER32" Alias "RegisterClassExA" _
    (pcWndClassEx As WNDCLASSEX) As Integer
Public Declare PtrSafe Function UnregisterClass Lib "USER32" Alias "UnregisterClassA" _
    (ByVal lpClassName As String, _
    ByVal hInstance As LongPtr) As Long
Public Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
    (ByVal lpModuleName As String) As LongPtr
Public Declare PtrSafe Function UpdateWindow Lib "USER32" _
    (ByVal hWnd As LongPtr) As Long
Public Declare PtrSafe Function DestroyWindow Lib "USER32" _
    (ByVal hWnd As LongPtr) As Long
Public Declare PtrSafe Sub PostQuitMessage Lib "USER32" _
    (ByVal nExitCode As Long)
Public Declare PtrSafe Function DefWindowProc Lib "USER32" Alias "DefWindowProcA" _
    (ByVal hWnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr

'メッセージループ
Public Declare PtrSafe Function GetMessage Lib "USER32" Alias "GetMessageA" _
    (lpMsg As MSG, _
    ByVal hWnd As LongPtr, _
    ByVal wMsgFilterMin As Long, _
    ByVal wMsgFilterMax As Long) As Long
Public Declare PtrSafe Function TranslateMessage Lib "USER32" _
    (lpMsg As MSG) As Long
Public Declare PtrSafe Function DispatchMessage Lib "USER32" Alias "DispatchMessageA" _
    (lpMsg As MSG) As LongPtr

Public Declare PtrSafe Function SendMessageW Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr

Public Declare PtrSafe Function SetWindowPos Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    ByVal hWndInsertAfter As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long) As Long

Public Declare PtrSafe Function ClientToScreen Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    lpPoint As POINTAPI) As Long


'描画関連
Public Declare PtrSafe Function GetDC Lib "USER32" _
    (ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function ReleaseDC Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    ByVal hDc As LongPtr) As Long
Public Declare PtrSafe Function DeleteDC Lib "gdi32" _
    (ByVal hDc As LongPtr) As Long
Public Declare PtrSafe Function SelectObject Lib "gdi32" _
    (ByVal hDc As LongPtr, _
    ByVal hObject As LongPtr) As LongPtr
Public Declare PtrSafe Function DeleteObject Lib "gdi32" _
    (ByVal hObject As LongPtr) As Long
Public Declare PtrSafe Function GetStockObject Lib "gdi32" _
    (ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function CreatePenIndirect Lib "gdi32" _
    (lpLogPen As LOGPEN) As LongPtr
Public Declare PtrSafe Function CreateSolidBrush Lib "gdi32" _
    (ByVal crColor As Long) As LongPtr
'Public Declare PtrSafe Function MoveToEx Lib "gdi32" _
'    (ByVal hdc As LongPtr, _
'    ByVal x As Long, _
'    ByVal y As Long, _
'    lpPoint As POINTAPI) As Long
Public Declare PtrSafe Function MoveToEx Lib "gdi32" _
    (ByVal hDc As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    lpPoint As LongPtr) As Long

Public Declare PtrSafe Function LineTo Lib "gdi32" _
    (ByVal hDc As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long) As Long
Public Declare PtrSafe Function Ellipse Lib "gdi32" _
    (ByVal hDc As LongPtr, _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long) As Long
Public Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hDc As LongPtr) As LongPtr
Public Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" _
    (ByVal hDc As LongPtr, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long) As LongPtr
Public Declare PtrSafe Function BeginPaint Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    lpPaint As PAINTSTRUCT) As LongPtr
Public Declare PtrSafe Function EndPaint Lib "USER32" _
    (ByVal hWnd As LongPtr, _
    lpPaint As PAINTSTRUCT) As Long
Public Declare PtrSafe Function BitBlt Lib "gdi32" _
    (ByVal hDestDC As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As LongPtr, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long

'ユーザー変数
Public blMouseDown As Boolean   'ドラッグ中判定フラグ
Public ptStart As POINTAPI      '移動開始時のマウスポインタの座標
Public hMemDC As LongPtr           'メモリDC
Sub Auto_Open()

    Dim cb As CommandBar

    For Each cb In Application.CommandBars
        If cb.Name = "SampleGraph" Then
            cb.Delete
        End If
    Next

    Set cb = Application.CommandBars.Add("SampleGraph", msoBarTop, , True)
    With cb.Controls.Add(msoControlButton)
        .style = msoButtonCaption
        .Caption = "グラフ描画"
        .OnAction = "DrawMain"
    End With
    cb.Visible = True

End Sub
Private Sub DrawMain()

    Dim hWnd As LongPtr
    Dim hDc As LongPtr
    Dim wndCls As WNDCLASSEX
    Dim dStyle As Long
    Dim dStyleEx As Long
    Dim tMsg As MSG
    Dim lngRet As Long
    Dim varRng As Variant

    On Error GoTo ErrHDL

    'Excelシートからデータ取得
    varRng = Selection
    
    '1次元配列以下の場合を排除（2次元の最大取得で判定）
    On Error Resume Next
    lngRet = UBound(varRng, 2)
    If Err.Number <> 0 Then
        Exit Sub
    End If
    On Error GoTo ErrHDL

    'メインウィンドウの登録
    With wndCls
        .cbSize = Len(wndCls)
        .lpszClassName = "myWin"
        .lpfnWndProc = FPtr(AddressOf WndProc)
        .hbrBackground = GetStockObject(BLACK_BRUSH)
        .style = CS_DBLCLKS
    End With
    If RegisterClassEx(wndCls) = 0 Then
        Call UnregisterClass(wndCls.lpszClassName, wndCls.hInstance)
        Exit Sub
    End If

    'ウィンドウスタイル
    dStyle = dStyle Or WS_VISIBLE
    dStyle = dStyle Or WS_DLGFRAME
    dStyle = dStyle Or WS_POPUP

    hWnd = CreateWindowEx(0, wndCls.lpszClassName, "TEST", _
        dStyle, 0, 0, 600, 600, 0&, 0&, 0&, 0&)
    If hWnd = 0 Then
        GoTo ErrHDL
    End If

    'ウィンドウに描画(画面外に出ると描画が消える）
'    hDc = GetDC(hWnd)
'    Call DrawGraph(hDc, "", 500, 500, 50, 50, varRng, 200)
'    Call UpdateWindow(hWnd)

    'メモリに作成したデバイスコンテキストに描画するように変更(画面外でも描画は消えない)
    hMemDC = GetMemDC(hWnd, 600, 600)
    Call DrawGraph(hMemDC, "", 500, 500, 50, 50, varRng, 500)

    'メッセージループ
    Do While (GetMessage(tMsg, 0, 0, 0))
        Call TranslateMessage(tMsg)
        Call DispatchMessage(tMsg)
    Loop

    '終了
    'ReleaseDC hWnd, hDC        'GetDCで取得したDCの解放
    DeleteDC hMemDC             'CreateCompatibleDCで作成したDCの削除
    Call UnregisterClass(wndCls.lpszClassName, wndCls.hInstance)
    Exit Sub

ErrHDL:

    Call SendMessageW(hWnd, WM_CLOSE, 0, 0)
    Call UnregisterClass(wndCls.lpszClassName, wndCls.hInstance)

End Sub
'グラフ描画処理（arryDataは2次元以上であること!!）
'varBaseはX軸に対してのY軸の割合（%）
Private Sub DrawGraph(hDc As LongPtr, _
    strCategory As String, _
    lngWidth As Long, _
    lngHeight As Long, _
    lngAxisX As Long, _
    lngAxisY As Long, _
    arryData As Variant, _
    Optional varBase As Variant = 1)

    Dim Ret As Long
    Dim tLogPen As LOGPEN
    Dim newPen As LongPtr
    Dim orgPen As LongPtr
    Dim newBrush As LongPtr
    Dim orgBrush As LongPtr
    Dim i As Long
    Dim j As Long

    '0除算の回避
    If varBase = 0 Then
        varBase = 1
    End If

    'グラフのXY軸
    tLogPen.lopnStyle = PS_SOLID
    tLogPen.lopnColor = vbGreen
    tLogPen.lopnWidth.x = 2     '太さ
    newPen = CreatePenIndirect(tLogPen)
    orgPen = SelectObject(hDc, newPen)
    'X軸の目盛
    For i = LBound(arryData, 1) To UBound(arryData, 1)
        Call MoveToEx(hDc, i / UBound(arryData, 1) * lngWidth + lngAxisX, lngHeight - 3 + lngAxisY, 0)
        Call LineTo(hDc, i / UBound(arryData, 1) * lngWidth + lngAxisX, lngHeight + lngAxisY)
    Next i
    Call MoveToEx(hDc, lngAxisX, lngAxisY, 0)
    Call LineTo(hDc, lngAxisX, lngHeight + lngAxisY)
    Call LineTo(hDc, lngWidth + lngAxisX, lngHeight + lngAxisY)

    'グラフ
    tLogPen.lopnColor = vbRed
    tLogPen.lopnWidth.x = 1
    tLogPen.lopnStyle = PS_SOLID
    newPen = CreatePenIndirect(tLogPen)
    Call SelectObject(hDc, newPen)

    'ブラシ（ポイント○の塗りつぶし用）
    newBrush = CreateSolidBrush(RGB(255, 0, 0))
    orgBrush = SelectObject(hDc, newBrush)


    'グラフ描画
    For j = LBound(arryData, 2) To UBound(arryData, 2)
        Call MoveToEx(hDc, 0 + lngAxisX, lngHeight + lngAxisY, 0)
        For i = LBound(arryData, 1) To UBound(arryData, 1)
            If Not IsNumeric(arryData(i, j)) Then
                arryData(i, j) = 0
            End If
            Call LineTo(hDc, (i / UBound(arryData, 1)) * lngWidth + lngAxisX, lngHeight - arryData(i, j) / varBase * lngHeight + lngAxisY)
            Ret = DrawPointCircle(hDc, (i / UBound(arryData, 1)) * lngWidth + lngAxisX, lngHeight - arryData(i, j) / varBase * lngHeight + lngAxisY, 3)
        Next i
    Next j

    Call SelectObject(hDc, orgBrush)
    Call DeleteObject(newBrush)

    Call SelectObject(hDc, orgPen)
    Call DeleteObject(newPen)

End Sub
'点の描画（塗りつぶし円を点に見立てる）
Private Function DrawPointCircle(hDc As LongPtr, x As Long, y As Long, nSize As Long) As Long
    Dim Ret As Long
    Ret = Ellipse(hDc, x - nSize, y - nSize, x + nSize, y + nSize)
    DrawPointCircle = Ret

End Function
Private Function FPtr(ByVal p As LongPtr) As LongPtr
    FPtr = p
End Function
Public Function WndProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

    Dim ptMv As POINTAPI
    Dim lngRet As Long
    Dim tPaint As PAINTSTRUCT
    Dim hDc As LongPtr

    Select Case uMsg
    '再描画毎にメモリDCから転送
    Case WM_PAINT
        hDc = BeginPaint(hWnd, tPaint)
        lngRet = BitBlt(hDc, 0, 0, tPaint.rcPaint.Right, tPaint.rcPaint.Bottom, hMemDC, 0, 0, SRCCOPY)
        Call EndPaint(hWnd, tPaint)
    Case WM_CLOSE
        Call DestroyWindow(hWnd)
        Call PostQuitMessage(0)
    Case WM_LBUTTONDBLCLK
        Call SendMessageW(hWnd, WM_CLOSE, 0, 0)
    Case WM_MOUSEMOVE
        If blMouseDown Then                 'ドラッグ中
            ptMv.x = LWORD(CLng(lParam))
            ptMv.y = HWORD(CLng(lParam))
            lngRet = ClientToScreen(hWnd, ptMv)
            lngRet = SetWindowPos(hWnd, HWND_TOP, ptMv.x - ptStart.x, ptMv.y - ptStart.y, 0, 0, SWP_NOSIZE)
        End If
    Case WM_LBUTTONDOWN
        blMouseDown = True                  'ドラッグ開始
        ptStart.x = LWORD(CLng(lParam))
        ptStart.y = HWORD(CLng(lParam))
    Case WM_LBUTTONUP
        blMouseDown = False                 'ドラッグ終了
'    Case WM_KILLFOCUS
'        Call DestroyWindow(hwnd)
'        Call PostQuitMessage(0)
    End Select

    WndProc = DefWindowProc(hWnd, uMsg, wParam, lParam)

End Function

Private Function HWORD(ByVal LongValue As Long) As Integer
    '長整数値から上位ワードを取得する
    HWORD = (LongValue And &HFFFF0000) \ &H10000

End Function
Private Function LWORD(ByVal LongValue As Long) As Integer

    '長整数値から下位ワードを取得する
    If (LongValue And &HFFFF&) > &H7FFF Then
        LWORD = (LongValue And &HFFFF&) - &H10000
    Else
        LWORD = LongValue And &HFFFF&
    End If

End Function
Private Function GetMemDC(hWnd As LongPtr, lngWidth As Long, lngHeight As Long) As LongPtr

    Dim hDc As LongPtr
    Dim memDC As LongPtr
    Dim memBMP As LongPtr

    hDc = GetDC(hWnd)
    memDC = CreateCompatibleDC(hDc)
    memBMP = CreateCompatibleBitmap(hDc, lngWidth, lngHeight)

    Call SelectObject(memDC, memBMP)

    GetMemDC = memDC
End Function