CAD vba窗体文本框中无法右键弹出“复制”、“粘贴”等功能，可借助如下代码实现“粘贴功能”，原理为模拟按下键盘发送命令。（excel vba 窗体中可实现 commandbar和 commandbarcontrol，即命令栏和“复制”、“粘贴”等控件，而CAD vba 中无此功能）
Private Sub TextBox_directory_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If Button = 2 Then
If MsgBox("是否粘贴目录", vbYesNo, "版权所有qq:443440204") = vbYes Then
'userform1.TextBox_directory.SetFocus
SendKeys "^a" & "^v", True
Else
SendKeys "^a" & "{BACKSPACE}", True
End If
End If
End Sub效果如图所示：
在文本框右键弹出弹窗，点击是即可完成"ctrl+v"粘贴功能（前提是需要完成复制路径）。
另附若干程序代码：
模块部分
Public selectlayer As String
Public Function creatsel() As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("mysel")) Then
Set creatsel = ThisDrawing.SelectionSets.Item("mysel")
creatsel.Delete
''如果图中有名为"mysel"的选择集，那么把这个选择集放入sel中，然后删除这个选择集
End If
''如果图中没有"mysel"，那么新建一个名为"mysel"的选择集，赋给sel这个对象
Set creatsel = ThisDrawing.SelectionSets.Add("mysel")
End Function
Sub 合并特定图层窗体()
'Application.Visible = False
UserForm1.show
End Sub
userform1部分：
Private Sub CommandButton1_Click()
'合并图层带图号
Application.Visible = True
Dim a As String, b As String
a = TextBox1.Value
a = IIf(Right(a, 1) = "\", Left(a, Len(a) - 1), a)
b = a & "\总" & Format(Time, "hh-mm") & ".dwg"
'Dim sel As AcadSelectionSet
Dim ljwj As String, lj As String, zong As String
Dim myzong As AcadDocument
Documents.Add
Set myzong = ActiveDocument
zong = ThisDrawing.Name
Dim ftype(0 To 10) As Integer, fdata(0 To 10) As Variant
ftype(0) = -4: fdata(0) = "<AND"
ftype(1) = 8: fdata(1) = "JZD"
ftype(2) = -4: fdata(2) = "<AND"
ftype(3) = -4: fdata(3) = "<NOT"
ftype(4) = 0: fdata(4) = "text"
ftype(5) = -4: fdata(5) = "NOT>"
ftype(6) = -4: fdata(6) = "<NOT"
ftype(7) = 0: fdata(7) = "mtext"
ftype(8) = -4: fdata(8) = "NOT>"
ftype(9) = -4: fdata(9) = "AND>"
ftype(10) = -4: fdata(10) = "AND>"
Dim obj As AcadObject
lj = a
ljwj = Dir(lj & "\*.dwg")
Dim lay As AcadLayer
For Each lay In ThisDrawing.Layers
If lay.Name = "JZD" Then
Set JZD = ThisDrawing.Layers("JZD")
ThisDrawing.ActiveLayer = JZD
JZD.color = acRed
Exit For
End If
Next lay
If ThisDrawing.ActiveLayer.Name <> "JZD" Then
Set JZD = ThisDrawing.Layers.Add("JZD")
ThisDrawing.ActiveLayer = JZD
JZD.color = acRed
End If
Do While ljwj <> ""
Set mydqwj = Documents.Open(lj & "\" & ljwj)
Set sel = creatsel()
sel.Select acSelectionSetAll, , , ftype, fdata
If sel.Count > 0 Then
Dim arr() As Object
ReDim arr(sel.Count - 1)
For i = 0 To sel.Count - 1
Set arr(i) = sel.Item(i)
Next i
dqwj = lj & "\" & ljwj
Dim myblock As AcadBlock: Dim ptbase(2) As Double: ptbase(0) = 0: ptbase(1) = 0: ptbase(2) = 0:
Dim blockname As String:
blockname = Left(ljwj, 10)
Set myblock = myzong.Blocks.Add(ptbase, blockname)
mydqwj.CopyObjects arr, myblock
Set insblock = myzong.ModelSpace.InsertBlock(ptbase, blockname, 1, 1, 1, 0)
End If
mydqwj.Close
Erase arr
ljwj = Dir
Loop
ThisDrawing.Regen acActiveViewport
Application.Visible = True
ZoomExtents
ThisDrawing.SaveAs b
Unload UserForm1
MsgBox "已完成!" & vbCr & "文件保存在:" & vbCr & b
End Sub
Private Sub CommandButton2_Click()
'合并DWG
Application.Visible = True
Dim a As String, b As String
a = TextBox1.Value
a = IIf(Right(a, 1) = "\", Left(a, Len(a) - 1), a)
b = a & "\总" & Format(Time, "hh-mm") & ".dwg"
Dim ljwj As String, lj As String, zong As String
Dim myzong As AcadDocument
Documents.Add
Set myzong = ActiveDocument
zong = ThisDrawing.Name
Dim obj As AcadObject
lj = a
ljwj = Dir(lj & "\*.dwg")
'统计文件总数
Dim file_count As Integer, filecount_progress As Integer
Do While ljwj <> ""
file_count = file_count + 1
ljwj = Dir
Loop
UserForm1.Label4.Caption = ""
ljwj = Dir(lj & "\*.dwg")
''''
Do While ljwj <> ""
Set mydqwj = Documents.Open(lj & "\" & ljwj)
Set sel = creatsel()
sel.Select acSelectionSetAll
If sel.Count > 0 Then
Dim arr() As Object
ReDim arr(sel.Count - 1)
For i = 0 To sel.Count - 1
Set arr(i) = sel.Item(i)
Next i
dqwj = lj & "\" & ljwj
mydqwj.CopyObjects arr, myzong.ModelSpace
End If
mydqwj.Close
Erase arr
''进度条显示
filecount_progress = filecount_progress + 1
UserForm1.Label3.Width = 222
UserForm1.Label4.Width = 40
UserForm1.Label2.Width = UserForm1.Label3.Width * filecount_progress / file_count
UserForm1.Label4.Caption = Round(filecount_progress / file_count * 100, 0) & "%"
UserForm1.Repaint
'''
ljwj = Dir
Loop
''进度条清除
UserForm1.Label2.Width = 0
UserForm1.Label3.Width = 0
UserForm1.Label4.Width = 0
UserForm1.Label4.Caption = ""
''
ThisDrawing.Regen acActiveViewport
Application.Visible = True
ZoomExtents
ThisDrawing.SaveAs b
Unload UserForm1
MsgBox "已完成!" & vbCr & "文件保存在:" & vbCr & b
End Sub
Private Sub CommandButton3_Click()
'退出
'UserForm1.Hide
Unload Me
End
'Application.Visible = True
End Sub
Private Sub CommandButton4_Click()
'54to2000
Application.Visible = True
On Error Resume Next
If ThisDrawing.FullName = "" Then
MsgBox "您未打开待转换文件或未保存文件"
Exit Sub
End If
Dim activedwg As AcadDocument: Dim rtn As String
Dim center(0 To 2) As Double
ZoomAll
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 400000 - 62.77 + 116.4: point2(1) = 3800000 - 48.29 + 0.9: point2(2) = 0
Dim ent As AcadEntity
For Each ent In ThisDrawing.ModelSpace
ent.Move point1, point2
Next ent
fullname_ = Left(ThisDrawing.FullName, Len(ThisDrawing.FullName) - 4)
Dim time_add As String
time_add = Replace(Now(), ":", "-")
time_add = Replace(time_add, "/", "-")
time_add = Replace(time_add, " ", "_")
time_add = "_" & Right(time_add, Len(time_add) - 5)
ThisDrawing.Regen acActiveViewport
ZoomExtents
ThisDrawing.PurgeAll
ThisDrawing.SaveAs fullname_ & time_add & "z54to2000.dwg"
UserForm1.Hide
End Sub
Private Sub CommandButton5_Click()
'80to2000
Application.Visible = True
On Error Resume Next
If ThisDrawing.FullName = "" Then
MsgBox "您未打开待转换文件或未保存文件"
Exit Sub
End If
Dim activedwg As AcadDocument: Dim rtn As String
Dim center(0 To 2) As Double
ZoomAll
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 116.4: point2(1) = 0.9: point2(2) = 0
Dim ent As AcadEntity
For Each ent In ThisDrawing.ModelSpace
ent.Move point1, point2
Next ent
fullname_ = Left(ThisDrawing.FullName, Len(ThisDrawing.FullName) - 4)
Dim time_add As String
time_add = Replace(Now(), ":", "-")
time_add = Replace(time_add, "/", "-")
time_add = Replace(time_add, " ", "_")
time_add = "_" & Right(time_add, Len(time_add) - 5)
ThisDrawing.Regen acActiveViewport
ZoomExtents
ThisDrawing.PurgeAll
ThisDrawing.SaveAs fullname_ & time_add & "z54to2000.dwg"
UserForm1.Hide
End Sub
Private Sub CommandButton6_Click()
'更多
On Error Resume Next
Unload Me
'Load UserForm2
UserForm2.show
End Sub
Private Sub CommandButton7_Click()
'合并指定图层带图号
Dim sl As String
UserForm2.show
sl = selectlayer
If sl = "" Then
MsgBox "您未选择图层"
Exit Sub
End If
Application.Visible = True
Dim a As String, b As String
selectlayer = UserForm2.TextBox1
a = TextBox1.Value
a = IIf(Right(a, 1) = "\", Left(a, Len(a) - 1), a)
b = a & "\总" & Format(Time, "hh-mm") & ".dwg"
Dim ljwj As String, lj As String, zong As String
Dim myzong As AcadDocument
Documents.Add
Set myzong = ActiveDocument
zong = ThisDrawing.Name
Dim ftype(0) As Integer, fdata(0) As Variant
'ftype(0) = -4: fdata(0) = "<AND"
ftype(0) = 8: fdata(0) = sl
'ftype(2) = -4: fdata(2) = "<AND"
'ftype(3) = -4: fdata(3) = "<NOT"
'ftype(4) = 0: fdata(4) = "mtext"
'ftype(5) = -4: fdata(5) = "NOT>"
'
'ftype(6) = -4: fdata(6) = "<NOT"
'ftype(7) = 0: fdata(7) = "mtext"
'ftype(8) = -4: fdata(8) = "NOT>"
'ftype(9) = -4: fdata(9) = "AND>"
'ftype(10) = -4: fdata(10) = "AND>"
Dim obj As AcadObject
lj = a
ljwj = Dir(lj & "\*.dwg")
Dim lay As AcadLayer
For Each lay In ThisDrawing.Layers
If lay.Name = sl Then
Set JZD = ThisDrawing.Layers(sl)
ThisDrawing.ActiveLayer = JZD
JZD.color = acRed
Exit For
End If
Next lay
If ThisDrawing.ActiveLayer.Name <> sl Then
Set JZD = ThisDrawing.Layers.Add(sl)
ThisDrawing.ActiveLayer = JZD
JZD.color = acRed
End If
Do While ljwj <> ""
Set mydqwj = Documents.Open(lj & "\" & ljwj)
Set sel = creatsel()
sel.Select acSelectionSetAll, , , ftype, fdata
If sel.Count > 0 Then
Dim arr() As Object
ReDim arr(sel.Count - 1)
For i = 0 To sel.Count - 1
Set arr(i) = sel.Item(i)
Next i
dqwj = lj & "\" & ljwj
Dim myblock As AcadBlock: Dim ptbase(2) As Double: ptbase(0) = 0: ptbase(1) = 0: ptbase(2) = 0:
Dim blockname As String:
blockname = Left(ljwj, 10)
Set myblock = myzong.Blocks.Add(ptbase, blockname)
mydqwj.CopyObjects arr, myblock
Set insblock = myzong.ModelSpace.InsertBlock(ptbase, blockname, 1, 1, 1, 0)
End If
mydqwj.Close
Erase arr
ljwj = Dir
Loop
ThisDrawing.Regen acActiveViewport
Application.Visible = True
ZoomExtents
ThisDrawing.SaveAs b
Unload UserForm1
MsgBox "已完成!" & vbCr & "文件保存在:" & vbCr & b
End Sub
Private Sub Label1_Click()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If Button = 2 Then
If MsgBox("是否粘贴目录", vbYesNo, "版权所有qq:443440204") = vbYes Then
'userform1.TextBox_directory.SetFocus
SendKeys "^a" & "^v", True
Else
SendKeys "^a" & "{BACKSPACE}", True
End If
End If
End Sub
userform2部分
Private Sub CommandButton1_Click()
''userform2的返回按钮
Unload Me
End Sub
Public Sub CommandButton2_Click()
''userform2的确定按钮
selectlayer = UserForm2.TextBox1.Value
Unload UserForm2
End Sub
Private Sub UserForm2_Initialize()
UserForm2.TextBox1.SetFocus
End Sub
1万+
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
