- 积分
- 1665
- 明经币
- 个
- 注册时间
- 2009-11-10
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
楼主 |
发表于 2011-6-7 16:54:45
|
显示全部楼层
本帖最后由 xyz002 于 2011-6-7 17:03 编辑
代码如下:
Sub tt (PathStr As String, layer As String)
On Error Resume Next
Dim sset As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("ss")) Then
Set sset = ThisDrawing.SelectionSets.Item("ss")
sset.Delete
End If
Set sset = ThisDrawing.SelectionSets.Add("ss")
Dim fType(0) As Variant
Dim fData(0) As Variant
Dim obj As AcadBlockReference
fType(0) = 0
fData(0) = "INSERT"
sset.SelectOnScreen fType, fData
If sset.count > 0 Then
With MyShape
.OpenShape "c:\test.shp", shpCreate, shpPoint
Dim NewField As ShapeField
Set NewField = .ShapeFields.CreateField("SOUTH", shpText, 8)
Set NewField = .ShapeFields.CreateField("点号", shpText, 15)
Set NewField = .ShapeFields.CreateField("Z坐标", shpDouble, 15, 3)
.AppendFieldDefs
End With
For Each obj In sset
Dim PointCoor As Variant
PointCoor = obj.InsertionPoint
Dim xtype As Variant
Dim xdata As Variant
obj.GetXData "", xtype, xdata
If TypeName(xdata) <> "Empty" Then
Dim sum As Integer
sum = UBound(xdata) - LBound(xdata) + 1
With MyShape
Dim sum1 As Integer
sum1 = .ShapeFields.count
Dim i As Integer, j As Integer
For i = 0 To sum - 1 Step 2
On Error Resume Next
For j = 1 To sum1
If StrComp(xdata(i), .ShapeFields.Item(j).FieldName) = 0 Then
.ShapeFields.Item(j).Value = xdata(i + 1)
End If
Next j
Next i
Dim NewVert As Variant
Set NewVert = .Vertices.AddVertice(PointCoor(0), PointCoor(1))
.CreateShape
End With
End If
Next obj
End If
End Sub
程序运行时,更多的是reading错误:
有时候 一运行就关闭CAD窗口,这是什么类型的错误?
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
x
|