ユーザーフォームの最大化・最小化・サイズ可変を設定するクラス

はじめに

仕事でエクセルからフォームに写真やDocuWorksを表示する機会があり、３回位コピペしたときに「これクラスにしとけば後で楽できる」と思い、フォームサイズを可変にする機能をクラスモジュールに分離しました。

使い方

１.標準モジュールやフォームのコード内でnewする
２.Formプロパティにフォームをセットする
　※デフォルトでは全て有効になっています。
　※フォームのCaptionを変更した場合、ボタンのない状態に戻るので、Redrawメソッドで再描画します。　
上記のほか、任意のタイミングで最大化・最小化ボタン、サイズ可変の有効/無効が変更できます。

ユーザーフォームで使う場合

Withブロックは省略してもOK。デフォルトで最大化・最小化ボタンとサイズ可変が有効になります。

UserForm1

Option Explicit

Private rfc As ResizableFormClass

Private Sub UserForm_Initialize()
Set rfc = New ResizableFormClass
Set rfc.Form = Me
'設定を変更した場合はRedrawする
With rfc
    .Maximize = True  'Default = True
    .Minimize = True  'Default = True
    .Resize = True    'Default = True
    .Redraw           '再描画
End With
End Sub

Private Sub UserForm_Terminate()
Set rfc = Nothing
End Sub

標準モジュールで使う場合

一応、標準モジュールからの後付でもボタン設置は可能ですが、フォームの方でリサイズイベントの対応しないとコントロールが動きません。同じくWithブロックは省略可。

Module1

Option Explicit

Sub ResizableFormShow()
Dim UF  As UserForm1
Dim rfc As ResizableFormClass

Set UF = New UserForm1
Set rfc = New ResizableFormClass

Set rfc.Form = UF

'設定を変更した場合はRedrawする
With rfc
    .Maximize = True  'Default = True
    .Minimize = True  'Default = True
    .Resize = True    'Default = True
    .Redraw           '再描画
End With
UF.Show

'フォームのCaptionを変更した場合、もとに戻るので再描画する
UF.Caption = "myForm"
rfc.Redraw
End Sub

コード

ResizableFormClass.cls

Option Explicit

'Windows API宣言
Private Declare Function FindWindow _
    Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong _
    Lib "user32" Alias "GetWindowLongA" ( _
        ByVal hwnd As Long, _
        ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong _
    Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hwnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long

Private Declare Function DrawMenuBar _
    Lib "user32" ( _
        ByVal hwnd As Long) As Long

'Windows API定数
Private Const GWL_STYLE      As Long = (-16)
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_THICKFRAME  As Long = &H40000

'参照用変数
Private TargetForm As MSForms.UserForm
Private bMinimize  As Boolean
Private bMaximize  As Boolean
Private bResize    As Boolean

'最小化ボタンの有効/無効
Public Property Get Minimize() As Boolean
Minimize = bMinimize
End Property

Public Property Let Minimize(ByVal flag As Boolean)
bMinimize = flag
End Property

'最大化ボタンの有効/無効
Public Property Get Maximize() As Boolean
Maximize = bMaximize
End Property

Public Property Let Maximize(ByVal flag As Boolean)
bMaximize = flag
End Property

'リサイズの有効/無効
Public Property Get Resize() As Boolean
Resize = bResize
End Property

Public Property Let Resize(ByVal flag As Boolean)
bResize = flag
End Property

'対象フォーム設定
Public Property Set Form(ByRef mform As MSForms.UserForm)
Set TargetForm = mform
Call Redraw
End Property

Public Property Get Form() As MSForms.UserForm
Set Form = TargetForm
End Property

'初期値設定
Private Sub Class_Initialize()
bMinimize = True
bMaximize = True
bResize = True
End Sub

'フォーム再描写　※Captionを変更した場合、ボタンが消えるのでRedrawする
Public Sub Redraw()
Dim lHwnd  As Long
Dim lStyle As Long

If TargetForm Is Nothing Then Exit Sub

lHwnd = FindWindow("ThunderDFrame", TargetForm.Caption)
lStyle = GetWindowLong(lHwnd, GWL_STYLE)

If Minimize Then
    lStyle = lStyle Or WS_MINIMIZEBOX
End If

If Maximize Then
    lStyle = lStyle Or WS_MAXIMIZEBOX
End If

If Resize Then
    lStyle = lStyle Or WS_THICKFRAME
End If

Call SetWindowLong(lHwnd, GWL_STYLE, lStyle)
Call DrawMenuBar(lHwnd)
End Sub