tt

本人在工作中编的

Option Explicit

Sub main()
  
  Dim sFile As String
  Dim Element As Object
  Dim RetCoord As Variant
  
  Dim Dis As Double

  On Error GoTo ErrHandle
    sFile = Dir("e:\dwg\*.dwg", vbArchive)
  
Do While sFile <> ""
        
   ThisDrawing.Application.Documents.Open ("e:\dwg\" & sFile)
   ThisDrawing.SetVariable "ltscale", 1
   
 For Each Element In ThisDrawing.ModelSpace
   If Element.Layer = "C285210" And Element.ObjectName = "AcDb3dPolyline" Then
      Element.Delete
   ElseIf Element.Layer = "C285210" And Element.EntityName = "AcDbPolyline" Then
      If UBound(Element.Coordinates) = 3 Then
         RetCoord = Element.Coordinates
         Dis = Abs((RetCoord(0) - RetCoord(2)) ^ 2 + (RetCoord(1) - RetCoord(3)) ^ 2)
         If Dis <= 1.001 Then
           Element.Delete
         End If
       End If
   End If
   
 Next Element
 
 '******************************************************************
 '刷新图形
  ThisDrawing.Regen True
  ThisDrawing.PurgeAll
  ThisDrawing.PurgeAll
  '******************************************************************
   ThisDrawing.Save
   ThisDrawing.Close
   sFile = Dir
Loop
  
  Exit Sub
ErrHandle:
    MsgBox Err.Description, vbCritical

End Sub