youry8007 发表于 2011-10-26 13:24:30

如何实现AutoCAD里自动布置点的位置

对AutoCAD VBA 编程是一个初学者,现在正在编辑一个程序,数据库用的是Access,文件名A.MDB,CAD块的文件名B.dwg;块在文件B.dwg已经定义好了,想编辑一个程序把access数据库里对应的”位号坐标“的X/Y坐标撒点到AUTOCAD里,不知道怎么实现,请高手们指点一二,拜谢了!!!
我的编程思路大概是这样:先创建一个选择集程序,设定范围,设定完之后在进行插入块;选择集的程序做好了
Sub Select_Polygon()
Dim SSet As AcadSelectionSet
Dim SSetObj As Object
On Error Resume Next
Dim fType(0 To 1) As Integer
Dim fData(0 To 1) As Variant
   If Not IsNull(ThisDrawing.SelectionSets.Item("BlockCount")) Then
      Set SSet = ThisDrawing.SelectionSets.Item("BlockCount")
      SSet.Delete
    End If
      Set SSet = ThisDrawing.SelectionSets.Add("BlockCount")
   
fType(0) = 0: fData(0) = "Insert"
fType(1) = 2: fData(1) = "Text_Block"
Dim pT1(0 To 2) As Double
Dim pT2(0 To 2) As Double
Dim Attr_Tag(0 To 1) As String
Dim Attr_Text(0 To 1) As String

Attr_Tag(0) = "A1": Attr_Tag(1) = "B1"
Attr_Text(0) = "Tag_No": Attr_Text(1) = "FT_x01"

pT1(0) = 0: pT1(1) = 0
pT2(0) = 500: pT2(1) = 500

SSet.Select acSelectionSetWindow, pT1, pT2, fType, fData

Dim EntObj As AcadEntity
Dim BlockRefObj As AcadBlockReference
Dim Mtextobj As AcadBlockReference

For Each EntObj In SSet
If TypeOf EntObj Is AcadBlockReference Then
   Set Mtextobj = EntObj
   If Mtextobj.TextString = "Here is title" Then
   Exit For
   Else
   Exit Sub
   End If
End If
Next

Dim AA As String

For Each EntObj In SSet
If TypeOf EntObj Is AcadBlockReference Then
    Set BlockRefObj = EntObj
         If BlockRefObj.HasAttributes Then
                Attrefs = BlockRefObj.GetAttributes
                For i = 0 To UBound(Attrefs)
                   AA = AA & Attrefs(i).TextString
                   MsgBox AA
                Next
         End If
End If
Next
   
End Sub
但是下来插入块怎么实现

youry8007 发表于 2011-10-27 14:29:53

高手们请帮帮忙啊,请斑竹出招啊

cqy 发表于 2011-10-29 19:32:23

使用EXCEL比较容易实现

chmenf087 发表于 2011-10-30 14:53:40

VBA很久没玩了,但是这个应该不难吧,打开cad用AcadPoint 对象作为点对象就好了啊。不清楚加我Q
页: [1]
查看完整版本: 如何实现AutoCAD里自动布置点的位置