#はじめに
仕事でエクセルからフォームに写真やDocuWorksを表示する機会があり、3回位コピペしたときに「これクラスにしとけば後で楽できる」と思い、フォームサイズを可変にする機能をクラスモジュールに分離しました。
#使い方
1.標準モジュールやフォームのコード内でnewする
2.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