excel - 表单中的表单 - VBA 右键单击复制/粘贴多页
问题描述
我之前问过一个问题,并收到了 TM 的回复,完美地回答了它!
但是,当我在辅助表单中输入代码时,我收到了与最初在主表单中收到的相同的错误。
下面是放置在表单和类模块中的代码以及一些屏幕截图,以更好地说明第二种形式,因为我不确定我是否解释得很清楚......
非常感谢大家!
代码形式:
Dim cBar As clsBar
Private Sub UserForm_Initialize()
On Error GoTo Whoa
Application.EnableEvents = False
Set cBar = New clsBar
cBar.Initialize Me
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
类模块中的代码
'Popup objects
Private cmdBar As CommandBar
Private WithEvents cmdCopyButton As CommandBarButton
Private WithEvents cmdPasteButton As CommandBarButton
'Useform to use
Private fmUserform As Object
'Control array of textbox
Private colControls As Collection
'Textbox Control
Private WithEvents tbControl As MSForms.TextBox
'Adds all the textbox in the userform to use the popup bar
Sub Initialize(ByVal UF As Object)
Dim Ctl As MSForms.Control
Dim cBar As clsBar
For Each Ctl In UF.Controls
If TypeName(Ctl) = "TextBox" Then
'Check if we have initialized the control array
If colControls Is Nothing Then
Set colControls = New Collection
Set fmUserform = UF
'Create the popup
CreateBar
End If
'Create a new instance of this class for each textbox
Set cBar = New clsBar
cBar.AssignControl Ctl, cmdBar
'Add it to the control array
colControls.Add cBar
End If
Next Ctl
End Sub
Private Sub Class_Terminate()
'Delete the commandbar when the class is destroyed
On Error Resume Next
cmdBar.Delete
End Sub
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform) ' find control's name
' Debug.Print sACN & ".Copy"
fmUserform.Controls(sACN).copy ' << instead of fmUserform.ActiveControl.Copy
CancelDefault = True
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform)
' Debug.Print sACN & ".Paste"
fmUserform.Controls(sACN).Paste ' << instead of fmUserform.ActiveControl.Paste
CancelDefault = True
End Sub
'Right click event of each textbox
Private Sub tbControl_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 And Shift = 0 Then
'Display the popup
cmdBar.ShowPopup
End If
End Sub
Private Sub CreateBar()
Set cmdBar = Application.CommandBars.Add(, msoBarPopup, False, True)
'We’ll use the builtin Copy and Paste controls
Set cmdCopyButton = cmdBar.Controls.Add(ID:=19)
Set cmdPasteButton = cmdBar.Controls.Add(ID:=22)
End Sub
'Assigns the Textbox and the CommandBar to this instance of the class
Sub AssignControl(TB As MSForms.TextBox, Bar As CommandBar)
Set tbControl = TB
Set cmdBar = Bar
End Sub
Function ActiveControlName(form As UserForm) As String
'cf Site: https://stackoverflow.com/questions/47745663/get-activecontrol-inside-multipage
'Purpose: get ActiveControl
Dim MyMultiPage As MSForms.MultiPage, myPage As MSForms.Page
If form.ActiveControl Is Nothing Then
' do nothing
ElseIf TypeName(form.ActiveControl) = "MultiPage" Then
Set MyMultiPage = form.ActiveControl
Set myPage = MyMultiPage.SelectedItem
ActiveControlName = myPage.ActiveControl.Name
Else
ActiveControlName = form.ActiveControl.Name
End If
End Function
当我在第二个表单中单击复制或粘贴时,出现错误:
运行时错误“438”:
对象不支持此属性或方法。在线上:
fmUserform.Controls(sACN).Paste
解决方案
第二次用户窗体调用的必要修改
问题似乎直接在第一个表单中显示第二个表单,并且因为单击事件也从单击的“CAT”控件获取返回值。
这对我有用:
- 建议仅在您的 UF 模块中显示第二个用户窗体
ShowYODA
,即调用位于单独模块中的过程,例如
在单独的模块中调用第二种形式的示例
Sub ShowYODA
With New YODA ' temporary new UF instance
.Show vbModeless
End With
End Sub
- 以下事件过程和调用的辅助函数需要更改(仅对将在调用事件中修剪的文本框使用结束空格标记):
相关点击事件
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform) ' find control's name
If Right$(sACN, 1) = " " Then ' marker (=ending space) for textboxes only!
Debug.Print Trim(sACN) & ".Copy"
fmUserform.Controls(Trim(sACN)).Copy ' << instead of fmUserform.ActiveControl.Copy /438 unterstü.d.Meth nicht!
CancelDefault = True
End If
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform) ' find control's name
If Right$(sACN, 1) = " " Then ' marker (=ending space) for textboxes only!
Debug.Print Trim(sACN) & ".Copy"
fmUserform.Controls(Trim(sACN)).Paste ' << instead of fmUserform.ActiveControl.Copy
CancelDefault = True
End If
End Sub
修改辅助函数ActiveControlName()
Function ActiveControlName(form As MSForms.UserForm) As String
'cf Site: https://stackoverflow.com/questions/47745663/get-activecontrol-inside-multipage
'Purpose: get ActiveControl name string and mark text boxes by an ending space
Dim MyMultiPage As MSForms.MultiPage, myPage As MSForms.Page
If form.ActiveControl Is Nothing Then
' do nothing
ElseIf TypeName(form.ActiveControl) = "MultiPage" Then
Set MyMultiPage = form.ActiveControl
Set myPage = MyMultiPage.SelectedItem
ActiveControlName = myPage.ActiveControl.Name
If TypeName(form.Controls(ActiveControlName)) = "TextBox" Then ActiveControlName = ActiveControlName & " "
Else
ActiveControlName = form.ActiveControl.Name
If TypeName(form.Controls(ActiveControlName)) = "TextBox" Then ActiveControlName = ActiveControlName & " "
End If
End Function
推荐阅读
- mysql - MySQL多行与将值全部存储在一个字符串中
- angularjs - 控制台返回错误数据
- graph - 为什么图处理难以分布式?
- mysql - 如何在数百万行中通过查询优化计数和排序
- sql - 存在三个表 A、B 和 C,其中我需要根据 B 中存在的公式将 C 中的值添加或连接到 A
- opc-ua - 使用 Eclipse milo 为 OPC UA 创建客户端,但在使用 ReadExample 时出错
- javascript - 在 DNN 站点中嵌入机器人
- vue.js - VUE DropDownList cascadeFrom不起作用
- python - 如果存在空白字符串,则在 Python 中连接字符串,忽略分隔符
- python-3.x - Python,Bokeh,映射时“哎呀!出了点问题”