社区 › VB › 边框问题

yingxunxue 发表于 2004-6-17 15:06:00

边框问题

' 绘边框的VBA程序
Public Sub test()
Dim ss As AcadSelectionSet
Dim i As AcadEntity
Dim pEntity(0) As AcadEntity
Set ss = ThisDrawing.ActiveSelectionSet
ss.Select acSelectionSetAll
ss(0).GetBoundingBox pmin, pmax
For Each i In ss
i.GetBoundingBox p1, p2
If p1(0)pmax(0) Then pmax(0) = p2(0)
If p2(1) > pmax(1) Then pmax(1) = p2(1)
Next i
ThisDrawing.SendCommand "_.RECTANG " & pmin(0) & "," & pmin(1) & vbCr & pmax(0) & "," & pmax(1) & vbCr
把上面程序中的THISDRAWING替换为ACADDOC(在VB中使用)
为什么在Set ss = acaddoc.ActiveSelectionSet时出错"接口出错"

yingxunxue 发表于 2004-6-17 15:27:00

错误信息
      

yingxunxue 发表于 2004-6-17 15:37:00

可能是选择集的问题,我重新建立一个CAD文件,就可以运行一次.
有谁可以为我加个判断选择集的语句吗?
呵呵

david.xw 发表于 2004-6-17 15:40:00

Dim ssetObj As AcadSelectionSet
For Each ssetObj In ThisDrawing.SelectionSets
                       If ssetObj.Name = "SS" Then
                                                       ssetObj.Clear
                                                       ssetObj.Delete
                                                       Exit For
                       End If
Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS")

yingxunxue 发表于 2004-6-17 15:56:00

      
' 绘边框的VBA程序
Public Sub test()
Dim ss As AcadSelectionSet
Dim i As AcadEntity
Dim pEntity(0) As AcadEntity
Dim ssetObj As AcadSelectionSet
For Each ssetObj In ThisDrawing.SelectionSets
                         If ssetObj.Name = "SS" Then
                                                         ssetObj.Clear
                                                         ssetObj.Delete
                                                         Exit For
                         End If
Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS")
Set ss = ThisDrawing.ActiveSelectionSet
ss.Select acSelectionSetAll
ss(0).GetBoundingBox pmin, pmax
For Each i In ss
i.GetBoundingBox p1, p2
If p1(0)pmax(0) Then pmax(0) = p2(0)
If p2(1) > pmax(1) Then pmax(1) = p2(1)
Next i
ThisDrawing.SendCommand "_.RECTANG " & pmin(0) & "," & pmin(1) & vbCr & pmax(0) & "," & pmax(1) & vbCr
Set pEntity(0) = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)Dim offsetObj As Variant
offsetObj = pEntity(0).Offset(500)
pEntity(0).Delete
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
pmax(0) = pmax(0) + 500
pmin(1) = pmin(1) - 500
Dim ucsobj As AcadUCS
Dim origin As Variant
Dim xAxispnt As Variant
Dim yAxispnt As Variant
Dim utilObj As Object
Set utilObj = ThisDrawing.Utility
'定义ucs
utilObj.CreateTypedArray origin, vbDouble, pmax(0), pmin(1), 3
utilObj.CreateTypedArray xAxispnt, vbDouble, pmax(0) + 1, pmin(1), 3
utilObj.CreateTypedArray yAxispnt, vbDouble, pmax(0), pmin(1) + 1, 3
Set ucsobj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxispnt, yAxispnt, "new_ucs")
ThisDrawing.ActiveViewport.UCSIconAtOrigin = True
      ThisDrawing.ActiveViewport.UCSIconOn = True
         ThisDrawing.ActiveUCS = ucsobj
Set pEntity(0) = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
Dim offsetObj1 As Variant
offsetObj1 = pEntity(0).Offset(50)
''''定义块的插入点
Dim blockInspoint(0 To 2) As Double
Dim blockRefobj As AcadBlockReference
blockInspoint(0) = pmax(0)
blockInspoint(1) = pmin(1)
blockInspoint(2) = 3
Set blockRefobj = ThisDrawing.ModelSpace.InsertBlock(inspoint, "F:\我的课题\陶瓷工业梭式窑CAD系统1\窑车标注1.dwg", 1, 1, 1, 0)还是出现上面的问题.

雪山飞狐_lzh 发表于 2004-6-17 16:15:00

Set ss = ThisDrawing.ActiveSelectionSet去掉，后面的ss用ssetObj代替

david.xw 发表于 2004-6-17 16:18:00

ss(1).GetBoundingBox pmin, pmax
当前无选择集,当然会出错!

yingxunxue 发表于 2004-6-17 16:23:00

兄弟 :到底如何做呀.
我的程序是在 画好边框后,在内边框插上标题栏,
只能运行一次扫心了

david.xw 发表于 2004-6-17 17:07:00

......
For Each ssetObj In ThisDrawing.SelectionSets
                       If ssetObj.Name = "SS" Then
                                                       ssetObj.Clear
                                                       ssetObj.Delete
                                                       Exit For
                       End If
Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS")
ssetObj .Select acSelectionSetAll
ssetObj .GetBoundingBox pmin, pmax
For Each i In ssetObj
i.GetBoundingBox p1, p2
......

yingxunxue 发表于 2004-6-17 17:48:00

ssetObj .GetBoundingBox pmin, pmax
必须改为ssetOjb(0)
不知道是什么原因,而且运行中在CAD命令行中出现"命令: 忽略块 窑车标注 的重复定义。"
呵呵这不知道是什么意思

查看完整版本: 边框问题