边框问题
' 绘边框的VBA程序<BR>Public Sub test()<BR>Dim ss As AcadSelectionSet<BR>Dim i As AcadEntity<BR>Dim pEntity(0) As AcadEntity<BR>Set ss = ThisDrawing.ActiveSelectionSet<BR>ss.Select acSelectionSetAll<BR>ss(0).GetBoundingBox pmin, pmax<BR>For Each i In ss<BR>i.GetBoundingBox p1, p2<BR>If p1(0) < pmin(0) Then pmin(0) = p1(0)<BR>If p1(1) < pmin(1) Then pmin(1) = p1(1)<BR>If p2(0) > pmax(0) Then pmax(0) = p2(0)<BR>If p2(1) > pmax(1) Then pmax(1) = p2(1)<BR>Next i<BR>ThisDrawing.SendCommand "_.RECTANG " & pmin(0) & "," & pmin(1) & vbCr & pmax(0) & "," & pmax(1) & vbCr把上面程序中的THISDRAWING替换为ACADDOC(在VB中使用)
为什么在Set ss = acaddoc.ActiveSelectionSet时出错"接口出错" 错误信息
可能是选择集的问题,我重新建立一个CAD文件,就可以运行一次.
有谁可以为我加个判断选择集的语句吗?
呵呵 Dim ssetObj As AcadSelectionSet
For Each ssetObj In ThisDrawing.SelectionSets<BR> If ssetObj.Name = "SS" Then<BR> ssetObj.Clear<BR> ssetObj.Delete<BR> Exit For<BR> End If<BR>Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS") <BR>
' 绘边框的VBA程序<BR>Public Sub test()<BR>Dim ss As AcadSelectionSet<BR>Dim i As AcadEntity<BR>Dim pEntity(0) As AcadEntity<BR>Dim ssetObj As AcadSelectionSet
For Each ssetObj In ThisDrawing.SelectionSets<BR> If ssetObj.Name = "SS" Then<BR> ssetObj.Clear<BR> ssetObj.Delete<BR> Exit For<BR> End If<BR>Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS")
Set ss = ThisDrawing.ActiveSelectionSet<BR>ss.Select acSelectionSetAll<BR>ss(0).GetBoundingBox pmin, pmax<BR>For Each i In ss<BR>i.GetBoundingBox p1, p2<BR>If p1(0) < pmin(0) Then pmin(0) = p1(0)<BR>If p1(1) < pmin(1) Then pmin(1) = p1(1)<BR>If p2(0) > pmax(0) Then pmax(0) = p2(0)<BR>If p2(1) > pmax(1) Then pmax(1) = p2(1)<BR>Next i<BR>ThisDrawing.SendCommand "_.RECTANG " & pmin(0) & "," & pmin(1) & vbCr & pmax(0) & "," & pmax(1) & vbCr<BR>Set pEntity(0) = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
Dim offsetObj As Variant<BR>offsetObj = pEntity(0).Offset(500)<BR>pEntity(0).Delete<BR>''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<BR>pmax(0) = pmax(0) + 500<BR>pmin(1) = pmin(1) - 500<BR>Dim ucsobj As AcadUCS<BR>Dim origin As Variant<BR>Dim xAxispnt As Variant<BR>Dim yAxispnt As Variant<BR>Dim utilObj As Object<BR>Set utilObj = ThisDrawing.Utility<BR>'定义ucs<BR>utilObj.CreateTypedArray origin, vbDouble, pmax(0), pmin(1), 3<BR>utilObj.CreateTypedArray xAxispnt, vbDouble, pmax(0) + 1, pmin(1), 3<BR>utilObj.CreateTypedArray yAxispnt, vbDouble, pmax(0), pmin(1) + 1, 3<BR>Set ucsobj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxispnt, yAxispnt, "new_ucs")<BR>ThisDrawing.ActiveViewport.UCSIconAtOrigin = True<BR> ThisDrawing.ActiveViewport.UCSIconOn = True<BR> ThisDrawing.ActiveUCS = ucsobj
Set pEntity(0) = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)<BR>Dim offsetObj1 As Variant<BR>offsetObj1 = pEntity(0).Offset(50)<BR>''''定义块的插入点<BR>Dim blockInspoint(0 To 2) As Double<BR>Dim blockRefobj As AcadBlockReference<BR>blockInspoint(0) = pmax(0)<BR>blockInspoint(1) = pmin(1)<BR>blockInspoint(2) = 3<BR>Set blockRefobj = ThisDrawing.ModelSpace.InsertBlock(inspoint, "F:\我的课题\陶瓷工业梭式窑CAD系统1\窑车标注1.dwg", 1, 1, 1, 0)
还是出现上面的问题. 本帖最后由 作者 于 2004-6-17 22:31:27 编辑
Set ss = ThisDrawing.ActiveSelectionSet去掉，后面的ss用ssetObj代替 ss(1).GetBoundingBox pmin, pmax
当前无选择集,当然会出错! 兄弟 :到底如何做呀.
我的程序是在 画好边框后,在内边框插上标题栏,
只能运行一次扫心了 lzh741206发表于2004-6-17 16:15:00static/image/common/back.gifSet ss = ThisDrawing.ActiveSelectionSet去掉，后面的ss用ssobj代替
......
For Each ssetObj In ThisDrawing.SelectionSets<BR> If ssetObj.Name = "SS" Then<BR> ssetObj.Clear<BR> ssetObj.Delete<BR> Exit For<BR> End If<BR>Next ssetObj
Set ssetObj = ThisDrawing.SelectionSets.Add("SS")
ssetObj .Select acSelectionSetAll<BR>ssetObj .GetBoundingBox pmin, pmax<BR>For Each i In ssetObj <BR>i.GetBoundingBox p1, p2<BR>......<BR> ssetObj .GetBoundingBox pmin, pmax
必须改为ssetOjb(0)
不知道是什么原因,而且运行中在CAD命令行中出现"命令: 忽略块 窑车标注 的重复定义。"
呵呵这不知道是什么意思<BR>
页:
[1]
2