邪魔なグラフウィンドウ
前回作成したグラフウィンドウですが、移動したいと思っても移動できなくて邪魔くさいです。
それで移動できるように変更してみましょう。
移動はウィンドウ内をドラッグすることで移動することを考えてみます。
ドラッグでの移動はドラッグを開始したときのマウス座標に対してドラッグ中のマウス座標がどんな位置かを元のウィンドウ位置に足してあげれば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
スタイルの変更と簡易的な描画
前回、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では簡単に実現できないことをどーにか実現する為にサブクラス化というものを使用することがあります。
で、これを使用するにはWindowsのメッセージ処理ってのを分かっていなければならないのですが、ある時サブクラス化ではなくWindowsのメッセージ処理そのままにプログラムが書けるのではないかと思って書いてみたのがこのプログラムになります。
普通にUserFormを使うのに比べて実用性が有るとはとても言えないんですが、勉強がてら作ってみたというのと、ある特殊な場合には使えるかもしれません。
例えば、普通はフォームを表示させるとVBEからブックの画面になってしまいますが、この方法ではそういうことがありません。
Excelを最小化させてもフォームは表示されたままとなります。
※注意点としてこのフォームを閉じる場合は必ず×ボタンで閉じること。
VBE上で中断とかリセットとか、あるいは実行中にExcel自体を終了しようとするとExcelが異常終了します。
Option Explicit Public Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME Public Const WS_SYSMENU = &H80000 Public Const WS_VISIBLE = &H10000000 Public Const WS_MINIMIZEBOX = &H20000 Public Const WS_MAXIMIZEBOX = &H10000 Public Const WM_CLOSE = &H10 Public Type POINTAPI x As Long y 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 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _ (ByVal lpModuleName As String) 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 DestroyWindow Lib "USER32" _ (ByVal hWnd As LongPtr) As Long Public Declare PtrSafe Sub PostQuitMessage Lib "USER32" _ (ByVal nExitCode As Long) 'プログラム Sub Main() Dim hWnd As LongPtr Dim wndCls As WNDCLASSEX Dim dStyle As Long Dim tMsg As MSG On Error GoTo ErrHDL 'メインウィンドウの登録 With wndCls .cbSize = Len(wndCls) .lpszClassName = "myWin" .lpfnWndProc = FPtr(AddressOf WndProc) End With If RegisterClassEx(wndCls) = 0 Then Exit Sub End If 'ウィンドウスタイル dStyle = WS_CAPTION Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX dStyle = dStyle Or WS_VISIBLE 'メインウィンドウの作成 hWnd = CreateWindowEx(0, wndCls.lpszClassName, "TEST", _ dStyle, 0, 0, 600, 400, 0&, 0&, 0&, 0&) If hWnd = 0 Then GoTo ErrHDL End If 'メッセージループ 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 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 If uMsg = WM_CLOSE Then Call DestroyWindow(hWnd) Call PostQuitMessage(0) End If WndProc = DefWindowProc(hWnd, uMsg, wParam, lParam) End Function