批量裁剪后如何复制粘贴到原坐标
Public Function axEnt2lspEnt(entObj As AcadEntity) As StringDim entHandle As String
entHandle = entObj.Handle
axEnt2lspEnt = "(handent" & Chr(34) & entHandle & Chr(34) & ")"
End Function
Public Function offent(obj As AcadEntity, off As Double, pt() As Double, de As Boolean) As AcadEntity
Const pi = 3.1415926
'obj??????????off???????????????pt()???????????????????,de ???????????????
'???obj????????????????????????????????????
Dim obj1 As AcadPolyline
Dim pl As AcadPolyline
Dim cr As AcadCircle
Select Case UCase(obj.ObjectName)
Case "ACDB3DPOLYLINE", "ACDB2DPOLYLINE"
ReDim pt(UBound(obj.Coordinates)) As Double
For I = 0 To UBound(pt) Step 3
pt(I) = obj.Coordinate(I / 3)(0)
pt(I + 1) = obj.Coordinate(I / 3)(1)
Next I
teml = obj.Layer
temc = obj.Closed
Case "ACDBPOLYLINE"
ReDim pt(((UBound(obj.Coordinates) + 1) / 2) * 3 - 1) As Double
For I = 0 To UBound(pt) Step 3
pt(I) = obj.Coordinate((I) / 3)(0)
pt(I + 1) = obj.Coordinate((I) / 3)(1)
Next I
teml = obj.Layer
temc = obj.Closed
Case "ACDBCIRCLE"
Set cr = obj
Dim pp As Double
pp = cr.radius
ReDim pt(359 * 3 + 2) As Double
For I = 0 To 359
pt(I * 3) = cr.center(0) + Cos(I * pi / 180) * cr.radius
pt(I * 3 + 1) = cr.center(1) + Sin(I * pi / 180) * cr.radius
pt(I * 3 + 2) = 0
Next I
teml = obj.Layer
temc = True
End Select
Set obj1 = ThisDrawing.ModelSpace.AddPolyline(pt)
obj1.Layer = teml
obj1.Closed = temc
'---------------------------------
Dim offobj As AcadEntity
Select Case off
Case Is > 0
off1 = obj1.Offset(off)
If off1(0).Area < obj1.Area Then
off1(0).Delete
off1 = obj1.Offset(-1 * off)
End If
Set offobj = off1(0)
Case Is < 0
off1 = obj1.Offset(off)
If off1(0).Area > obj1.Area Then
off1(0).Delete
off1 = obj1.Offset(-1 * off)
End If
Set offobj = off1(0)
End Select
'--------------------------------
Set offent = offobj
ReDim pt(UBound(offobj.Coordinates)) As Double
For I = 0 To UBound(pt) Step 3
pt(I) = offobj.Coordinate(I / 3)(0)
pt(I + 1) = offobj.Coordinate(I / 3)(1)
Next I
obj1.Delete
Set obj1 = Nothing
If de Then
offobj.Delete
End If
End Function
Public Function chkclose(SSet As AcadSelectionSet) As Boolean
chkclose = True
Dim pl As AcadObject
For I = 0 To SSet.Count - 1
Set pl = SSet.Item(I)
Select Case UCase(pl.ObjectName)
Case "ACDB3DPOLYLINE", "ACDB2DPOLYLINE"
last = (UBound(pl.Coordinates) + 1) / 3 - 1
Case "ACDBPOLYLINE"
last = (UBound(pl.Coordinates) + 1) / 2 - 1
Case "ACDBCIRCLE"
last = -1
End Select
If last > 0 Then
If Not (pl.Closed Or (pl.Coordinate(0)(0) = pl.Coordinate(last)(0) And pl.Coordinate(0)(1) = pl.Coordinate(last)(1))) Then
chkclose = False
pl.color = acRed
pl.Highlight True
End If
End If
Next I
End Function
Sub trim()
Dim ptt(0 To 7) As Double
pt1 = ThisDrawing.Utility.GetPoint(, " ?????????????:")
pt2 = ThisDrawing.Utility.GetCorner(pt1, " ?????????????:")
ptt(0) = pt1(0)
ptt(1) = pt1(1)
ptt(2) = pt1(0)
ptt(3) = pt2(1)
ptt(4) = pt2(0)
ptt(5) = pt2(1)
ptt(6) = pt2(0)
ptt(7) = pt1(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptt)
plineObj.Closed = True
Dim SSet1 As AcadSelectionSet
For Each SSet1 In ThisDrawing.SelectionSets
If SSet1.Name = "SS2" Then
ThisDrawing.SelectionSets.Item("SS2").Delete
Exit For
End If
Next
Set SSet1 = ThisDrawing.SelectionSets.Add("SS2")
Dim keyWord As String
'??????????????
Dim ft() As Integer
Dim fd() As Variant
ReDim ft(0) As Integer
ReDim fd(0) As Variant
ft(0) = 0
fd(0) = "polyline,lwpolyline,circle"
SSet1.Select acSelectionSetLast, pt1, pt2, ft, fd
If SSet1.Count = 0 Then
MsgBox "δ???????", vbCritical, "??????"
Exit Sub
End If
If Not chkclose(SSet1) Then
MsgBox "?????????в???????Σ?" & vbCr & "???飬?????????г???", vbCritical, "?????"
Exit Sub
End If
ThisDrawing.StartUndoMark
Dim offobj As AcadEntity
Dim off As Double
off = 0.1
Dim pt() As Double
ThisDrawing.Regen acActiveViewport
'ThisDrawing.Application.ZoomExtents
Dim strcom As String
ThisDrawing.SetVariable "modemacro", "????????????????????..."
'??????ж??????????????????
ThisDrawing.SendCommand "trim "
For I = 0 To SSet1.Count - 1
ThisDrawing.SendCommand axEnt2lspEnt(SSet1.Item(I)) & vbCr
Set offobj = offent(SSet1.Item(I), off, pt(), False)
ThisDrawing.SendCommand axEnt2lspEnt(offobj) & vbCr
Next I
ThisDrawing.SendCommand vbCr
'????????????????????????
For I = 0 To SSet1.Count - 1
Set offobj = offent(SSet1.Item(I), off / 2, pt(), True)
For j = 0 To UBound(pt) Step 3
strcom = strcom & pt(j)
strcom = strcom & "," & pt(j + 1) & vbCr
Next j
strcom = strcom & pt(0)
strcom = strcom & "," & pt(1) & vbCr
strcom = strcom & Chr(9)
Next I
'???????????????????
Dim sc() As String
sc = Split(strcom, Chr(9))
'------------------------------------------------
ThisDrawing.SetVariable "modemacro", "."
ThisDrawing.SetVariable "modemacro", "??????е?" & j & "?β???..."
For I = 0 To UBound(sc) - 1
DoEvents
ThisDrawing.SendCommand "f " & sc(I) & vbCr
Next I
' GoTo begindel
SSet1.Clear
ReDim ft(0) As Integer
ReDim fd(0) As Variant
ft(0) = 0: fd(0) = "polyline,lwpolyline,circle"
For I = 0 To UBound(sc) - 1
pp = Split(sc(I), vbCr)
n = -1
For k = 0 To UBound(pp) - 1
temp = Split(pp(k), ",")
n = n + 3
ReDim Preserve pt(n) As Double
pt(n - 2) = temp(0)
pt(n - 1) = temp(1)
Next k
Set temp = Nothing
SSet1.SelectByPolygon acSelectionSetFence, pt, ft, fd
last = SSet1.Count
Dim lp As Integer
n = 0
'lp = 0
While SSet1.Count <> 0
lp = lp + 1
ThisDrawing.SetVariable "modemacro", "."
ThisDrawing.SetVariable "modemacro", "??????е?" & lp & "?β???..."
last = SSet1.Count
ThisDrawing.SendCommand "f " & sc(I) & vbCr
SSet1.Clear
If last = 0 Then GoTo nnext
SSet1.SelectByPolygon acSelectionSetFence, pt, ft, fd
If last = SSet1.Count Then
n = n + 1
End If
If n = 4 Then
GoTo nnext
End If
Wend
nnext:
Next I
begindel:
Set offobj = Nothing
ReDim pt(0) As Double
strcom = ""
Set pp = Nothing
SSet1.Clear
ThisDrawing.SendCommand vbCr
ThisDrawing.Utility.InitializeUserInput 0, "1 2"
keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "?ü??????????1,?ü????????2 (1/2): ")
If keyWord = "" Then keyWord = "1"
'??????????
ThisDrawing.SendCommand "e "
' '??????
If keyWord = "1" Then
sendcom = "wp "
For I = 0 To UBound(sc) - 1
ThisDrawing.SendCommand sendcom & sc(I) & vbCr
Next I
'???????
ElseIf keyWord = "2" Then
sendcom = "r wp "
ThisDrawing.SendCommand "all "
For I = 0 To UBound(sc) - 1
ThisDrawing.SendCommand sendcom & sc(I) & vbCr
Next I
End If
ThisDrawing.SendCommand vbCr
ThisDrawing.EndUndoMark
End Sub
以上是批量裁剪功能，参考某大神编写的，请问大神们如何把框选裁剪前的数据先复制粘贴到新建文件里面再实行自动裁剪？
本帖最后由 KO你 于 2021-12-30 06:06 编辑
方法1：
快捷键cv1粘贴到原坐标
(defun c:cv1 () (command"pasteorig"))
方法2：
可以试试先“Ctrl+C(复制）”，然后输入“Alt+E+D”组合键CAD默认的，没必要去编
方法3：
也可以命令copybase带基点复制输入坐标0，0 粘贴时也输入坐标0，0
页:
[1]