Excel VBAでモダンなForm(枠無しForm)
個人で使っているWindows10に慣れると、どうも会社でのWindows7のAeroにレガシー感を感じてしまいます。
今日は、VBAでWin10風(メトロスタイル?フラットスタイル?)のFormを作ってみようと思います。
最後にダウンロードURLを貼りますので、読むのが面倒な人はスクロールしてください。
0.準備
まずは、モジュールの準備です。Excelを開いて、Alt+F11でエディタを開きます。VBAProjectを選択した状態で、右クリックから挿入→ユーザーフォームとクラスモジュールを追加。
名前をプロパティから、それぞれ「MainForm」「clsUserForm」に変更しておきます。
1.枠無しFormをつくる
WinAPIを宣言します。以下のコードをクラスモジュールに記載します。
clsUserForm
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As Long) As Long Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = (-16&) Const GWL_EXSTYLE = (-20&) Const WS_CAPTION = &HC00000 Const WS_EX_DLGMODALFRAME = &H1&
実際の仕事をするファンクションもクラスに書いておきましょう。
Function NonTitleBar(objName As String) As Long Dim wnd As Long, formHeight As Double Dim uForm As Object For Each uf In VBA.UserForms If uf.Name = objName Then Set uForm = uf: Exit For Next formHeight = uForm.InsideHeight WindowFromAccessibleObject uForm, wnd SetWindowLong wnd, GWL_EXSTYLE, GetWindowLong(wnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME NonTitleBar = SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE) And Not WS_CAPTION) DrawMenuBar wnd uForm.Height = uForm.Height - uForm.InsideHeight + formHeight End Function
NonTitleBarは失敗すると0を返してきます。
続いてForm側です。
閉じる用のボタンを配置して、名前を「btnClose」にしておきます。
ボタンをダブルクリックして、フォームを閉じる処理を書きます。
MainForm
Private Sub btnClose_Click() Unload Me End Sub
UserFormのInitialize処理をコンボボックスから追加します。
Initializeに先ほど作ったクラスを呼び出します。
Private clsForm As New clsUserForm1 Private Sub UserForm_Initialize() clsForm.NonTitleBar Me.Name End Sub
F5で実行すると、画面中央に枠無しフォームが表示されると思います。
2.ドラッグできるようにする
さらに、Formをドラッグで動かせるようにします。以下のコードをクラスに追加します。
clsUserForm
' 最上部に宣言 Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare PtrSafe Sub ReleaseCapture Lib "user32.dll" () Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Sub FormDrag(objName As String, ByVal Button As Integer) Dim hWnd As Long Dim uForm As Object For Each uf In VBA.UserForms If uf.Name = objName Then Set uForm = uf: Exit For Next If Button = 1 Then WindowFromAccessibleObject uForm, hWnd ReleaseCapture Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&) End If End Sub
Form側ではフォーム上でマウスダウンしたときに、FormDragを呼び出します。
MainForm
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) clsForm.FormDrag Me.Name, Button End Sub
F5で実行して・・・どうでしょう。Formを掴めましたでしょうか?
3.おわりに
今回は「まず見た目から入りたい!」という人向けに書きました。これを機にVBA&WinAPIを学んでみたいという方が増えてくれることを願います。
最後に、自分が作ったテンプレートフォームのダウンロード用のURLを貼っておきます。
https://github.com/rsinz/vba/releases
こんな感じです。