none
ExcelのVBAで、Form上で移動可能なコントロールを動的に作成し、配置した後、その状態を保存することができますか? RRS feed

  • 質問

  • ExcelのVBAで、Form上で移動可能なコントロールを動的に作成し、配置した後、その状態を保存することができますか?

    次回、開いたとき、その状態から作業を続けたい。

    やりたい事 ー 在庫管理

    商品が入荷した際、新しいコマンドボタン(この場合、パレットを意味する。)を作成し、Form上に貼られた倉庫図上の任意箇所に配置する。そのコマンドボタンをダブルクリックすると、別のフォームが出現し、在庫の確認や入出荷処理が行える。「← ここまでのプログラムはできたのですが 」

    さらにやりたい事

    Frame(パレットの段積みを意味する)も動的に作成「これはプログラムできましたが」し、上述のコマンドボタン(パレットを意味する)をそのFrame内に入れたり、Frame外に出したりしたい。
    ↑ Frame内に入れたり、Frame外に出したりが、できない。

    上記内容を説明する画像も付けさせていただきます。

    何卒よろしくお願い申し上げます。

    2019年7月6日 13:33

すべての返信

  • ExcelのVBAで、Form上で移動可能なコントロールを動的に作成し、配置した後、その状態を保存することができますか?
    次回、開いたとき、その状態から作業を続けたい。

    ワークシートに配置に必要な情報を保存しておいて、次回表示時にはその情報から復元する

    上述のコマンドボタン(パレットを意味する)をそのFrame内に入れたり、Frame外に出したりしたい。

    出し入れするときにコマンドボタンを削除して、対象に新たに作り直す

    *ユーザーフォーム

    Option Explicit
    
    Private items As New collection
    
    Private Sub UserForm_Initialize()
    
        Dim name As String
        name = "##_" & TypeName(Me)
    
        Dim ws As Worksheet
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets(name)
        On Error GoTo 0
        If ws Is Nothing Then
            Exit Sub
        End If
    
        Dim rng As Range
    
        '設定保存用ワークシートにある設定からフレームを生成する
        Set rng = ws.Cells(1, 1)
        Do While rng.value <> ""
            If rng.value = "Frame" Then
                Dim itemF As FrameItem
                Set itemF = New FrameItem
                    
                Call itemF.AddControlToForm(Me)
                
                itemF.Caption = rng.Offset(0, 1).value
                itemF.Left = rng.Offset(0, 2).value
                itemF.Top = rng.Offset(0, 3).value
                itemF.Width = rng.Offset(0, 4).value
                itemF.Height = rng.Offset(0, 5).value
                itemF.Tag = rng.Offset(0, 6).value
        
                Call items.Add(itemF)
                Call itemF.Frame.ZOrder(0)
            End If
            Set rng = rng.Offset(1, 0)
        Loop
        
        '設定保存用ワークシートにある設定からボタンを生成する
        Set rng = ws.Cells(1, 1)
        Do While rng.value <> ""
            If rng.value = "Button" Then
                Dim itemB As ButtonItem
                Set itemB = New ButtonItem
         
                Dim frameName As String
                frameName = Trim(rng.Offset(0, 7).value)
                If frameName <> "" Then
                    Dim Frame As Frame
                    Set Frame = Me.Controls(frameName)
                    Call itemB.AddControlToForm(Frame)
                Else
                    Call itemB.AddControlToForm(Me)
                End If
                
                itemB.Caption = rng.Offset(0, 1).value
                itemB.Left = rng.Offset(0, 2).value
                itemB.Top = rng.Offset(0, 3).value
                itemB.Width = rng.Offset(0, 4).value
                itemB.Height = rng.Offset(0, 5).value
                itemB.Tag = rng.Offset(0, 6).value
        
                Call items.Add(itemB)
                Call itemB.Button.ZOrder(0)
            End If
            Set rng = rng.Offset(1, 0)
        Loop
        
    End Sub
    
    Private Sub UserForm_Terminate()
        Dim name As String
        name = "##_" & TypeName(Me)
    
        Dim ws As Worksheet
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets(name)
        On Error GoTo 0
        If ws Is Nothing Then
            Set ws = ThisWorkbook.Worksheets.Add
            ws.name = name
            'ws.Visible = xlSheetHidden
        End If
    
        ws.Cells.Clear
    
        '設定保存用ワークシートに設定を書き出す
        Dim rng As Range
        Set rng = ws.Cells(1, 1)
    
        Dim itemTemp As Object
        Dim index As Integer
        For Each itemTemp In items
            If TypeOf itemTemp Is FrameItem Then
                Dim itemF As FrameItem
                Set itemF = itemTemp
                rng.Offset(0, 0).value = "Frame"
                
                rng.Offset(0, 1).value = itemF.Caption
                rng.Offset(0, 2).value = itemF.Left
                rng.Offset(0, 3).value = itemF.Top
                rng.Offset(0, 4).value = itemF.Width
                rng.Offset(0, 5).value = itemF.Height
                rng.Offset(0, 6).value = itemF.Tag
                
                Set rng = rng.Offset(1, 0)
            End If
            
        Next
        
        For Each itemTemp In items
            If TypeOf itemTemp Is ButtonItem Then
                Dim itemB As ButtonItem
                Set itemB = itemTemp
                
                rng.Offset(0, 0).value = "Button"
                
                rng.Offset(0, 1).value = itemB.Caption
                rng.Offset(0, 2).value = itemB.Left
                rng.Offset(0, 3).value = itemB.Top
                rng.Offset(0, 4).value = itemB.Width
                rng.Offset(0, 5).value = itemB.Height
                rng.Offset(0, 6).value = itemB.Tag
                       
                If TypeOf itemB.Button.Parent Is MSForms.Frame Then
                    rng.Offset(0, 7).value = itemB.Button.Parent.name
                End If
                
                Set rng = rng.Offset(1, 0)
            End If
        Next
    End Sub
    
    
    Private Sub AddButtonCommandButton_Click()
        Dim itemB As ButtonItem
        Set itemB = New ButtonItem
          
        Call itemB.AddControlToForm(Me)
        Call items.Add(itemB)
    End Sub
    
    Private Sub AddFrameCommandButton_Click()
        Dim itemF As FrameItem
        Set itemF = New FrameItem
        Call itemF.AddControlToForm(Me)
        
        Call items.Add(itemF)
    End Sub
    *クラスモジュール(ButtonItem)
    Option Explicit
    
    Private WithEvents m_Frame As MSForms.Frame
    
    Private m_caption As String
    Private m_left As Long
    Private m_top As Long
    Private m_width As Long
    Private m_height As Long
    Private m_tag As String
    
    Private m_flag As Boolean
    Private m_x As Single
    Private m_y As Single
    
    Public Property Get Frame() As MSForms.Frame
        Set Frame = m_Frame
    End Property
    Private Property Set Frame(ByVal btn As MSForms.Frame)
        Set m_Frame = btn
        
        If Not (m_Frame Is Nothing) Then
            m_Frame.Caption = m_caption
            m_Frame.Left = m_left
            m_Frame.Top = m_top
            m_Frame.Width = m_width
            m_Frame.Height = m_height
            m_Frame.Tag = m_tag
        End If
    End Property
    
    
    Public Property Get Caption() As String
        Caption = m_caption
    End Property
    Public Property Let Caption(ByVal value As String)
        m_caption = value
        If Not m_Frame Is Nothing Then
            m_Frame.Caption = value
        End If
    End Property
    
    Public Property Get Left() As String
        If Not m_Frame Is Nothing Then
            m_left = m_Frame.Left
        End If
        
        Left = m_left
    End Property
    Public Property Let Left(ByVal value As String)
        m_left = value
        If Not m_Frame Is Nothing Then
            m_Frame.Left = value
        End If
    End Property
    
    Public Property Get Top() As String
        If Not m_Frame Is Nothing Then
            m_top = m_Frame.Top
        End If
        
        Top = m_top
    End Property
    Public Property Let Top(ByVal value As String)
        m_top = value
        If Not m_Frame Is Nothing Then
            m_Frame.Top = value
        End If
    End Property
    
    Public Property Get Width() As String
        If Not m_Frame Is Nothing Then
            m_width = m_Frame.Width
        End If
        
        Width = m_width
    End Property
    Public Property Let Width(ByVal value As String)
        m_width = value
        If Not m_Frame Is Nothing Then
            m_Frame.Width = value
        End If
    End Property
    
    Public Property Get Height() As String
        If Not m_Frame Is Nothing Then
            m_height = m_Frame.Height
        End If
        
        Height = m_height
    End Property
    Public Property Let Height(ByVal value As String)
        m_height = value
        If Not m_Frame Is Nothing Then
            m_Frame.Height = value
        End If
    End Property
    
    Public Property Get Tag() As String
        If Not m_Frame Is Nothing Then
            m_tag = m_Frame.Tag
        End If
        
        Tag = m_tag
    End Property
    Public Property Let Tag(ByVal value As String)
        m_tag = value
        If Not m_Frame Is Nothing Then
            m_Frame.Tag = value
        End If
    End Property
    
    
    '***************************************
    
    Private Sub Class_Initialize()
        Caption = ""
        Left = 20
        Top = 20
        Width = 50
        Height = 50
    End Sub
    
    
    'ユーザーフォームにフレームを追加する
    Public Sub AddControlToForm(ByVal form As MSForms.UserForm)
        Set Frame = form.Controls.Add("Forms.Frame.1", , True)
    End Sub
    
    Public Sub m_Frame_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Down", X, Y
        m_x = X
        m_y = Y
        m_flag = True
    End Sub
    
    Public Sub m_Frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Move", X, Y
        If Not m_flag Then
            Exit Sub
        End If
        
        Dim wpx As Single
        Dim wpy As Single
        wpx = m_Frame.Left + X
        wpy = m_Frame.Top + Y
        
        m_Frame.Left = m_Frame.Left + X - m_x
        m_Frame.Top = m_Frame.Top + Y - m_y
    End Sub
    
    Public Sub m_Frame_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        m_flag = False
    End Sub
    *クラスモジュール(FrameItem)
    Option Explicit
    
    Private WithEvents m_Button As MSForms.CommandButton
    
    Private m_caption As String
    Private m_left As Long
    Private m_top As Long
    Private m_width As Long
    Private m_height As Long
    Private m_tag As String
    
    Private m_flag As Boolean
    Private m_x As Single
    Private m_y As Single
    
    Public Property Get Button() As MSForms.CommandButton
        Set Button = m_Button
    End Property
    Private Property Set Button(ByVal btn As MSForms.CommandButton)
        Set m_Button = btn
        
        If Not (m_Button Is Nothing) Then
            m_Button.Caption = m_caption
            m_Button.Left = m_left
            m_Button.Top = m_top
            m_Button.Width = m_width
            m_Button.Height = m_height
            m_Button.Tag = m_tag
        End If
    End Property
    
    
    Public Property Get Caption() As String
        Caption = m_caption
    End Property
    Public Property Let Caption(ByVal value As String)
        m_caption = value
        If Not m_Button Is Nothing Then
            m_Button.Caption = value
        End If
    End Property
    
    Public Property Get Left() As String
        If Not m_Button Is Nothing Then
            m_left = m_Button.Left
        End If
        
        Left = m_left
    End Property
    Public Property Let Left(ByVal value As String)
        m_left = value
        If Not m_Button Is Nothing Then
            m_Button.Left = value
        End If
    End Property
    
    Public Property Get Top() As String
        If Not m_Button Is Nothing Then
            m_top = m_Button.Top
        End If
        
        Top = m_top
    End Property
    Public Property Let Top(ByVal value As String)
        m_top = value
        If Not m_Button Is Nothing Then
            m_Button.Top = value
        End If
    End Property
    
    Public Property Get Width() As String
        If Not m_Button Is Nothing Then
            m_width = m_Button.Width
        End If
        
        Width = m_width
    End Property
    Public Property Let Width(ByVal value As String)
        m_width = value
        If Not m_Button Is Nothing Then
            m_Button.Width = value
        End If
    End Property
    
    Public Property Get Height() As String
        If Not m_Button Is Nothing Then
            m_height = m_Button.Height
        End If
        
        Height = m_height
    End Property
    Public Property Let Height(ByVal value As String)
        m_height = value
        If Not m_Button Is Nothing Then
            m_Button.Height = value
        End If
    End Property
    
    Public Property Get Tag() As String
        If Not m_Button Is Nothing Then
            m_tag = m_Button.Tag
        End If
        
        Tag = m_tag
    End Property
    Public Property Let Tag(ByVal value As String)
        m_tag = value
        If Not m_Button Is Nothing Then
            m_Button.Tag = value
        End If
    End Property
    
    
    '***************************************
    
    Private Sub Class_Initialize()
        Caption = ""
        Left = 0
        Top = 0
        Width = 20
        Height = 20
    End Sub
    
    'フレームにボタンを追加する
    Public Sub AddControlToFrame(ByVal Frame As MSForms.Frame)
        Set Button = Frame.Controls.Add("Forms.CommandButton.1", , True)
    End Sub
    'ユーザーフォームにボタンを追加する
    Public Sub AddControlToForm(ByVal form As MSForms.UserForm)
        Set Button = form.Controls.Add("Forms.CommandButton.1", , True)
    End Sub
    
    'ユーザーフォームかフレームから削除する
    Public Sub Remove()
        If m_Button Is Nothing Then
            Exit Sub
        End If
        
        m_caption = m_Button.Caption
        m_left = m_Button.Left
        m_top = m_Button.Top
        m_width = m_Button.Width
        m_height = m_Button.Height
        m_tag = m_Button.Tag
        
        Dim Frame As MSForms.Frame
        Dim form As MSForms.UserForm
        
        If TypeOf m_Button Is MSForms.Frame Then
            Dim f As MSForms.Frame
            Set f = m_Button.Parent
            
            Call f.Controls.Remove(m_Button.name)
            
        Else
            Dim u As MSForms.UserForm
            Set u = m_Button.Parent
            Call u.Controls.Remove(m_Button.name)
        End If
        
        Set Button = Nothing
    End Sub
    
    '指定したフレームに移動する
    Public Sub MoveToFrame(ByVal Frame As MSForms.Frame)
        Remove
        Call AddControlToFrame(Frame)
    End Sub
    
    '指定したユーザーフォームに移動する
    Public Sub MoveToForm(ByVal form As MSForms.UserForm)
        Remove
        Call AddControlToForm(form)
    End Sub
    
    
    Public Sub m_Button_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        MsgBox m_Button.Caption
    End Sub
    
    
    Public Sub m_Button_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Down", X, Y
        m_x = X
        m_y = Y
        m_flag = True
    End Sub
    
    Public Sub m_Button_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Move", X, Y
        If Not m_flag Then
            Exit Sub
        End If
        
        Dim wpx As Single
        Dim wpy As Single
        wpx = m_Button.Left + X
        wpy = m_Button.Top + Y
        
        m_Button.Left = m_Button.Left + X - m_x
        m_Button.Top = m_Button.Top + Y - m_y
        
        Dim f As MSForms.Frame
        Dim u As MSForms.UserForm
        If TypeOf m_Button.Parent Is MSForms.Frame Then
            Set f = m_Button.Parent
            Set u = f.Parent
                    
            If wpx < 0 Or f.Width < wpx Or wpy < 0 Or f.Height < wpy Then
                Call MoveToForm(u)
                
                m_Button.Left = m_Button.Left + f.Left
                m_Button.Top = m_Button.Top + f.Top
            End If
        Else
            Set u = m_Button.Parent
            Dim ctl As Control
            
            For Each ctl In u.Controls
                If TypeOf ctl Is MSForms.Frame Then
                    If (ctl.Left <= wpx And wpx <= ctl.Left + ctl.Width And ctl.Top <= wpy And wpy <= ctl.Top + ctl.Height) Then
                        Set f = ctl
                        Call MoveToFrame(f)
                        
                        m_Button.Left = m_Button.Left - f.Left
                        m_Button.Top = m_Button.Top - f.Top
    
                        Exit For
                    End If
                End If
            Next
        End If
        
    End Sub
    
    Public Sub m_Button_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Up", X, Y
        m_flag = False
    End Sub

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2019年7月7日 13:58