批量裁剪后如何复制粘贴到原坐标

q1365466 · 发表于 2021-2-1 23:24:58

Public Function axEnt2lspEnt(entObj As AcadEntity) As String
Dim 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

Public Function axEnt2lspEnt(entObj As AcadEntity) As String 
    Dim 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-4-24 03:56:12

本帖最后由 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

账号		自动登录	找回密码
密码			注册