自動算出鞋圖樣板的個數程序

BDYCAD

下程序自动地测出我设计鞋样片的个数,

 

 

[Power=1]

; 制鞋专用   测试样板片的个数
; 源码来自Meflying大侠, BDYCAD在应用中,
; 时间 : 2004-08-05
(defun c:test (/ ss select-spline-g)
  (setq ss (ssget "X" '((0 . "SPLINE") (8 . "0")))); 取得所有0层的spline曲线
  (setq select-spline-g (Get_Selection_List ss)); 调用子程序把组成鞋样板片图的曲线分为一个选集组一个选集组
  (princ (strcat "\n报告BDYCAD, 你当前的文件样板版的个数为" (rtos (length select-spline-g)) "个, 如有凝问请自行查正."))
  (princ))
(defun HasInters (ent_1 ent_2 / ax_ent_1 ax_ent_2 intpoints)
  (setq ax_ent_1 (vlax-ename->vla-object ent_1)
        ax_ent_2 (vlax-ename->vla-object ent_2)
  )
  (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendboth))
  (setq intpoints (vlax-variant-value intpoints))
  (if (> (vlax-safearray-get-u-bound intpoints 1) 0)
    t
    nil
  )
)
(defun Get_Inters_Name(ename ss / n i ename2 rname)
  (setq i 0)
  (setq n (sslength ss))
  (while (< i n)
    (setq ename2 (ssname ss i))
    (if (HasInters ename ename2)
      (progn
 (setq rname ename2)
 (setq i n)
      )
      (setq i (1+ i))
    )
  )
  rname
)
(defun Get_Selection_List(ss /  ss_New n Ename1 Ename2 Ename_List)
  (IF SS (PROGN
  (setq n (sslength ss))
  (while (> n 0)
    (setq Ename1 (ssname ss 0))
    (ssdel Ename1 ss)
    (setq ss_New (ssadd))
    (ssadd Ename1 ss_New)
    (while (setq Ename2 (Get_Inters_Name Ename1 ss))
      (ssadd Ename2 ss_New)
      (ssdel Ename2 ss)
      (setq Ename1 Ename2)
    )
    (setq Ename_List (append Ename_List (list ss_New)))
    (setq ss_New nil)
    (setq n (sslength ss))
  )))
  (princ)
  Ename_List
)

[/Power]

BDYCAD

但是如果在样板片我开了孔程序就多计出来了如下图所示, 在这里我想请教Mefyling 版主和龙龙版主和各位朋友. 如何解决这样的情况呢? 因为我这里制鞋用的都是spline哦. 还望各位朋友在百忙中抽个时间给我指点一二. 谢谢!!!


       

王咣生

你的图是Group形式，考虑组字典是否会好处理些, 今天写了个vba的程序,有些牵强:
'就你的dwg文件而言,你需要得到的鞋样板片都是以组Group形式存在的.
'而开孔实体没有,仍然是Spline.
'所以这个程序只对这两张图. 如果开孔实体也是在Group中,就要再想别的方法了! Sub Test() Dim ssetObj As AcadSelectionSet
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets Set ssetObj = CreateSSet("TEST2") Dim mode As Integer

mode = acSelectionSetAll Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "SPLINE"

Dim groupCode As Variant
Dim dataCode As Variant
groupCode = gpCode
dataCode = dataValue

ssetObj.Select acSelectionSetAll, , , groupCode, dataCode

'取得选择集中所有Spline实体ID
Dim ssObj As AcadEntity
Dim ind As Integer
Dim idlist() As Long
ReDim idlist(0)

For ind = 0 To ssetObj.Count - 1
Set ssObj = ssetObj.Item(ind)
If StrComp(ssObj.ObjectName, "AcDbSpline", 1) = 0 Then
ReDim Preserve idlist(UBound(idlist) + 1)
idlist(UBound(idlist)) = ssObj.ObjectID
End If
Next
''' Dim groupsObj As AcadGroups
Set groupsObj = ThisDrawing.Groups
Dim groupObj As AcadGroup Dim num As Integer 'Group个数计数据器
num = 0 Dim i, j As Integer

For i = 0 To groupsObj.Count - 1
Set groupObj = groupsObj.Item(i)
Dim na As String
na = groupObj.name

Dim Count As Integer
Count = groupObj.Count
If Count > 0 Then
Dim grpEnt As AcadEntity

'检查每一个Group中有无idlist()数组中列出的实体
For j = 0 To Count - 1
Set grpEnt = groupObj.Item(j)
Dim entName As String
entName = grpEnt.ObjectName
If StrComp(entName, "AcDbSpline", 0) = 0 Then
Dim entId As Long
entId = grpEnt.ObjectID
'在idlist中查找有无entId,如果有,我就认为这个Group是一个鞋样(当然不具有普适性)
Dim il As Integer
Dim found As Boolean
found = False
For il = 1 To UBound(idlist)
If entId = idlist(il) Then
found = True
Exit For
End If
Next
If (found = True) Then
num = num + 1 '计数器
Exit For
End If
End If
Next '
End If
Next

MsgBox num
End Sub
Private Function CreateSSet(ByVal name As String) As AcadSelectionSet
On Error GoTo ERR_HANDLER

Dim ssetObj As AcadSelectionSet
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets

Dim index As Integer
Dim found As Boolean

found = False For index = 0 To SSetColl.Count - 1
Set ssetObj = SSetColl.Item(index)
If StrComp(ssetObj.name, name, 1) = 0 Then
found = True
Exit For 'Important.
End If
Next

If Not (found) Then
Set ssetObj = SSetColl.Add(name)
Else
ssetObj.Delete '
Set ssetObj = SSetColl.Add(name)
End If

Set CreateSSet = ssetObj

Exit Function
ERR_HANDLER:
'-----------------------------------------------
' just print the error the the debug window.
Debug.Print "Error in sub CreateSSet: " & Err.Number & " -- "; Err.Description
Resume ERR_END

ERR_END:
End Function

BDYCAD

在实际的使用时，　我是把所有的组清去的．　不好意思上传的文件忘记清去组了．王版主我明天再看你的ＶＢＡ，　我现加班的眼睛痛痛．你晚上也早点休息哦．

王咣生

如果不用Group,那这段vba是用不上了,哈哈。

spring

王斑竹真是厉害 VBA,ARX,LISP样样都行


为什么不写个 LISP 的上来呢???

BDYCAD

我的问一直没找不到正确的解决方法呢. Meflying 有空帮我看看如何?

citykunan

TO :BDYCAD


我有一个思路，不知是否可行。当得到选择集后，依次判断，用zoom--WPolygon逼近你的鞋底样板的轮廓，如果再轮廓之内选到了选择集内的物体，就在选择集的数量上减1，依次类推。不知可行否？

BDYCAD

就来就是一个样板. 可是程序报出四个了.

无痕

BDYCAD发表于2004-9-9 11:09:00就来就是一个样板. 可是程序报出四个了.

好的习惯是把内部环另外放一个层，这样直接选外部实体就知道有多少个了。 下面的试试，我写来玩的：）