スタイルの変更と簡易的な描画

前回、CreateWindowExを使って標準モジュールでフォームを作成する例が作成できました。
でもわざわざ面倒な方法で普通のフォームを作っても面白くないですね。
そこでタイトルの無いウィンドウにして何かを描画してみましょう。

タイトルの無いウィンドウにするにはウィンドウスタイルを変更します。

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

このままだとタイトルバーの閉じるボタンが無くなってしまうので、閉じる手段が無くなってしまいます。
そこで取り敢えずウィンドウ内をダブルクリックしたら閉じるように変更します。
1つ目の変更点はウィンドウクラスで、ダブルクリックを受け付けるように変更します。
ついでにこの後、描画もするので背景色を黒にしておきます。

    'メインウィンドウ
    With wndCls
        .cbSize = Len(wndCls)
        .lpszClassName = "myWin"
        .lpfnWndProc = FPtr(AddressOf WndProc)
        .hbrBackground = GetStockObject(BLACK_BRUSH)
        .style = CS_DBLCLKS
    End With

続いて、ウィンドウプロシージャでダブルクリックに対応

    Case WM_LBUTTONDBLCLK
        Call SendMessageW(hWnd, WM_CLOSE, 0, 0)

それでは何か簡易的に描画してみます。
描画は線の色とか、塗りつぶしの設定とかをデバイスコンテキストに選択し、
描画命令で描画する流れになります。
今回はシート上の選択範囲を元に簡易的なグラフを描画します。
1．描画する線をLOGPEN構造体に設定

    tLogPen.lopnStyle = PS_SOLID           '線種
    tLogPen.lopnColor = vbGreen            '色
    tLogPen.lopnWidth.x = 2                '太さ
    newPen = CreatePenIndirect(tLogPen)
    orgPen = SelectObject(hDC, newPen)

2．直線の描画

    Call MoveToEx(hDC, lngAxisX, lngAxisY, 0)
    Call LineTo(hDC, lngAxisX, lngHeight + lngAxisY)
    Call LineTo(hDC, lngWidth + lngAxisX, lngHeight + lngAxisY)

3．塗りつぶしの設定

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

4．点（円）の描画

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

プログラム全体は下記の通り。
しかし、こいつは隠そうとしているけど描画に関して問題点が。
次回はその問題点と、このウィンドウが邪魔と感じる場合の対応について修正します。

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 CS_DBLCLKS = &H8

'背景用
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 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 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 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 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
'アドインリボンに選択範囲を元にグラフ描画するボタンを追加
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 ReleaseDC(hWnd, hDc)
    
    'メッセージループ
    Do While (GetMessage(tMsg, 0, 0, 0))
        Call TranslateMessage(tMsg)
        Call DispatchMessage(tMsg)
    Loop

    '終了
    Call UnregisterClass(wndCls.lpszClassName, wndCls.hInstance)
    Exit Sub

ErrHDL:

    Call SendMessageW(hWnd, WM_CLOSE, 0, 0)
    Call UnregisterClass(wndCls.lpszClassName, wndCls.hInstance)
    
End Sub
'グラフ描画
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

    Select Case uMsg
    Case WM_CLOSE
        Call DestroyWindow(hWnd)
        Call PostQuitMessage(0)
    Case WM_LBUTTONDBLCLK
        Call SendMessageW(hWnd, WM_CLOSE, 0, 0)
    End Select
    
    WndProc = DefWindowProc(hWnd, uMsg, wParam, lParam)

End Function

微妙技術者の実験

VBAを中心にした忘備録

スタイルの変更と簡易的な描画