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