VBAによるサイズ変更可能なユーザーフォーム
たまにはマクロネタを書かないと、「なんだこの人、Excelと全然関係ないことしか書かないじゃない」と言われてしまうので、マクロに関係する内容を書きます。
基本的にVBAのユーザーフォームはマウスによる表示後のサイズ変更ができません。これはAPIを使えばすぐに実現できるのですが、ここではあえてVBAだけの機能を使ってサイズ変更が可能なユーザーフォームの作成方法について解説してみます。
まず、図のように3つのイメージコントロールを配置し、名前を変更します。
場所は適当に配しておけば、VBAで位置を設定するのでこのままでOKです。
次に以下のコードを作成します。以上ですが、サンプルファイルを作成しましたので、ダウンロードして動作の確認をしてみて下さい。
Option Explicit
Option Base 1
'定数
Private Const MODE_RESIZE_X = 0
Private Const MODE_RESIZE_Y = 1
Private Const MODE_RESIZE_XY = 2
'変数
Private flgResize As Boolean
Private ResizeX As Single
Private ResizeY As Single
'*** リサイズ用コントロールの再配置 ***
Private Sub SetResizeControls()
With imgResizeXY
.Left = Me.InsideWidth - .Width
.Top = Me.InsideHeight - .Height
.ZOrder 0
End With
With imgResizeY
.Left = 0
.Top = imgResizeXY.Top
.Width = imgResizeXY.Left
.ZOrder 0
End With
With imgResizeX
.Top = 0
.Left = imgResizeXY.Left
.Height = imgResizeXY.Top
.ZOrder 0
End With
End Sub
'*** リサイズ用コントロール上でマウスをクリック ****
Private Sub Resize_MouseDown(X As Single, Y As Single, Button As Integer)
If Button = 1 Then
flgResize = True
ResizeX = X
ResizeY = Y
End If
End Sub
'*** リサイズ用コントロール上でマウスをドラッグ ***
Private Sub Resize_MouseMove(X As Single, Y As Single, Mode As Byte)
If flgResize Then
If Mode = MODE_RESIZE_X Or Mode = MODE_RESIZE_XY Then
Me.Width = Me.Width + X - ResizeX
ResizeX = X
End If
If Mode = MODE_RESIZE_Y Or Mode = MODE_RESIZE_XY Then
Me.Height = Me.Height + Y - ResizeY
ResizeY = Y
End If
End If
End Sub
'*** リサイズ用コントロール上でマウスを離す ***
Private Sub Resize_MouseUp(Button As Integer)
If Button = 1 Then
flgResize = False
Call SetResizeControls
End If
End Sub
'*** 縦のリサイズ ***
Private Sub imgResizeY_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseDown(X, Y, Button)
End Sub
Private Sub imgResizeY_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseMove(X, Y, MODE_RESIZE_Y)
End Sub
Private Sub imgResizeY_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseUp(Button)
End Sub
'*** 横のリサイズ ***
Private Sub imgResizeX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseDown(X, Y, Button)
End Sub
Private Sub imgResizeX_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseMove(X, Y, MODE_RESIZE_X)
End Sub
Private Sub imgResizeX_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseUp(Button)
End Sub
'*** 縦横のリサイズ ***
Private Sub imgResizeXY_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseDown(X, Y, Button)
End Sub
Private Sub imgResizeXY_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseMove(X, Y, MODE_RESIZE_XY)
End Sub
Private Sub imgResizeXY_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Resize_MouseUp(Button)
End Sub
'*** フォームの初期化 ***
Private Sub UserForm_Initialize()
'*** 枠線の消去 ***
imgResizeX.BorderStyle = fmBorderStyleNone
imgResizeY.BorderStyle = fmBorderStyleNone
imgResizeXY.BorderStyle = fmBorderStyleNone
'*** マウスポインターの設定 ***
imgResizeX.MousePointer = fmMousePointerSizeWE
imgResizeY.MousePointer = fmMousePointerSizeNS
imgResizeXY.MousePointer = fmMousePointerSizeNWSE
Call SetResizeControls
End Sub
| 固定リンク
コメント