HOME > エクセルVBA > サンプル > SetWindowPos

SetWindowPos


【ファイル名】SetWindowPos.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年04月24日
【更新日】2021年04月25日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】SetWindowPos.zip
【説明】Excel のウィンドウを常に前面に表示します。(Windows APIのSetWindowPos)
Excel のウィンドウを常に前面に表示します。
このブックを閉じると元に戻ります。
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h > SetWindowPos function
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h > GetSystemMetrics function

WindowsAPIModule
Option Explicit

' SetWindowPos Flags
Const SWP_NOSIZE = &H1 ' サイズの引数は使用しない
Const SWP_NOMOVE = &H2 ' 移動の引数は使用しない
Const SWP_NOZORDER = &H4
Const SWP_NOREDRAW = &H8
Const SWP_NOACTIVATE = &H10
Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE
Const SWP_SHOWWINDOW = &H40
Const SWP_HIDEWINDOW = &H80
Const SWP_NOCOPYBITS = &H100
Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering

Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Const SWP_NOREPOSITION = SWP_NOOWNERZORDER

' SetWindowPos() hwndInsertAfter values
Const HWND_TOP = 0
Const HWND_BOTTOM = 1
Const HWND_TOPMOST = -1 ' ウィンドウを常に手前に表示する
Const HWND_NOTOPMOST = -2 ' ウィンドウの常に手前に表示を解除する

' GetSystemMetrics() codes
Const SM_CXSCREEN = 0 ' スクリーンの幅
Const SM_CYSCREEN = 1 ' スクリーンの高さ
Const SM_CXVSCROLL = 2
Const SM_CYHSCROLL = 3
Const SM_CYCAPTION = 4
Const SM_CXBORDER = 5
Const SM_CYBORDER = 6
Const SM_CXDLGFRAME = 7
Const SM_CYDLGFRAME = 8
Const SM_CYVTHUMB = 9
Const SM_CXHTHUMB = 10
Const SM_CXICON = 11
Const SM_CYICON = 12
Const SM_CXCURSOR = 13
Const SM_CYCURSOR = 14
Const SM_CYMENU = 15
Const SM_CXFULLSCREEN = 16
Const SM_CYFULLSCREEN = 17
Const SM_CYKANJIWINDOW = 18
Const SM_MOUSEPRESENT = 19
Const SM_CYVSCROLL = 20
Const SM_CXHSCROLL = 21
Const SM_DEBUG = 22
Const SM_SWAPBUTTON = 23
Const SM_RESERVED1 = 24
Const SM_RESERVED2 = 25
Const SM_RESERVED3 = 26
Const SM_RESERVED4 = 27
Const SM_CXMIN = 28
Const SM_CYMIN = 29
Const SM_CXSIZE = 30
Const SM_CYSIZE = 31
Const SM_CXFRAME = 32
Const SM_CYFRAME = 33
Const SM_CXMINTRACK = 34
Const SM_CYMINTRACK = 35
Const SM_CXDOUBLECLK = 36
Const SM_CYDOUBLECLK = 37
Const SM_CXICONSPACING = 38
Const SM_CYICONSPACING = 39
Const SM_MENUDROPALIGNMENT = 40
Const SM_PENWINDOWS = 41
Const SM_DBCSENABLED = 42
Const SM_CMOUSEBUTTONS = 43
Const SM_CMETRICS = 44
Const SM_CXSIZEFRAME = SM_CXFRAME
Const SM_CYSIZEFRAME = SM_CYFRAME
Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Const SM_CYFIXEDFRAME = SM_CYDLGFRAME

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setwindowpos
  Private 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
                                                      
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getsystemMetrics
  Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
  Private 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
                  
  Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

' ウィンドウを常に手前に表示する
Public Function setExcelWindowTopMost() As Long ' 戻り値は、0ならエラー
  setExcelWindowTopMost = SetWindowPos(Application.hwnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, SWP_NOSIZE Or SWP_NOMOVE)
End Function

' ウィンドウの常に手前に表示を解除する
Public Function setExcelWindowNoTopMost() As Long ' 戻り値は、0ならエラー
  setExcelWindowNoTopMost = SetWindowPos(Application.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_NOSIZE Or SWP_NOMOVE)
End Function

' ウィンドウを左上に移動する
Public Sub MoveLeftTopWindow()
  SetWindowPos Application.hwnd, 0&, 0&, 0&, 0&, 0&, SWP_NOSIZE
End Sub

' ウィンドウのサイズを変更(600,480)して、デスクトップの中央に移動する
Public Sub MoveCenterWindow()
  Dim x As Long ' ウィンドウの左の位置
  Dim y As Long ' ウィンドウの上の位置
  Dim cx As Long ' ウィンドウの幅
  Dim cy As Long ' ウィンドウの高さ
  Dim CXScreen As Long ' スクリーンの幅
  Dim CYScreen As Long ' スクリーンの高さ
  
  CXScreen = GetSystemMetrics(SM_CXSCREEN)
  CYScreen = GetSystemMetrics(SM_CYSCREEN)
  cx = 600
  cy = 480
  x = (CXScreen - cx) \ 2
  y = (CYScreen - cy) \ 2
  SetWindowPos Application.hwnd, 0&, x, y, cx, cy, 0&
End Sub
このページの上

ThisWorkbook
Option Explicit

Private Sub Workbook_Open()
  Call WindowsAPIModule.setExcelWindowTopMost
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Call WindowsAPIModule.setExcelWindowNoTopMost
End Sub
このページの上