[LISP程序]：将选定的两条曲线连成一条(vlisp+vba源码)

whrock · 发表于 2005-8-11 23:57:14

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

只为表示对晓东家园的支持。
先给出Vlisp的，再给出VBA的。

;;; 环境初始化
(vl-load-com) ;_ 确保加载了 activex 支持
;;; c:ccc
;;; 将相邻的两条曲线合并成一条曲线，
;;; 同时如果一条曲线的两端点相邻则将此曲线封闭。
;;; 用户可手工选择两条曲线（spline,*polyline），或一条曲线，先选后选均可。
(defun c:ccc (/ comclosedist fpprecision selsets
selset filtertype filterdata curve1
fplist1 curve2 fplist2 fparray
statan endtan newcurve newcurvearray
)
(setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
*modelspace* (vla-get-ModelSpace *thisdrawing*)
)
(setq comclosedist
10 ;_ 小于这个距离才合并或封闭
fpprecision
1.01 ;_ 获取 fitpoint 时使用的精度
filtertype
0 ;_ 0 在DXF格式中是图元类型的组码
filterdata
"spline,*polyline" ;_ 图元类型的值
newcurve nil
)
;; 曲线选择，一条或两条
(setq selsets (vla-get-selectionsets *thisdrawing*))
(if (= (vla-get-count selsets) 0)
(vla-add selsets (vlax-make-variant "ss1"))
)
(setq selset (vla-item selsets 0))
(vla-clear selset)
(vla-select
selset
acSelectionSetPrevious
filtertype
filterdata
)
(if (= 0 (vla-get-count selset))
(progn
(prompt
"\n请选择两条相邻的 spline,*polyline <退出>:"
)
; (vla-SelectOnScreen selset filtertype filterdata)
(vla-SelectOnScreen selset)
)
)
;; 进行曲线合并
(if (= 2 (vla-get-count selset))
(progn
;; 获取第1条曲线的拟合点列表 fitpoints 。
(setq curve1 (vla-item selset 0))
(if (= "acdbspline" (strcase (vla-get-ObjectName curve1) t))
(setq fplist1 (spline_fplist curve1 fpprecision)) ;_ 对 spline ，直接或间接取它的 fitpoint 。
(setq fplist1 (pline_vertexlist curve1)) ;_ 对 *polyline ，取其 vertex 为 fitpoint 。
)
;; 获取第2条曲线的拟合点列表 fitpoints 。
(setq curve2 (vla-item selset 1))
(if (= "acdbspline" (strcase (vla-get-ObjectName curve2) t))
(setq fplist2 (spline_fplist curve2 fpprecision)) ;_ 对 spline ，直接或间接取它的 fitpoint 。
(setq fplist2 (pline_vertexlist curve2)) ;_ 对 *polyline ，取其 vertex 为 fitpoint 。
)
;; 删除旧曲线
(vla-delete curve1)
(vla-delete curve2)
;; 合并两个fplist生成新曲线
(setq fplist1 (spline_combine2fpl fplist1 fplist2))
(setq fparray (vlax-make-safearray
vlax-vbdouble
(cons 0 (1- (length fplist1)))
)
)
(vlax-safearray-fill fparray fplist1)
(setq
statan (setq
endtan (vlax-make-safearray vlax-vbDouble '(0 . 2))
)
)
(setq newcurve (vla-addspline *modelspace* fparray statan endtan))
;; 将新曲线的 fitpoint 都 purge 掉，以减少图形数据量。
;;; (vla-PurgeFitData newcurve)
;; 将曲线加入 selset ，以供进一步处理
(vla-clear selset)
(setq newcurvearray (vlax-make-safearray vlax-vbObject '(0 . 0)))
(vlax-safearray-fill newcurvearray (list newcurve))
(vla-additems selset newcurvearray)
)
)
;; 将曲线封闭
(if (= 1 (vla-get-count selset))
(progn
(setq newcurve (vla-item selset 0))
(if (> comclosedist
(distance (vlax-curve-getstartpoint newcurve)
(vlax-curve-getEndPoint newcurve)
)
)
(progn
;; 用 ssadd 创建的 selection set , 才适用于命令行。
;; selset 的类型是 VLA-Object acadSelectionSet , 不适用于命令行。
;; 两种选择集不能互相转换：(vlax-vla-object->ename selset) 返回 nil 。
(setq lspselset (ssadd (vlax-vla-object->ename newcurve)))
;; 调用acad命令行
(command "splinedit" lspselset "c" "" "")
)
)
)
)
;; 结束
(princ)
)
;;; 返回 *polyline 的顶点（vertex）列表
;;; 参数说明，
;;; plobj -- polyline object , 类型为 vla-object .
;;; -----
(defun pline_vertexlist
(plobj / plname vtxlist fp fplist plinetype vtxcount i)
(setq plname (vlax-vla-object->ename plobj)
fplist nil
i 0
)
(setq vtxlist (vlax-safearray->list (vla-get-coordinates plobj)))
(setq plinetype (strcase (vla-get-objectname plobj) t))
(cond
((= "acdblwpolyline" plinetype) ;_ 这时 vtxlist 是 x,y 坐标
(progn
(setq vtxcount (/ (length vtxlist) 2))
(repeat vtxcount
(setq
fp (trans (list (nth i vtxlist) (nth (+ i 2) vtxlist) 0)
plname
0
)
) ;_ 同时将点的坐标从 ocs 转换为 wcs
(setq fplist (cons fp fplist))
(setq i (+ i 2))
)
)
)
((= "acdbpolyline" plinetype) ;_ 这时 vtxlist 是 x,y,z 坐标
(progn
(setq vtxcount (/ (length vtxlist) 3))
(repeat vtxcount
(setq fp (trans (list (nth i vtxlist)
(nth (+ i 2) vtxlist)
(nth (+ i 3) vtxlist)
)
plname
0
)
) ;_ 同时将点的坐标从 ocs 转换为 wcs
(setq fplist (cons fp fplist))
(setq i (+ i 3))
)
)
)
)
fplist ;_ 返回值
) ;_ pline_vertexlist 结束
;;; 返回 spline 的拟合点（fitpoint）列表
;;; 参数说明，
;;; splobj -- spline object , 类型为 vla-object .
;;; precision -- 获取 fitpoint 时的精确度。相邻两 fitpoint 将曲线分段。
;;; 分段两端点的曲线长度与直接距离相比，比值不大于 precision 。
;;; 算法说明，
;;; 随着曲线长度增加，计算量也线性增加。
;;; -----
(defun spline_fplist (splobj precision /
list_fps ; list of fitpoints
len_fps ; length of the curve coverd by the fipoint list
wcslist_rmsegs ; end wcs list of remaining segments
lenlist_rmsegs ; length list of remaining segments
fpwcs_segsta ; fitpoint WCS of the current segment start
fpwcs_segend ; fitpoint WCS of the current segment end
per_seg ; percent of the curve coverd by the current segment, ex, 0.5, 0.25, ...
len_seg ; length of current segment
dist_seg ; distance between the current segment's two ends
acprecision ; actual precision
wcs_sta ; wcs of the curve's start point
wcs_end ; wcs of the curve's end point
)
;; 防止精度不合理
;; 太高精度会死机或引起超过值域等错误。
(if (< precision 1.005)
(setq precision 1.005)
)
;; 初始化
(setq list_fps (cons (vlax-curve-getstartPoint splobj) nil)) ;_ 将起点坐标加到 fitpoint 列表中
(setq len_fps 0.0) ;_ list_fps 的覆盖长度为 0.0
(setq wcslist_rmsegs (cons (vlax-curve-getendPoint splobj) nil)) ;_ 将终点坐标加到剩余段终点列表
(setq lenlist_rmsegs
(cons (vlax-curve-getDistAtParam
splobj
(vlax-curve-getEndParam splobj)
)
nil
)
) ;_ 将曲线全长加到剩余段终点列表
;; 获取 list_fps
(while (/= wcslist_rmsegs nil) ;_ 当list_fps未覆盖整条曲线时继续
;;
(setq len_seg (car lenlist_rmsegs))
(setq fpwcs_segsta (car list_fps))
(setq fpwcs_segend (car wcslist_rmsegs))
(setq dist_seg (distance fpwcs_segsta fpwcs_segend))
(setq acprecision
(/ len_seg dist_seg))
(if (> precision acprecision)
;; 精度达到要求时
(progn
(setq list_fps (cons fpwcs_segend list_fps)) ;_ fitpoint 列表增加一个点
(setq len_fps (+ len_fps len_seg)) ;_ fitpoint 覆盖的长度增加
(setq lenlist_rmsegs (cdr lenlist_rmsegs)) ;_ 剩余段列表减少一段
(setq wcslist_rmsegs (cdr wcslist_rmsegs))
)
;; 精度不足时
(progn
(setq len_seg (/ len_seg 2)) ;_ 将当前的段一分为 2
(setq lenlist_rmsegs
(cons len_seg (cons len_seg (cdr lenlist_rmsegs)))
) ;_ 剩余段列表第一段变为两段
(setq wcslist_rmsegs
(cons
(vlax-curve-getPointAtDist splobj (+ len_fps len_seg))
wcslist_rmsegs
)
) ;_ 剩余段终点增加一个
)
)
)
list_fps ;_ 返回值
) ;_ spline_fplist 结束
;;; 返回两个 spline 拟合点列表的合并列表
;;; Combine two FitPoint Lists .
(defun spline_combine2fpl (fpl1 fpl2 / rev1 rev2 mdist ndist fpcount i)
;; 判断最邻近的端点，并决定是否要将拟合点列表返序
;; 第1次
(setq rev1 nil ;_ fpl1 不需反序
rev2 nil ;_ fpl2 不需反序
mdist (distance (last fpl1) (car fpl2)) ;_ 最邻近的端点的距离
)
;; 第2次
(setq ndist (distance (last fpl1) (last fpl2)))
(if (> mdist ndist)
(setq rev1 nil
rev2 1
mdist ndist
)
)
;; 第3次
(setq ndist (distance (car fpl1) (car fpl2)))
(if (> mdist ndist)
(setq rev1 1
rev2 nil
mdist ndist
)
)
;; 第4次
(setq ndist (distance (car fpl1) (last fpl2)))
(if (> mdist ndist)
(setq rev1 1
rev2 1
mdist ndist
)
)
;; 完成两个拟合点列表合并
(if rev1
(setq fpl1 (reverse fpl1))
)
(if rev2
(setq fpl2 (reverse fpl2))
)
(setq fpl1 (append fpl1 fpl2)
fpl2 nil
fpcount (length fpl1)
i 0
)
(repeat fpcount
(setq fpl2 (append fpl2 (nth i fpl1)))
(setq i (+ 1 i))
)
fpl2
)
以下是 VBA 的
' ---------------------------------------
' 合并两条曲线, 合并结果为一条 spline .
' 合并后, 如果曲线两端点距离足够小, 则将此曲线封闭.
' ---------------------------------------
Sub curvecbcl()
Dim curve As AcadObject
Dim sset As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim isnewcurve As Boolean
' 选择两条曲线
If ThisDrawing.SelectionSets.Count < 1 Then
Set sset = ThisDrawing.SelectionSets.Add("ss01")
Else
Set sset = ThisDrawing.SelectionSets.Item("ss01")
End If
sset.Clear
ftype(0) = 0
fdata(0) = "spline,*polyline"
sset.Select acSelectionSetPrevious, ftype, fdata '完成曲线选择(预选方式)
' selset.SelectOnScreen ftype, fdata '完成曲线选择(后选方式)
Select Case sset.Count
Case 2
Set curve = curvecombine(sset, 10) ' 10是合并限距
isnewcurve = True
Case 1
Set curve = sset.Item(0)
isnewcurve = False
Case Else
MsgBox "操作错误: 请选择两条曲线以供连接,或选择一条曲线以供封闭."
End Select
If Not curve Is Nothing Then
curveclose curve, 10, isnewcurve ' 10是闭合限距
End If
End Sub
' -----------------------
' 如果两条曲线端点足够近, 则合并其 fitpoint 生成一条 spline .
' 合并成功后,自动删除原来的两条曲线
Private Function curvecombine(ByRef ss As AcadSelectionSet, ByVal distlimit As Double)
Dim fps1 As Variant ' FitPoints of curve 1
Dim fps1count As Long
Dim fps2 As Variant ' FitPoints of curve 2
Dim fps2count As Long
' ----调用 addspline 所需的参数----------------------
Dim fpsall() As Double ' FitPoints of all the 2 curves,
Dim statan(0 To 2) As Double ' starttangen of the new curve
Dim endtan(0 To 2) As Double 'endtangen of the new curve
' ----以上3个参数类型只能是数组,若改为variant,则绘制不成功-------
Dim tangent As Variant ' 用于辅助处理 statan 和 endtan
Dim distx(0 To 1, 0 To 1) As Double '端点距离
Dim distmin As Variant
distmin = Array(distlimit, 0, 0) '(端点最小距离,曲线1方向标志,曲线2方向标志)
Dim newcurve(0 To 0) As AcadSpline
'合并曲线应满足的条件
If Not (ss.Count = 2) Then
MsgBox "错误原因:选择的不是两条曲线."
Exit Function '只能选择2条曲线
End If
If ss.Item(0).Closed Or ss.Item(0).Closed Then
MsgBox "错误原因:选择的曲线中至少有一条是已经闭合的."
Exit Function '已闭合的不作合并
End If
If UBound(ss.Item(0).IntersectWith(ss.Item(1), acExtendNone)) >= 0 Then
MsgBox "错误原因:选择的两条曲线有交点."
Exit Function '有交点时不作合并
End If
'取得 FitPoints
If UCase(ss.Item(0).ObjectName) Like "*POLYLINE" Then
fps1 = wcscoords_xpl(ss.Item(0)) 'polyline 的 vertex 视作 fitpoint
Else
fps1 = ss.Item(0).FitPoints
End If
fps1count = (UBound(fps1) + 1) / 3
If UCase(ss.Item(1).ObjectName) Like "*POLYLINE" Then
fps2 = wcscoords_xpl(ss.Item(1)) ' polyline 的 vertex 视作 fitpoint
Else
fps2 = ss.Item(1).FitPoints
End If
fps2count = (UBound(fps2) + 1) / 3
' 相近的端点应足够近(不大于distlimit)
Dim pt1sta As Variant
Dim pt1end As Variant
Dim pt2sta As Variant
Dim pt2end As Variant
pt1sta = Array(fps1(0), fps1(1), fps1(2))
pt1end = Array(fps1(UBound(fps1) - 2), fps1(UBound(fps1) - 1), fps1(UBound(fps1) - 0))
pt2sta = Array(fps2(0), fps2(1), fps2(2))
pt2end = Array(fps2(UBound(fps2) - 2), fps2(UBound(fps2) - 1), fps2(UBound(fps2) - 0))
distx(0, 0) = distance(pt1sta, pt2sta)
distx(0, 1) = distance(pt1sta, pt2end)
distx(1, 0) = distance(pt1end, pt2sta)
distx(1, 1) = distance(pt1end, pt2end)
Dim i As Long, j As Long
For i = 0 To 1
For j = 0 To 1
If distx(i, j) <= distmin(0) Then
distmin(0) = distx(i, j)
distmin(1) = (-1) ^ (i + 1) ' = -1 时, 表示要将 fitpoint数组 fps1 反序加入总表
distmin(2) = (-1) ^ j ' = -1 时, 表示要将 fitpoint数组 fps2 反序加入总表
End If
Next
Next ' 至此已知道最靠近的端点是哪两个
If distmin(1) = 0 Then
MsgBox "错误信息: 曲线端点距离太远了, 不作合并."
Exit Function
End If
' 构造 fitpoint 总表(数组)
ReDim fpsall((fps1count + fps2count) * 3 - 1)
Dim firstpt As Long, lastpt As Long
If distmin(1) = -1 Then
firstpt = fps1count - 1
lastpt = 0
Else
firstpt = 0
lastpt = fps1count - 1
End If
j = 0
For i = firstpt To lastpt Step distmin(1)
fpsall(j + 0) = fps1(i * 3 + 0)
fpsall(j + 1) = fps1(i * 3 + 1)
fpsall(j + 2) = fps1(i * 3 + 2)
j = j + 3
Next '至此 fitpoint 总表已构造了一半
If distmin(2) = -1 Then
firstpt = fps2count - 1
lastpt = 0
Else
firstpt = 0
lastpt = fps2count - 1
End If
For i = firstpt To lastpt Step distmin(2)
fpsall(j + 0) = fps2(i * 3 + 0)
fpsall(j + 1) = fps2(i * 3 + 1)
fpsall(j + 2) = fps2(i * 3 + 2)
j = j + 3
Next '至此 fitpoint 总表已构造完成
' 确定 fitpoint 总表两端点的 tangent 值
' 先确定起点的, 即 statan .
If UCase(ss.Item(0).ObjectName) Like "*SPLINE" Then
' 对 spline 保持原来的 tangent 值, 只调整方向.
If distmin(1) = -1 Then
tangent = ss.Item(0).EndTangent
statan(0) = -tangent(0): statan(1) = -tangent(1): statan(2) = -tangent(2)
Else
tangent = ss.Item(0).StartTangent
statan(0) = tangent(0): statan(1) = tangent(1): statan(2) = tangent(2)
End If ' 对未连接的端点
Else
' 对 polyline 使用两点射线为 tangen.
statan(0) = fpsall(3) - fpsall(0): statan(1) = fpsall(4) - fpsall(1): statan(2) = fpsall(5) - fpsall(2)
tangent = Abs(statan(0))
For i = 1 To 2
If Abs(statan(i)) > tangent Then
tangent = Abs(statan(i))
End If
Next
For i = 0 To 2
statan(i) = statan(i) / tangent
Next
End If
' 再确定终点的, 即 endtan
If UCase(ss.Item(1).ObjectName) Like "*SPLINE" Then
' 对 spline 保持原来的 tangent 值, 只调整方向.
If distmin(2) = -1 Then
tangent = ss.Item(1).StartTangent
endtan(0) = -tangent(0): endtan(1) = -tangent(1): endtan(2) = -tangent(2)
Else
tangent = ss.Item(1).EndTangent
endtan(0) = tangent(0): endtan(1) = tangent(1): endtan(2) = tangent(2)
End If ' 对未连接的端点
Else
' 对 polyline 使用两点射线为 tangen , 并确定方向.
endtan(0) = fpsall((fps1count + fps2count - 1) * 3 + 0) - fpsall((fps1count + fps2count - 2) * 3 + 0)
endtan(1) = fpsall((fps1count + fps2count - 1) * 3 + 1) - fpsall((fps1count + fps2count - 2) * 3 + 1)
endtan(2) = fpsall((fps1count + fps2count - 1) * 3 + 2) - fpsall((fps1count + fps2count - 2) * 3 + 2)
tangent = Abs(endtan(0))
For i = 1 To 2
If Abs(endtan(i)) > tangent Then
tangent = Abs(endtan(i))
End If
Next
For i = 0 To 2
endtan(i) = endtan(i) / tangent
Next
End If
' 删除原有曲线
ss.Erase
ss.Clear
' 生成新曲线(spline)
Set newcurve(0) = ThisDrawing.ModelSpace.AddSpline(fpsall, statan, endtan)
' ThisDrawing.Regen (True)
' 返回曲线对象
Set curvecombine = newcurve(0)
End Function
' ---------------------------------
' 一条曲线两端足够近, 则将此曲线闭合.
Private Sub curveclose(ByRef curve As AcadObject, ByVal distlimit As Double, isnewcurve As Boolean)
' curve 为需封闭的曲线
' distlimit 为封闭限制距离(端点距离不可大于此值)
' isnewcurve 表示曲线是新生成的(选择方法不同).
Dim cmdtxt As String
Dim fps As Variant, fpscount As Long
Dim ptsta As Variant, ptend As Variant
If curve.Closed Then
ThisDrawing.Utility.Prompt "提示: 曲线原已闭合"
Exit Sub '已闭合的直接退出
End If
'取得 FitPoints
If UCase(curve.ObjectName) Like "*POLYLINE" Then
fps = wcscoords_xpl(curve) 'polyline 的 vertex 视作 fitpoint
Else
fps = curve.FitPoints
End If
fpscount = (UBound(fps) + 1) / 3
ptsta = Array(fps(0), fps(1), fps(2))
ptend = Array(fps((fpscount - 1) * 3 + 0), fps((fpscount - 1) * 3 + 1), fps((fpscount - 1) * 3 + 2))
If distance(ptsta, ptend) <= distlimit Then
' 通过命令行调用 lisp 指令, 从而利用 autocad 的 splinedit 指令,(一时找不到更好的方法).
If isnewcurve Then
cmdtxt = "(command " & """splinedit""" & " " & "(ssget ""l"")" & " " & """C""" & " """" )" & " "
Else
cmdtxt = "(command " & """splinedit""" & " " & "(ssget ""p"")" & " " & """C""" & " """" )" & " "
End If
ThisDrawing.SendCommand cmdtxt
ThisDrawing.Regen (True)
End If
End Sub
' 将一条 Xpolyline 的全部顶点坐标由OCS转换为WCS
Function wcscoords_xpl(ByRef xpl As AcadObject)
Dim ub_ocs As Integer 'OCS项点列表的上界
Dim ptcount As Integer '顶点的个数
Dim wcspt As Variant
Dim ocspt(0 To 2) As Double, _
ocspt_tmp As Variant
Dim wcspts() As Double
ub_ocs = UBound(xpl.Coordinates)
Select Case UCase(xpl.ObjectName)
Case "ACDBPOLYLINE"
ptcount = (ub_ocs + 1) / 2
Case "ACDBLWPOLYLINE"
ptcount = (ub_ocs + 1) / 2
Case Else
Exit Function
End Select
ReDim wcspts(0 To ptcount * 3 - 1) As Double
Dim i As Integer
For i = 0 To ptcount - 1
ocspt_tmp = xpl.Coordinate(i)
ocspt(0) = ocspt_tmp(0)
ocspt(1) = ocspt_tmp(1)
ocspt(2) = xpl.Elevation
wcspt = ThisDrawing.Utility.TranslateCoordinates(ocspt, acOCS, acWorld, False, xpl.Normal)
wcspts(i * 3 + 0) = wcspt(0)
wcspts(i * 3 + 1) = wcspt(1)
wcspts(i * 3 + 2) = wcspt(2)
Next
wcscoords_xpl = wcspts
End Function
' 计算两点之间距离
Function distance(ByVal sp As Variant, ByVal ep As Variant) As Double
Dim x As Double
Dim y As Double
Dim z As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)
distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

;;; 环境初始化 
(vl-load-com) ;_ 确保加载了 activex 支持 
 
;;; c:ccc 
;;; 将相邻的两条曲线合并成一条曲线， 
;;; 同时如果一条曲线的两端点相邻则将此曲线封闭。 
;;; 用户可手工选择两条曲线（spline,*polyline），或一条曲线，先选后选均可。 
(defun c:ccc (/                   comclosedist        fpprecision  selsets 
              selset           filtertype        filterdata   curve1 
              fplist1           curve2        fplist2             fparray 
              statan           endtan        newcurve     newcurvearray 
             ) 
  (setq        *thisdrawing* (vla-get-activedocument (vlax-get-acad-object)) 
        *modelspace*  (vla-get-ModelSpace *thisdrawing*) 
  ) 
  (setq        comclosedist 
         10 ;_ 小于这个距离才合并或封闭 
        fpprecision 
         1.01 ;_ 获取 fitpoint 时使用的精度 
        filtertype 
         0 ;_ 0 在DXF格式中是 图元类型的组码 
        filterdata 
         "spline,*polyline" ;_ 图元类型的值 
        newcurve nil 
  ) 
  ;; 曲线选择，一条或两条 
  (setq selsets (vla-get-selectionsets *thisdrawing*)) 
  (if (= (vla-get-count selsets) 0) 
    (vla-add selsets (vlax-make-variant "ss1")) 
  ) 
  (setq selset (vla-item selsets 0)) 
  (vla-clear selset) 
  (vla-select 
    selset 
    acSelectionSetPrevious 
    filtertype 
    filterdata 
  ) 
  (if (= 0 (vla-get-count selset)) 
    (progn 
      (prompt 
        "\n请选择两条相邻的 spline,*polyline <退出>:" 
      ) 
                                        ; (vla-SelectOnScreen selset filtertype filterdata) 
      (vla-SelectOnScreen selset) 
    ) 
  ) 
  ;; 进行曲线合并 
  (if (= 2 (vla-get-count selset)) 
    (progn 
      ;; 获取第1条曲线的拟合点列表 fitpoints 。 
      (setq curve1 (vla-item selset 0)) 
      (if (= "acdbspline" (strcase (vla-get-ObjectName curve1) t)) 
        (setq fplist1 (spline_fplist curve1 fpprecision)) ;_ 对 spline ，直接或间接取它的 fitpoint 。 
        (setq fplist1 (pline_vertexlist curve1)) ;_ 对 *polyline ，取其 vertex 为 fitpoint 。 
      ) 
      ;; 获取第2条曲线的拟合点列表 fitpoints 。 
      (setq curve2 (vla-item selset 1)) 
      (if (= "acdbspline" (strcase (vla-get-ObjectName curve2) t)) 
        (setq fplist2 (spline_fplist curve2 fpprecision)) ;_ 对 spline ，直接或间接取它的 fitpoint 。 
        (setq fplist2 (pline_vertexlist curve2)) ;_ 对 *polyline ，取其 vertex 为 fitpoint 。 
      ) 
      ;; 删除旧曲线 
      (vla-delete curve1) 
      (vla-delete curve2) 
      ;; 合并两个fplist生成新曲线 
      (setq fplist1 (spline_combine2fpl fplist1 fplist2)) 
      (setq fparray (vlax-make-safearray 
                      vlax-vbdouble 
                      (cons 0 (1- (length fplist1))) 
                    ) 
      ) 
      (vlax-safearray-fill fparray fplist1) 
      (setq 
        statan (setq 
                 endtan        (vlax-make-safearray vlax-vbDouble '(0 . 2)) 
               ) 
      ) 
      (setq newcurve (vla-addspline *modelspace* fparray statan endtan)) 
      ;; 将新曲线的 fitpoint 都 purge 掉，以减少图形数据量。 
;;;      (vla-PurgeFitData newcurve) 
      ;; 将曲线加入 selset ，以供进一步处理 
      (vla-clear selset) 
      (setq newcurvearray (vlax-make-safearray vlax-vbObject '(0 . 0))) 
      (vlax-safearray-fill newcurvearray (list newcurve)) 
      (vla-additems selset newcurvearray) 
    ) 
  ) 
  ;; 将曲线封闭 
  (if (= 1 (vla-get-count selset)) 
    (progn 
      (setq newcurve (vla-item selset 0)) 
      (if (> comclosedist 
             (distance (vlax-curve-getstartpoint newcurve) 
                       (vlax-curve-getEndPoint newcurve) 
             ) 
          ) 
        (progn 
          ;; 用 ssadd 创建的 selection set , 才适用于命令行。 
          ;; selset 的类型是 VLA-Object acadSelectionSet , 不适用于命令行。 
          ;; 两种选择集不能互相转换：(vlax-vla-object->ename selset) 返回 nil 。 
          (setq lspselset (ssadd (vlax-vla-object->ename newcurve))) 
          ;; 调用acad命令行 
          (command "splinedit" lspselset "c" "" "") 
        ) 
      ) 
    ) 
  ) 
  ;; 结束 
  (princ) 
) 
 
;;; 返回 *polyline 的顶点（vertex）列表 
;;; 参数说明， 
;;; plobj -- polyline object , 类型为 vla-object . 
;;; ----- 
(defun pline_vertexlist 
       (plobj / plname vtxlist fp fplist plinetype vtxcount i) 
  (setq        plname (vlax-vla-object->ename plobj) 
        fplist nil 
        i      0 
  ) 
  (setq vtxlist (vlax-safearray->list (vla-get-coordinates plobj))) 
  (setq plinetype (strcase (vla-get-objectname plobj) t)) 
  (cond 
    ((= "acdblwpolyline" plinetype) ;_ 这时 vtxlist 是 x,y 坐标 
     (progn 
       (setq vtxcount (/ (length vtxlist) 2)) 
       (repeat vtxcount 
         (setq 
           fp (trans (list (nth i vtxlist) (nth (+ i 2) vtxlist) 0) 
                     plname 
                     0 
              ) 
         ) ;_ 同时将点的坐标从 ocs 转换为 wcs 
         (setq fplist (cons fp fplist)) 
         (setq i (+ i 2)) 
       ) 
     ) 
    ) 
    ((= "acdbpolyline" plinetype) ;_ 这时 vtxlist 是 x,y,z 坐标 
     (progn 
       (setq vtxcount (/ (length vtxlist) 3)) 
       (repeat vtxcount 
         (setq fp (trans (list (nth i vtxlist) 
                               (nth (+ i 2) vtxlist) 
                               (nth (+ i 3) vtxlist) 
                         ) 
                         plname 
                         0 
                  ) 
         ) ;_ 同时将点的坐标从 ocs 转换为 wcs 
         (setq fplist (cons fp fplist)) 
         (setq i (+ i 3)) 
       ) 
     ) 
    ) 
  ) 
  fplist ;_ 返回值 
) ;_ pline_vertexlist 结束 
 
;;; 返回 spline 的拟合点（fitpoint）列表 
;;; 参数说明， 
;;; splobj -- spline object , 类型为 vla-object . 
;;; precision -- 获取 fitpoint 时的精确度。相邻两 fitpoint 将曲线分段。 
;;;              分段两端点的曲线长度与直接距离相比，比值不大于 precision 。 
;;; 算法说明， 
;;; 随着曲线长度增加，计算量也线性增加。 
;;; ----- 
(defun spline_fplist (splobj             precision            / 
                      list_fps                ; list of fitpoints 
                      len_fps                ; length of the curve coverd by the fipoint list 
                      wcslist_rmsegs        ; end wcs list of remaining segments 
                      lenlist_rmsegs        ; length list of remaining segments 
                      fpwcs_segsta        ; fitpoint WCS of the current segment start 
                      fpwcs_segend        ; fitpoint WCS of the current segment end 
                      per_seg                ; percent of the curve coverd by the current segment, ex, 0.5, 0.25, ... 
                      len_seg                ; length of current segment 
                      dist_seg                ; distance between the current segment's two ends 
                      acprecision        ; actual precision 
                      wcs_sta                ; wcs of the curve's start point 
                      wcs_end                ; wcs of the curve's end point 
                     ) 
  ;; 防止精度不合理 
  ;; 太高精度会死机或引起超过值域等错误。 
  (if (< precision 1.005) 
    (setq precision 1.005) 
  ) 
  ;; 初始化 
  (setq list_fps (cons (vlax-curve-getstartPoint splobj) nil)) ;_ 将起点坐标加到 fitpoint 列表中 
  (setq len_fps 0.0) ;_ list_fps 的覆盖长度为 0.0 
  (setq wcslist_rmsegs (cons (vlax-curve-getendPoint splobj) nil)) ;_ 将终点坐标加到 剩余段终点列表 
  (setq        lenlist_rmsegs 
         (cons (vlax-curve-getDistAtParam 
                 splobj 
                 (vlax-curve-getEndParam splobj) 
               ) 
               nil 
         ) 
  ) ;_ 将曲线全长加到 剩余段终点列表 
  ;; 获取 list_fps 
  (while (/= wcslist_rmsegs nil) ;_ 当list_fps未覆盖整条曲线时继续 
    ;; 
    (setq len_seg (car lenlist_rmsegs)) 
    (setq fpwcs_segsta (car list_fps)) 
    (setq fpwcs_segend (car wcslist_rmsegs)) 
    (setq dist_seg (distance fpwcs_segsta fpwcs_segend)) 
    (setq acprecision 
           (/ len_seg dist_seg)) 
    (if        (> precision acprecision) 
      ;; 精度达到要求时 
      (progn 
        (setq list_fps (cons fpwcs_segend list_fps)) ;_ fitpoint 列表增加一个点 
        (setq len_fps (+ len_fps len_seg)) ;_ fitpoint 覆盖的长度增加 
        (setq lenlist_rmsegs (cdr lenlist_rmsegs)) ;_ 剩余段列表减少一段 
        (setq wcslist_rmsegs (cdr wcslist_rmsegs)) 
      ) 
      ;; 精度不足时 
      (progn 
        (setq len_seg (/ len_seg 2)) ;_ 将当前的段一分为 2 
        (setq lenlist_rmsegs 
               (cons len_seg (cons len_seg (cdr lenlist_rmsegs))) 
        ) ;_ 剩余段列表第一段变为两段 
        (setq wcslist_rmsegs 
               (cons 
                 (vlax-curve-getPointAtDist splobj (+ len_fps len_seg)) 
                 wcslist_rmsegs 
               ) 
        ) ;_ 剩余段终点增加一个 
 
      ) 
    ) 
  ) 
  list_fps ;_ 返回值 
) ;_ spline_fplist 结束 
 
;;; 返回两个 spline 拟合点列表的合并列表 
;;; Combine two FitPoint Lists . 
(defun spline_combine2fpl (fpl1 fpl2 / rev1 rev2 mdist ndist fpcount i) 
  ;; 判断最邻近的端点，并决定是否要将拟合点列表返序 
  ;; 第1次 
  (setq        rev1  nil ;_ fpl1 不需反序 
        rev2  nil ;_ fpl2 不需反序 
        mdist (distance (last fpl1) (car fpl2)) ;_ 最邻近的端点的距离 
  ) 
  ;; 第2次 
  (setq ndist (distance (last fpl1) (last fpl2))) 
  (if (> mdist ndist) 
    (setq rev1        nil 
          rev2        1 
          mdist        ndist 
    ) 
  ) 
  ;; 第3次 
  (setq ndist (distance (car fpl1) (car fpl2))) 
  (if (> mdist ndist) 
    (setq rev1        1 
          rev2        nil 
          mdist        ndist 
    ) 
  ) 
  ;; 第4次 
  (setq ndist (distance (car fpl1) (last fpl2))) 
  (if (> mdist ndist) 
    (setq rev1        1 
          rev2        1 
          mdist        ndist 
    ) 
  ) 
  ;; 完成两个拟合点列表合并 
  (if rev1 
    (setq fpl1 (reverse fpl1)) 
  ) 
  (if rev2 
    (setq fpl2 (reverse fpl2)) 
  ) 
  (setq        fpl1        (append fpl1 fpl2) 
        fpl2        nil 
        fpcount        (length fpl1) 
        i        0 
  ) 
  (repeat fpcount 
    (setq fpl2 (append fpl2 (nth i fpl1))) 
    (setq i (+ 1 i)) 
  ) 
  fpl2 
) 
 
 
以下是 VBA 的 
' --------------------------------------- 
' 合并两条曲线, 合并结果为一条 spline . 
' 合并后, 如果曲线两端点距离足够小, 则将此曲线封闭. 
' --------------------------------------- 
Sub curvecbcl() 
    Dim curve As AcadObject 
    Dim sset As AcadSelectionSet 
    Dim ftype(0) As Integer 
    Dim fdata(0) As Variant 
    Dim isnewcurve As Boolean 
    ' 选择两条曲线 
    If ThisDrawing.SelectionSets.Count < 1 Then 
        Set sset = ThisDrawing.SelectionSets.Add("ss01") 
    Else 
        Set sset = ThisDrawing.SelectionSets.Item("ss01") 
    End If 
    sset.Clear 
    ftype(0) = 0 
    fdata(0) = "spline,*polyline" 
    sset.Select acSelectionSetPrevious, ftype, fdata   '完成曲线选择(预选方式) 
    ' selset.SelectOnScreen ftype, fdata  '完成曲线选择(后选方式) 
    Select Case sset.Count 
    Case 2 
        Set curve = curvecombine(sset, 10)    ' 10是合并限距 
        isnewcurve = True 
    Case 1 
        Set curve = sset.Item(0) 
        isnewcurve = False 
    Case Else 
        MsgBox "操作错误: 请选择两条曲线以供连接,或选择一条曲线以供封闭." 
    End Select 
    If Not curve Is Nothing Then 
        curveclose curve, 10, isnewcurve        ' 10是闭合限距 
    End If 
End Sub 
 
 
' ----------------------- 
' 如果两条曲线端点足够近, 则合并其 fitpoint 生成一条 spline . 
' 合并成功后,自动删除原来的两条曲线 
Private Function curvecombine(ByRef ss As AcadSelectionSet, ByVal distlimit As Double) 
    Dim fps1 As Variant ' FitPoints of curve 1 
    Dim fps1count As Long 
    Dim fps2 As Variant ' FitPoints of curve 2 
    Dim fps2count As Long 
    ' ----调用 addspline 所需的参数---------------------- 
    Dim fpsall() As Double   ' FitPoints of all the 2 curves, 
    Dim statan(0 To 2) As Double  ' starttangen of the new curve 
    Dim endtan(0 To 2) As Double 'endtangen of the new curve 
    ' ----以上3个参数类型只能是数组,若改为variant,则绘制不成功------- 
    Dim tangent As Variant   ' 用于辅助处理 statan 和 endtan 
    Dim distx(0 To 1, 0 To 1) As Double   '端点距离 
    Dim distmin As Variant 
    distmin = Array(distlimit, 0, 0) '(端点最小距离,曲线1方向标志,曲线2方向标志) 
    Dim newcurve(0 To 0) As AcadSpline 
    '合并曲线应满足的条件 
    If Not (ss.Count = 2) Then 
        MsgBox "错误原因:选择的不是两条曲线." 
        Exit Function '只能选择2条曲线 
    End If 
    If ss.Item(0).Closed Or ss.Item(0).Closed Then 
        MsgBox "错误原因:选择的曲线中至少有一条是已经闭合的." 
        Exit Function '已闭合的不作合并 
    End If 
    If UBound(ss.Item(0).IntersectWith(ss.Item(1), acExtendNone)) >= 0 Then 
        MsgBox "错误原因:选择的两条曲线有交点." 
        Exit Function '有交点时不作合并 
    End If 
    '取得 FitPoints 
    If UCase(ss.Item(0).ObjectName) Like "*POLYLINE" Then 
        fps1 = wcscoords_xpl(ss.Item(0))    'polyline 的 vertex 视作 fitpoint 
    Else 
        fps1 = ss.Item(0).FitPoints 
    End If 
    fps1count = (UBound(fps1) + 1) / 3 
    If UCase(ss.Item(1).ObjectName) Like "*POLYLINE" Then 
        fps2 = wcscoords_xpl(ss.Item(1))    ' polyline 的 vertex 视作 fitpoint 
    Else 
        fps2 = ss.Item(1).FitPoints 
    End If 
    fps2count = (UBound(fps2) + 1) / 3 
    ' 相近的端点应足够近(不大于distlimit) 
    Dim pt1sta As Variant 
    Dim pt1end As Variant 
    Dim pt2sta As Variant 
    Dim pt2end As Variant 
    pt1sta = Array(fps1(0), fps1(1), fps1(2)) 
    pt1end = Array(fps1(UBound(fps1) - 2), fps1(UBound(fps1) - 1), fps1(UBound(fps1) - 0)) 
    pt2sta = Array(fps2(0), fps2(1), fps2(2)) 
    pt2end = Array(fps2(UBound(fps2) - 2), fps2(UBound(fps2) - 1), fps2(UBound(fps2) - 0)) 
    distx(0, 0) = distance(pt1sta, pt2sta) 
    distx(0, 1) = distance(pt1sta, pt2end) 
    distx(1, 0) = distance(pt1end, pt2sta) 
    distx(1, 1) = distance(pt1end, pt2end) 
    Dim i As Long, j As Long 
    For i = 0 To 1 
        For j = 0 To 1 
            If distx(i, j) <= distmin(0) Then 
                distmin(0) = distx(i, j) 
                distmin(1) = (-1) ^ (i + 1) ' = -1 时, 表示要将 fitpoint数组 fps1 反序加入总表 
                distmin(2) = (-1) ^ j       ' = -1 时, 表示要将 fitpoint数组 fps2 反序加入总表 
            End If 
        Next 
    Next    ' 至此已知道最靠近的端点是哪两个 
    If distmin(1) = 0 Then 
        MsgBox "错误信息: 曲线端点距离太远了, 不作合并." 
        Exit Function 
    End If 
    ' 构造 fitpoint 总表(数组) 
    
    ReDim fpsall((fps1count + fps2count) * 3 - 1) 
    
    Dim firstpt As Long, lastpt As Long 
    If distmin(1) = -1 Then 
        firstpt = fps1count - 1 
        lastpt = 0 
    Else 
        firstpt = 0 
        lastpt = fps1count - 1 
    End If 
    j = 0 
    For i = firstpt To lastpt Step distmin(1) 
         fpsall(j + 0) = fps1(i * 3 + 0) 
         fpsall(j + 1) = fps1(i * 3 + 1) 
         fpsall(j + 2) = fps1(i * 3 + 2) 
         j = j + 3 
    Next        '至此 fitpoint 总表已构造了一半 
    If distmin(2) = -1 Then 
        firstpt = fps2count - 1 
        lastpt = 0 
    Else 
        firstpt = 0 
        lastpt = fps2count - 1 
    End If 
    For i = firstpt To lastpt Step distmin(2) 
         fpsall(j + 0) = fps2(i * 3 + 0) 
         fpsall(j + 1) = fps2(i * 3 + 1) 
         fpsall(j + 2) = fps2(i * 3 + 2) 
         j = j + 3 
    Next        '至此 fitpoint 总表已构造完成 
    ' 确定 fitpoint 总表两端点的 tangent 值 
    ' 先确定起点的, 即 statan . 
    If UCase(ss.Item(0).ObjectName) Like "*SPLINE" Then 
        ' 对 spline 保持原来的 tangent 值, 只调整方向. 
        If distmin(1) = -1 Then 
            tangent = ss.Item(0).EndTangent 
            statan(0) = -tangent(0): statan(1) = -tangent(1): statan(2) = -tangent(2) 
        Else 
            tangent = ss.Item(0).StartTangent 
            statan(0) = tangent(0): statan(1) = tangent(1): statan(2) = tangent(2) 
        End If  ' 对未连接的端点 
    Else 
        ' 对 polyline 使用两点射线为 tangen. 
        statan(0) = fpsall(3) - fpsall(0): statan(1) = fpsall(4) - fpsall(1): statan(2) = fpsall(5) - fpsall(2) 
        tangent = Abs(statan(0)) 
        For i = 1 To 2 
            If Abs(statan(i)) > tangent Then 
                tangent = Abs(statan(i)) 
            End If 
        Next 
        For i = 0 To 2 
            statan(i) = statan(i) / tangent 
        Next 
    End If 
    ' 再确定终点的, 即 endtan 
    If UCase(ss.Item(1).ObjectName) Like "*SPLINE" Then 
        ' 对 spline 保持原来的 tangent 值, 只调整方向. 
        If distmin(2) = -1 Then 
            tangent = ss.Item(1).StartTangent 
            endtan(0) = -tangent(0): endtan(1) = -tangent(1): endtan(2) = -tangent(2) 
        Else 
            tangent = ss.Item(1).EndTangent 
            endtan(0) = tangent(0): endtan(1) = tangent(1): endtan(2) = tangent(2) 
        End If  ' 对未连接的端点 
    Else 
        ' 对 polyline 使用两点射线为 tangen , 并确定方向. 
        endtan(0) = fpsall((fps1count + fps2count - 1) * 3 + 0) - fpsall((fps1count + fps2count - 2) * 3 + 0) 
        endtan(1) = fpsall((fps1count + fps2count - 1) * 3 + 1) - fpsall((fps1count + fps2count - 2) * 3 + 1) 
        endtan(2) = fpsall((fps1count + fps2count - 1) * 3 + 2) - fpsall((fps1count + fps2count - 2) * 3 + 2) 
        tangent = Abs(endtan(0)) 
        For i = 1 To 2 
            If Abs(endtan(i)) > tangent Then 
                tangent = Abs(endtan(i)) 
            End If 
        Next 
        For i = 0 To 2 
            endtan(i) = endtan(i) / tangent 
        Next 
    End If 
    
    ' 删除原有曲线 
    ss.Erase 
    ss.Clear 
    ' 生成新曲线(spline) 
    Set newcurve(0) = ThisDrawing.ModelSpace.AddSpline(fpsall, statan, endtan) 
    ' ThisDrawing.Regen (True) 
    ' 返回曲线对象 
    Set curvecombine = newcurve(0) 
End Function 
 
' --------------------------------- 
' 一条曲线两端足够近, 则将此曲线闭合. 
Private Sub curveclose(ByRef curve As AcadObject, ByVal distlimit As Double, isnewcurve As Boolean) 
    ' curve 为需封闭的曲线 
    ' distlimit 为封闭限制距离(端点距离不可大于此值) 
    ' isnewcurve 表示曲线是新生成的(选择方法不同). 
    Dim cmdtxt As String 
    Dim fps As Variant, fpscount As Long 
    Dim ptsta As Variant, ptend As Variant 
    If curve.Closed Then 
        ThisDrawing.Utility.Prompt "提示: 曲线原已闭合" 
        Exit Sub '已闭合的直接退出 
    End If 
     '取得 FitPoints 
    If UCase(curve.ObjectName) Like "*POLYLINE" Then 
        fps = wcscoords_xpl(curve)    'polyline 的 vertex 视作 fitpoint 
    Else 
        fps = curve.FitPoints 
    End If 
    fpscount = (UBound(fps) + 1) / 3 
    ptsta = Array(fps(0), fps(1), fps(2)) 
    ptend = Array(fps((fpscount - 1) * 3 + 0), fps((fpscount - 1) * 3 + 1), fps((fpscount - 1) * 3 + 2)) 
    If distance(ptsta, ptend) <= distlimit Then 
        ' 通过命令行调用 lisp 指令, 从而利用 autocad 的 splinedit 指令,(一时找不到更好的方法). 
        If isnewcurve Then 
            cmdtxt = "(command " & """splinedit""" & " " & "(ssget ""l"")" & " " & """C""" & " """" )" & " " 
        Else 
            cmdtxt = "(command " & """splinedit""" & " " & "(ssget ""p"")" & " " & """C""" & " """" )" & " " 
        End If 
        ThisDrawing.SendCommand cmdtxt 
        ThisDrawing.Regen (True) 
    End If 
End Sub 
' 将一条 Xpolyline 的全部顶点坐标由OCS转换为WCS 
Function wcscoords_xpl(ByRef xpl As AcadObject) 
    Dim ub_ocs As Integer   'OCS项点列表的上界 
    Dim ptcount As Integer  '顶点的个数 
    Dim wcspt As Variant 
    Dim ocspt(0 To 2) As Double, _ 
        ocspt_tmp As Variant 
    Dim wcspts() As Double 
    ub_ocs = UBound(xpl.Coordinates) 
    Select Case UCase(xpl.ObjectName) 
        Case "ACDBPOLYLINE" 
            ptcount = (ub_ocs + 1) / 2 
        Case "ACDBLWPOLYLINE" 
            ptcount = (ub_ocs + 1) / 2 
        Case Else 
            Exit Function 
    End Select 
    ReDim wcspts(0 To ptcount * 3 - 1) As Double 
    Dim i As Integer 
    For i = 0 To ptcount - 1 
        ocspt_tmp = xpl.Coordinate(i) 
        ocspt(0) = ocspt_tmp(0) 
        ocspt(1) = ocspt_tmp(1) 
        ocspt(2) = xpl.Elevation 
        wcspt = ThisDrawing.Utility.TranslateCoordinates(ocspt, acOCS, acWorld, False, xpl.Normal) 
        wcspts(i * 3 + 0) = wcspt(0) 
        wcspts(i * 3 + 1) = wcspt(1) 
        wcspts(i * 3 + 2) = wcspt(2) 
    Next 
    wcscoords_xpl = wcspts 
End Function 
 
' 计算两点之间距离 
Function distance(ByVal sp As Variant, ByVal ep As Variant) As Double 
    Dim x As Double 
    Dim y As Double 
    Dim z As Double 
    x = sp(0) - ep(0) 
    y = sp(1) - ep(1) 
    z = sp(2) - ep(2) 
    distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2)) 
End Function

MJJ3468 · 发表于 2005-8-12 09:48:13

好位置
Vlisp,如何加载，我用AP加载后执行ccc，出现如下错误：
错误 : ActiveX 服务器返回错误: 未知名称: Coordinates

JOSDENNIS · 发表于 2005-8-12 14:07:52

經測試LISP 部分 selsets 變量由於在使用的過程中. 如果用戶用完undo回去. 再用這個程序時selsets變量內部的內容沒有清空, 使用就出錯了.
程序修改建議如用vla難解決可改用lisp的ssget涵數代替. 這樣可大大的減少出錯.

;;; ?境初始化
(vl-load-com) ;_ 确保加?了 activex 支持

;;; c:ccc
;;; 將相今的兩條曲線合并成一條曲線，
;;; 同時如果一條曲線的兩端點相鄰則將此曲線封閉。
;;; 用戶可手工選擇兩曲線（spline,*polyline），或一條曲線，先選后選均可。
(defun c:ccc (/ comclosedist fpprecision selsets
 selset filtertype filterdata curve1
 fplist1 curve2 fplist2 fparray
 statan endtan newcurve newcurvearray
 )
 (setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
*modelspace* (vla-get-ModelSpace *thisdrawing*)
 )
 (setq comclosedist 10 ;_ 小于這個距离才合并或封閉
fpprecision 1.01 ;_ ?取 fitpoint ?使用的精度
filtertype 0 ;_ 0 在DXF格式中是圖元類型的組碼
filterdata "spline,*polyline" ;_ 圖元類型的值
newcurve nil
 )
 ;; 曲線選擇,一條或兩條
 (setq selsets (ssget '((0 . "SPLINE,*POLYLINE"))))
 ;|(setq selsets (vla-get-selectionsets *thisdrawing*))
 (if (= (vla-get-count selsets) 0)
(vla-add selsets (vlax-make-variant "ss1"))
 )
 (vla-update selset)
 (setq selset (vla-item selsets 0))
 (vla-clear selset)
;;; (vla-select selset acSelectionSetPrevious filtertype filterdata)
 (if (= 0 (vla-get-count selset))
(progn
 (prompt"\n請選擇兩條相鄰的 spline,*polyline <退出>:")
 ; (vla-SelectOnScreen selset filtertype filterdata)
 (vla-SelectOnScreen selset)
)
 )|;
 ;; 進行曲線合并
 (if (= 2 (SSLENGTH selsets));(= 2 (vla-get-count selset))
(progn
 ;; 選取第1條曲線的合點列表 fitpoints 。
 ;;;(setq curve1 (vla-item selset 0))
 (setq curve1 (VLAX-ENAME->VLA-OBJECT (SSNAME selsets 0 ))); (vla-item selset 0))
 (if (= "acdbspline" (strcase (vla-get-ObjectName curve1) t))
(setq fplist1 (spline_fplist curve1 fpprecision)) ;_ 對 spline ，直接或?接取它的 fitpoint 。
(setq fplist1 (pline_vertexlist curve1)) ;_ 對 *polyline ，取其 vertex 為 fitpoint 。
 )
 ;; 選取第2條曲線的合點列表 fitpoints 。
 ;;;(setq curve2 (vla-item selset 1))
 (setq curve2 (VLAX-ENAME->VLA-OBJECT (SSNAME selsets 1)))
 (if (= "acdbspline" (strcase (vla-get-ObjectName curve2) t))
(setq fplist2 (spline_fplist curve2 fpprecision)) ;_ ? spline ，直接或?接取它的 fitpoint 。
(setq fplist2 (pline_vertexlist curve2)) ;_ ? *polyline ，取其 vertex ? fitpoint 。
 )
 ;;刪除曲線
 (vla-delete curve1)
 (vla-delete curve2)
 ;; 合并點表fplist生成新曲線
 (setq fplist1 (spline_combine2fpl fplist1 fplist2))
 (setq fparray (vlax-make-safearray
 vlax-vbdouble
 (cons 0 (1- (length fplist1)))
 )
 )
 (vlax-safearray-fill fparray fplist1)
 (setq
statan (setq
 endtan (vlax-make-safearray vlax-vbDouble '(0 . 2))
 )
 )
 (setq newcurve (vla-addspline *modelspace* fparray statan endtan))
 ;; ?新曲?的 fitpoint 都 purge 掉，以?少?形?据量。
;;; (vla-PurgeFitData newcurve)
 ;; ?曲?加入 selset ，以供?一步?理
 (vla-clear selset)
 (setq newcurvearray (vlax-make-safearray vlax-vbObject '(0 . 0)))
 (vlax-safearray-fill newcurvearray (list newcurve))
 (vla-additems selset newcurvearray)
)
 )
 ;; ?曲?封?
 (if (= 1 (vla-get-count selset))
(progn
 (setq newcurve (vla-item selset 0))
 (if (> comclosedist
 (distance (vlax-curve-getstartpoint newcurve)
 (vlax-curve-getEndPoint newcurve)
 )
 )
(progn
 ;; 用 ssadd ?建的 selection set , 才适用于命令行。
 ;; selset 的?型是 VLA-Object acadSelectionSet , 不适用于命令行。
 ;; ?种??集不能互相??：(vlax-vla-object->ename selset) 返回 nil 。
 (setq lspselset (ssadd (vlax-vla-object->ename newcurve)))
 ;; ?用acad命令行
 (command "splinedit" lspselset "c" "" "")
)
 )
)
 )
 ;; ?束
 (princ)
)

;;; 返回 *polyline 的??（vertex）列表
;;; ???明，
;;; plobj -- polyline object , ?型? vla-object .
;;; -----
(defun pline_vertexlist
 (plobj / plname vtxlist fp fplist plinetype vtxcount i)
 (setq plname (vlax-vla-object->ename plobj)
fplist nil
i 0
 )
 (setq vtxlist (vlax-safearray->list (vla-get-coordinates plobj)))
 (setq plinetype (strcase (vla-get-objectname plobj) t))
 (cond
((= "acdblwpolyline" plinetype) ;_ ?? vtxlist 是 x,y 坐?
 (progn
 (setq vtxcount (/ (length vtxlist) 2))
 (repeat vtxcount
 (setq
 fp (trans (list (nth i vtxlist) (nth (+ i 2) vtxlist) 0)
 plname
 0
 )
 ) ;_ 同???的坐?? ocs ??? wcs
 (setq fplist (cons fp fplist))
 (setq i (+ i 2))
 )
 )
)
((= "acdbpolyline" plinetype) ;_ ?? vtxlist 是 x,y,z 坐?
 (progn
 (setq vtxcount (/ (length vtxlist) 3))
 (repeat vtxcount
 (setq fp (trans (list (nth i vtxlist)
 (nth (+ i 2) vtxlist)
 (nth (+ i 3) vtxlist)
 )
 plname
 0
 )
 ) ;_ 同???的坐?? ocs ??? wcs
 (setq fplist (cons fp fplist))
 (setq i (+ i 3))
 )
 )
)
 )
 fplist ;_ 返回值
) ;_ pline_vertexlist ?束

;;; 返回 spline 的?合?（fitpoint）列表
;;; ???明，
;;; splobj -- spline object , ?型? vla-object .
;;; precision -- ?取 fitpoint ?的精确度。相?? fitpoint ?曲?分段。
;;; 分段?端?的曲??度与直接距离相比，比值不大于 precision 。
;;; 算法?明，
;;; ??曲??度增加，?算量也?性增加。
;;; -----
(defun spline_fplist (splobj precision /
 list_fps ; list of fitpoints
 len_fps ; length of the curve coverd by the fipoint list
 wcslist_rmsegs ; end wcs list of remaining segments
 lenlist_rmsegs ; length list of remaining segments
 fpwcs_segsta ; fitpoint WCS of the current segment start
 fpwcs_segend ; fitpoint WCS of the current segment end
 per_seg ; percent of the curve coverd by the current segment, ex, 0.5, 0.25, ...
 len_seg ; length of current segment
 dist_seg ; distance between the current segment's two ends
 acprecision ; actual precision
 wcs_sta ; wcs of the curve's start point
 wcs_end ; wcs of the curve's end point
 )
 ;; 防止精度不合理
 ;; 太高精度?死机或引起超?值域等??。
 (if (< precision 1.005)
(setq precision 1.005)
 )
 ;; 初始化
 (setq list_fps (cons (vlax-curve-getstartPoint splobj) nil)) ;_ ?起?坐?加到 fitpoint 列表中
 (setq len_fps 0.0) ;_ list_fps 的覆??度? 0.0
 (setq wcslist_rmsegs (cons (vlax-curve-getendPoint splobj) nil)) ;_ ???坐?加到剩余段??列表
 (setq lenlist_rmsegs
 (cons (vlax-curve-getDistAtParam
 splobj
 (vlax-curve-getEndParam splobj)
 )
 nil
 )
 ) ;_ ?曲?全?加到剩余段??列表
 ;; ?取 list_fps
 (while (/= wcslist_rmsegs nil) ;_ ?list_fps未覆?整?曲????
;;
(setq len_seg (car lenlist_rmsegs))
(setq fpwcs_segsta (car list_fps))
(setq fpwcs_segend (car wcslist_rmsegs))
(setq dist_seg (distance fpwcs_segsta fpwcs_segend))
(setq acprecision
 (/ len_seg dist_seg))
(if (> precision acprecision)
 ;; 精度?到要求?
 (progn
(setq list_fps (cons fpwcs_segend list_fps)) ;_ fitpoint 列表增加一??
(setq len_fps (+ len_fps len_seg)) ;_ fitpoint 覆?的?度增加
(setq lenlist_rmsegs (cdr lenlist_rmsegs)) ;_ 剩余段列表?少一段
(setq wcslist_rmsegs (cdr wcslist_rmsegs))
 )
 ;; 精度不足?
 (progn
(setq len_seg (/ len_seg 2)) ;_ ??前的段一分? 2
(setq lenlist_rmsegs
 (cons len_seg (cons len_seg (cdr lenlist_rmsegs)))
) ;_ 剩余段列表第一段???段
(setq wcslist_rmsegs
 (cons
 (vlax-curve-getPointAtDist splobj (+ len_fps len_seg))
 wcslist_rmsegs
 )
) ;_ 剩余段??增加一?

 )
)
 )
 list_fps ;_ 返回值
) ;_ spline_fplist ?束

;;; 返回?? spline ?合?列表的合并列表
;;; Combine two FitPoint Lists .
(defun spline_combine2fpl (fpl1 fpl2 / rev1 rev2 mdist ndist fpcount i)
 ;; 判?最?近的端?，并?定是否要??合?列表返序
 ;; 第1次
 (setq rev1 nil ;_ fpl1 不需反序
rev2 nil ;_ fpl2 不需反序
mdist (distance (last fpl1) (car fpl2)) ;_ 最?近的端?的距离
 )
 ;; 第2次
 (setq ndist (distance (last fpl1) (last fpl2)))
 (if (> mdist ndist)
(setq rev1 nil
 rev2 1
 mdist ndist
)
 )
 ;; 第3次
 (setq ndist (distance (car fpl1) (car fpl2)))
 (if (> mdist ndist)
(setq rev1 1
 rev2 nil
 mdist ndist
)
 )
 ;; 第4次
 (setq ndist (distance (car fpl1) (last fpl2)))
 (if (> mdist ndist)
(setq rev1 1
 rev2 1
 mdist ndist
)
 )
 ;; 完成???合?列表合并
 (if rev1
(setq fpl1 (reverse fpl1))
 )
 (if rev2
(setq fpl2 (reverse fpl2))
 )
 (setq fpl1 (append fpl1 fpl2)
fpl2 nil
fpcount (length fpl1)
i 0
 )
 (repeat fpcount
(setq fpl2 (append fpl2 (nth i fpl1)))
(setq i (+ 1 i))
 )
 fpl2
)

楚界 · 发表于 2005-12-22 20:49:50

正在学习中

tgh56 · 发表于 2006-1-3 00:21:34

正在找这个东东,非常谢谢

狂刀 · 发表于 2006-1-3 01:13:58

两条都是ｓｐｌｉｎｅ的时候测试可以，用ｐｌｉｎｅ测试出现错误
命令: ccc
选择对象: 找到 1 个

选择对象: 指定对角点: 找到 1 个，总计 2 个

选择对象:

错误: 参数类型错误: safearrayp #<variant 8197 ...>

jx2008 · 发表于 2007-7-6 09:10:41

研究研究，试试看

hnfsf · 发表于 2014-8-15 00:06:06

这个比较有用，做个标记

luorui2000 · 发表于 2017-5-12 12:31:33

正需要,谢谢楼主

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：将选定的两条曲线连成一条(vlisp+vba源码)

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子