|
|
代码如下：加下划线的地方提示类型不匹配，为什么？二天都没找到原因啊。
Private Sub UserForm_Click()
Dim aa As AcadPolyline
Me.hide
Dim entobj As AcadEntity
Dim coorpoint As Variant
Dim coorpoint1 As Variant
Dim pickpoint As Variant
ThisDrawing.Utility.GetEntity entobj, pickpoint, "请选择闭合多段线"
If StrComp(entobj.ObjectName, "acdbpolyline", 1) = 0 And entobj.Closed = True Then
a = entobj.Area
TextBox1.Text = a
coorpoint = entobj.Coordinates
Else
MsgBox "不是多段线或没有闭合，请检查"
Exit Sub
End If
Dim n As Integer, m As Integer
n = UBound(coorpoint)
m = (n + 1) * 3 / 2 - 1
TextBox2.Text = n
For I = 0 To n Step 2
[U][U]coorpoint1(I * 3 / 2) = coorpoint(I)[/U]
coorpoint1(I * 3 / 2 + 1) = coorpoint(I + 1)
'coorpoint1(I + 2) = 0
Next I
'TextBox2.Text = coorpoint1(5)
Dim sset As AcadSelectionSet
On Error Resume Next
If ThisDrawing.SelectionSets.Count 0 Then
For j = 0 To ThisDrawing.SelectionSets.Count - 1
Set sset = ThisDrawing.SelectionSets(I)
sset.Delete
Next
End If
Set sset = ThisDrawing.SelectionSets.Add("4")
mode = acSelectionSetCrossingPolygon
'mode = acSelectionSetWindowPolygon
filtertype = 0
filterdata = "text"
sset.SelectByPolygon mode, coorpoint1, filtertype, filterdata
'sset.SelectOnScreen
Dim entry As AcadEntity
For Each entry In sset
entry.Color = acBlue
entry.updata
Next entry
Me.Show
End Sub
|
|
置顶卡
