CAD VB实现Wipeout的创建删除后置.docVIP

CAD VB实现Wipeout的创建删除后置 Private Sub AeroButton1_Click() On Error GoTo err1 Dim obj As AcadApplication Dim doc As AcadDocument Dim sset As AcadSelectionSet Dim i, j As Double Dim ft(0) As Integer Dim fd(0) As Variant Set obj = GetObject(, autocad.application.16) Set doc = obj.ActiveDocument ft(0) = 0 fd(0) = Wipeout Set sset = CreateSSet(SSET, doc) sset.Clear sset.Select acSelectionSetAll, , , ft, fd If sset.Count 0 Then pro.max = sset.Count For i = 0 To sset.Count - 1 pro.Value = i sset.Item(i).Delete Next End If MsgBox (删除完毕!) Exit Sub err1: MsgBox (程序出错，不能处理的异常!) End Sub Private Sub AeroButton2_Click() On Error GoTo err1 Dim obj As AcadApplication Dim doc As AcadDocument Dim sset As AcadSelectionSet Dim pnt(0 To 7) As Double Dim min As Variant Dim max As Variant Dim znt As Variant Dim txt As AcadText Dim arg1 As Double Dim arg2 As Double Dim arg3 As Double Dim arg4 As Double Dim zarg As Double Dim JL As Double Dim zxd(0 To 2) As Double Dim zx(0 To 2) As Double Dim ft(6) As Integer Dim fd(6) As Variant Set obj = GetObject(, autocad.application.16) Set doc = obj.ActiveDocument doc.Application.ZoomExtents ft(0) = 0 fd(0) = Text ft(1) = -4 fd(1) = or ft(2) = 8 fd(2) = 729000 ft(3) = 8 fd(3) = 719000 ft(4) = 8 fd(4) = 759000 ft(5) = 8 fd(5) = 769000 ft(6) = -4 fd(6) = or Set sset = CreateSSet(SSET, doc) sset.Clear sset.Select acSelectionSetAll, , , ft, fd If sset.Count 0 Then pro.max = sset.Count For i = 0 To sset.Count - 1 pro.Value = i Set txt = sset.Item(i) If txt.Rotation = 0 Then txt.GetBoundingBox min, max min(0) = min(0) min(1) = min(1) - 0.0814 min(2) = 0 max(0) = max(0) max(1) = max(1) + 0.0814 max(2) = 0 JL = ddist(min, max