[抛砖引玉]：结构精品程序源码下载

wujimmy · 发表于 2007-6-15 21:49:17

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

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

×

本帖是抛砖引玉,希望大家也把好家伙拿出来吧
基本上我的好家伙,除了梁配筋校对程序没有,其他的都在这里了

原文地址:http://www.jgcad.com/article.asp?id=268

该程序配合计算书归并程序,就可以方便的进行计算书归并了.

该程序配合批量打印程序,就可以批量打印计算书了.

[FONT=courier new]
主函数:
(defun c:jss()
(init_bonus_error
(list
(list "cmdecho" 0 "osmode" 0
)
T ;flag. True means use undo for error clean up.
);list
)
(alert "\n该函数用于生成所有的计算书.")
;;; (initget "Y N_Yes No")
;;; (setq changepos (getkword "\n是否插入到同一点?[Y/N]<Y>:"))
;;; (if (null changepos) (setq changepos "Yes"))
(setq dir-mid (qf_getFolder (strcat"选择文件夹<" (if filedir filedir "")">:")))
(if dir-mid (setq filedir dir-mid))
(command "layer" "m" "plot" "")
(setq pt-start (getpoint))
;;荷载. "第_1层梁、墙柱节点输入及楼面荷载平面图.DWG"
(setq file-list (vl-directory-files filedir "第??层梁、墙柱节点输入及楼面荷载平面图.DWG"))
(if file-list (setq max-distx (my_insert pt-start file-list 1)))
(setq pt-start (polar pt-start 0 max-distx))
;;板筋;bjss板计算结果01.DWG
(setq file-list (vl-directory-files filedir "*板计算结果*.dwg"))
(if file-list (setq max-distx (my_insert pt-start file-list 100)))
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx)))
;;梁筋;
(setq file-list (vl-directory-files filedir "wpj*.dwg"))
(if file-list (setq max-distx (my_insert pt-start file-list 1000)))
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx)))
;;梁截面;
(setq file-list (vl-directory-files filedir "FLR*.dwg"))
(if file-list (setq max-distx (my_insert pt-start file-list 1000)))
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx)))
)
[/FONT]

[FONT=courier new] 
主函数: 
 
(defun c:jss() 
(init_bonus_error 
(list 
(list "cmdecho" 0 "osmode" 0 
) 
T ;flag. True means use undo for error clean up. 
);list 
) 
 
(alert "\n该函数用于生成所有的计算书.") 
 
;;; (initget "Y N_Yes No") 
;;; (setq changepos (getkword "\n是否插入到同一点?[Y/N]<Y>:")) 
;;; (if (null changepos) (setq changepos "Yes")) 
 
(setq dir-mid (qf_getFolder (strcat"选择文件夹<" (if filedir filedir "")">:"))) 
(if dir-mid (setq filedir dir-mid)) 
 
(command "layer" "m" "plot" "") 
(setq pt-start (getpoint)) 
 
;;荷载. "第_1层梁、墙柱节点输入及楼面荷载平面图.DWG" 
 
(setq file-list (vl-directory-files filedir "第??层梁、墙柱节点输入及楼面荷载平面图.DWG")) 
(if file-list (setq max-distx (my_insert pt-start file-list 1))) 
(setq pt-start (polar pt-start 0 max-distx)) 
 
;;板筋;bjss板计算结果01.DWG 
(setq file-list (vl-directory-files filedir "*板计算结果*.dwg")) 
(if file-list (setq max-distx (my_insert pt-start file-list 100))) 
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx))) 
 
;;梁筋; 
(setq file-list (vl-directory-files filedir "wpj*.dwg")) 
(if file-list (setq max-distx (my_insert pt-start file-list 1000))) 
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx))) 
 
;;梁截面; 
 
(setq file-list (vl-directory-files filedir "FLR*.dwg")) 
(if file-list (setq max-distx (my_insert pt-start file-list 1000))) 
(setq pt-start (polar pt-start 0 (+ paper-dist max-distx))) 
 
) 
 
  [/FONT]

wujimmy · 发表于 2007-6-15 22:09:37

[FONT=courier new]
(defun c:get-colu-pgl ()
(princ "\n选择箍筋配筋值:")
(setq en (single_select (list (cons 0 "*TEXT")(cons 1 "*%%13#*")) nil))
(princ "\n选择墙大样外边框:")
(setq colu-en (SINGLE_SELECT
(list (cons 0 "LWPOLYLINE")
(cons 8 "*colu*,*柱*,*墙*,*wall*")
)
nil
)
)
(get-ss-pgl colu-en en)
)
[/FONT]

http://www.jgcad.com/uploads/200706/09_233215_colugg.rar

附件是用到的裤函数

litss · 发表于 2007-6-16 00:02:22

还没在cad里试用。先提点问题：）

1、是否要求外框为pline，以减少求交点的麻烦？
2、是否要求钢筋为line？若增加考虑pline的钢筋线，然后在程序中explode后求解，最后再undo回去，有没有可能呢？
3、对于钢筋弯头是如何处理的？呵呵，没太细看，还不太明白。

求交点后减去保护层的方法很不错，我原来以为只能直接量钢筋直线长度然后累加呢。那样误差很大。每个人画图都不太标准。

感谢分享：）

wujimmy · 发表于 2007-6-16 07:56:44

1.外框当然要求是PL线了,不然的话,不好选择.
2.里面的钢筋要求是PL线,就像是TSSD生成的那样.
3.钢筋的弯头是不计算的,通过判断钢筋长度,短于一定长度就不计算的

wujimmy · 发表于 2007-6-16 23:03:33

(defun c:help-cc ()
(textscr)
(princ
" ===>黄金左手程序说明<===
本程序是通过输入数字或字母代替代替输入钢筋根数及直径\n
以减少用户输入钢筋是的繁杂钢筋输入过程.
以下是钢筋直径,钢筋根数对照表."
)
(princ "\n直径:a=14,b=16,c=18,d=20,e=22,f=25...")
(princ "\n根数:a=1,b=2,c=3,d=4,e=5,f=6...")
(princ "使用程序中有几点要注意的问题,了解这些问题将有利于你更好的使用本程序.
1.程序运行过程中会自动查找梁线,用于判断梁宽,从而可以自动加上钢筋排数信息,目前只支持二排筋.
2.程序识别的梁线的图层为\"*梁*,*beam*,bout \" 其中*可以是任意字符,
例如你的梁线图层为\"梁实线\",则会被程序所支持.
3.另外,为了保持程序对各种比例的图形都能识别出梁宽,在命令运行过程中按右键可以设置图形比例.
4.右键菜单中还可以设置保护层厚度.
5.本程序还在不断优化中,以期使你的画图效率得到极大的提高,
请继续关注官方网站中\"结构软件\"版块的最新态
网址http://www.jgcad.com
6.如果你想改变程序默认的钢筋直径,钢筋根数对照表,
你可以修改文件cc-user.lsp中的相应内容,
并把该文件置于AutoCAD的支持目录下(例如support这个目录).
7.本程序作者吴所不及,如有转载请注明作都及官方网址等信息!
未经许可,本程序不得用于任何商业软件.")
(princ)

)

下载地址:
http://www.jgcad.com/article.asp?id=264

wujimmy · 发表于 2007-6-17 07:31:04

计算书批量打印程序源码

(defun c:mypt (/ AcadObject AcadDocument mSpace preferenceSel fileSel plot-filedir plots plot)
(princ "\n选择边框为蓝色的PL线:")
(setq ss (ssget '((0 . "LWPOLYLINE")(62 . 5))))
(setq ss-list (WJM_SS2LST ss))
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
mSpace (vla-get-ModelSpace AcadDocument)
)
(setq preferenceSel (vla-get-Preferences AcadObject))
(setq fileSel (vla-get-Files preferenceSel))
(setq plot-filedir(vla-get-PrinterConfigPath fileSel));_打印机.
(setq plots (vl-directory-files plot-filedir "*.pc3"))
(setq plot (myp:get_properties plots "选择打印机"))
;(setq plot (substr style 1 (- (strlen style) 4)))
(setq plot-filedir(vla-get-PrinterStyleSheetPath fileSel));_打印样式.
(setq plot-styles (vl-directory-files plot-filedir "*.ctb"))
(setq style (myp:get_properties plot-styles "打印样式"))
;(setq style (substr plot 1 (- (strlen plot) 4)))
(setq paper-size
(myp:get_properties
(list
"A3"
"A4"
"过大尺寸：ISO A0 "
"过大尺寸：ISO A1 (横向)"
"过大尺寸：ISO A1 (纵向)"
"过大尺寸：ISO A2 (横向)"
"过大尺寸：ISO A2 (纵向)"
)
"选择图纸尺寸"
)
) ;_纸张选择.
(setq paper-dir-mid
(myp:get_properties
(list
"自动根据长宽比判断"
"横向(L)"
"纵向(P)"
)
"选择图纸方向"
))
(setq paper-plot-to-file-mid
(myp:get_properties
(list
"打印到文件"
"直接打印"
)
"选择是否打到文件"
))
(setq paper-plot-to-file
(cond
((= paper-plot-to-file-mid "打印到文件") "Y")
((= paper-plot-to-file-mid "直接打印") "N")
))
(setq i 0)
(foreach en ss-list
(progn
(setq i (1+ i))
(setq obj (vlax-ename->vla-object en))
(vla-getboundingbox obj 'll 'ur)
(setq pt1 (vlax-safearray->list ll))
(setq pt2 (vlax-safearray->list ur))
(setq paper-dir (cond
((= paper-dir-mid "自动根据长宽比判断")
(if (> (- (car pt2) (car pt1));_x
(- (cadr pt2) (cadr pt1));_y
)
"L"
"P"
)
)
((= paper-dir-mid "横向(L)") "L")
((= paper-dir-mid "纵向(P)") "P")
)
)
(if (= paper-plot-to-file "Y")
(command "_.PLOT"
"Y";_是否需要详细打印配置？[是(Y)/否(N)] <否>: y
"";_输入布局名或 [?] <模型>:
plot;_输入输出设备的名称或 [?] <在网管上自动 HP LaserJet 5100 PCL 6>:
paper-size;_输入图纸尺寸或 [?] <A3>:
"m";_输入图纸单位 [英寸(I)/毫米(M] <毫米>:
paper-dir;_输入图形方向 [纵向(P)/横向(L)] <横向>:
"N";_是否反向打印？[是(Y)/否(N)] <否>:
"W";_输入打印区域 [显示(D)/范围(E)/图形界限(L)/视图(V)/窗口(W)] <范围>: w
pt1;_输入窗口的左下角 <0.000000,0.000000>: 输入窗口的右上角 <0.000000,0.000000>:
pt2;_输入窗口的右上角 <0.000000,0.000000>:
"f";_输入打印比例 (打印的毫米=图形单位) 或 [布满(F)] <Fit>: fit
"c";_输入打印偏移 (x,y) 或 [居中打印(C)] <0.00,0.00>: c
"Y";_是否按样式打印？[是(Y)/否(N)] <是>:
style;_输入打印样式表名称或 [?] (输入 . 表示无) <hp5100.ctb>:
"Y";_是否打印线宽？[是(Y)/否(N)] <是>:
"N";_是否删除隐藏线？[是(Y)/否(N)] <否>:
paper-plot-to-file ;_是否打印到文件 [是(Y)/否(N)] <N>: y
(strcat (getvar "DWGPREFIX") (rtos i 2 0) ".plt" );_文件名.
"Y";_是否保存模型选项卡的修改 .
"Y";_是否继续打印 .
)
(command "_.PLOT"
"Y";_是否需要详细打印配置？[是(Y)/否(N)] <否>: y
"";_输入布局名或 [?] <模型>:
plot;_输入输出设备的名称或 [?] <在网管上自动 HP LaserJet 5100 PCL 6>:
paper-size;_输入图纸尺寸或 [?] <A3>:
"m";_输入图纸单位 [英寸(I)/毫米(M] <毫米>:
paper-dir;_输入图形方向 [纵向(P)/横向(L)] <横向>:
"N";_是否反向打印？[是(Y)/否(N)] <否>:
"W";_输入打印区域 [显示(D)/范围(E)/图形界限(L)/视图(V)/窗口(W)] <范围>: w
pt1;_输入窗口的左下角 <0.000000,0.000000>: 输入窗口的右上角 <0.000000,0.000000>:
pt2;_输入窗口的右上角 <0.000000,0.000000>:
"f";_输入打印比例 (打印的毫米=图形单位) 或 [布满(F)] <Fit>: fit
"c";_输入打印偏移 (x,y) 或 [居中打印(C)] <0.00,0.00>: c
"Y";_是否按样式打印？[是(Y)/否(N)] <是>:
style;_输入打印样式表名称或 [?] (输入 . 表示无) <hp5100.ctb>:
"Y";_是否打印线宽？[是(Y)/否(N)] <是>:
"N";_是否删除隐藏线？[是(Y)/否(N)] <否>:
paper-plot-to-file ;_是否打印到文件 [是(Y)/否(N)] <N>: y
"Y";_是否保存模型选项卡的修改 .
"Y";_是否继续打印 .
)
);_if
(princ "\n*********************\n")
)
)
)

(defun c:mypt (/ AcadObject  AcadDocument mSpace preferenceSel fileSel plot-filedir plots plot) 
  (princ "\n选择边框为蓝色的PL线:") 
  (setq ss (ssget '((0 . "LWPOLYLINE")(62 . 5)))) 
  (setq ss-list (WJM_SS2LST ss)) 
 
    (setq    AcadObject   (vlax-get-acad-object) 
       AcadDocument (vla-get-ActiveDocument AcadObject) 
       mSpace        (vla-get-ModelSpace AcadDocument) 
 
  ) 
  (setq preferenceSel (vla-get-Preferences AcadObject)) 
  (setq fileSel (vla-get-Files preferenceSel)) 
 
  (setq plot-filedir(vla-get-PrinterConfigPath fileSel));_打印机. 
  (setq plots (vl-directory-files plot-filedir "*.pc3")) 
  (setq plot (myp:get_properties plots "选择打印机")) 
  ;(setq plot (substr style 1 (- (strlen style) 4))) 
   
  (setq plot-filedir(vla-get-PrinterStyleSheetPath fileSel));_打印样式. 
  (setq plot-styles (vl-directory-files plot-filedir "*.ctb")) 
  (setq style (myp:get_properties plot-styles  "打印样式")) 
  ;(setq style (substr plot 1 (- (strlen plot) 4))) 
   
  (setq        paper-size 
         (myp:get_properties 
           (list 
             "A3" 
             "A4" 
             "过大尺寸：ISO A0 " 
             "过大尺寸：ISO A1  (横向)" 
             "过大尺寸：ISO A1  (纵向)" 
             "过大尺寸：ISO A2  (横向)" 
             "过大尺寸：ISO A2  (纵向)" 
            ) 
           "选择图纸尺寸" 
         ) 
  ) ;_纸张选择. 
 
  (setq paper-dir-mid 
  (myp:get_properties 
           (list 
             "自动根据长宽比判断" 
             "横向(L)" 
             "纵向(P)" 
            ) 
           "选择图纸方向" 
         )) 
 
  (setq paper-plot-to-file-mid 
  (myp:get_properties 
           (list              
             "打印到文件" 
             "直接打印" 
            ) 
           "选择是否打到文件" 
         )) 
 
  (setq paper-plot-to-file 
  (cond 
    ((= paper-plot-to-file-mid "打印到文件") "Y") 
    ((= paper-plot-to-file-mid "直接打印") "N") 
    )) 
 
   
  (setq i 0) 
  (foreach en ss-list 
    (progn 
      (setq i (1+ i)) 
       
      (setq obj (vlax-ename->vla-object en)) 
      (vla-getboundingbox obj 'll 'ur) 
      (setq pt1 (vlax-safearray->list ll)) 
      (setq pt2 (vlax-safearray->list ur)) 
 
      (setq paper-dir (cond 
                        ((= paper-dir-mid "自动根据长宽比判断") 
                         (if (>        (- (car pt2) (car pt1));_x 
                                (- (cadr pt2) (cadr pt1));_y 
                             ) 
                           "L" 
                           "P" 
                         ) 
                         ) 
                        ((= paper-dir-mid "横向(L)") "L") 
                        ((= paper-dir-mid "纵向(P)") "P") 
                        ) 
            ) 
      (if (= paper-plot-to-file "Y") 
      (command "_.PLOT" 
               "Y";_是否需要详细打印配置？[是(Y)/否(N)] <否>: y 
               "";_输入布局名或 [?] <模型>: 
               plot;_输入输出设备的名称或 [?] <在 网管 上自动 HP LaserJet 5100 PCL 6>: 
               paper-size;_输入图纸尺寸或 [?] <A3>: 
                
               "m";_输入图纸单位 [英寸(I)/毫米(M] <毫米>:                
               paper-dir;_输入图形方向 [纵向(P)/横向(L)] <横向>: 
               "N";_是否反向打印？[是(Y)/否(N)] <否>: 
               "W";_输入打印区域 [显示(D)/范围(E)/图形界限(L)/视图(V)/窗口(W)] <范围>: w 
               pt1;_输入窗口的左下角 <0.000000,0.000000>: 输入窗口的右上角 <0.000000,0.000000>: 
               pt2;_输入窗口的右上角 <0.000000,0.000000>: 
               "f";_输入打印比例 (打印的 毫米=图形单位) 或 [布满(F)] <Fit>: fit 
               "c";_输入打印偏移 (x,y) 或 [居中打印(C)] <0.00,0.00>: c 
               "Y";_是否按样式打印？[是(Y)/否(N)] <是>: 
               style;_输入打印样式表名称或 [?] (输入 . 表示无) <hp5100.ctb>: 
               "Y";_是否打印线宽？[是(Y)/否(N)] <是>: 
               "N";_是否删除隐藏线？[是(Y)/否(N)] <否>: 
               paper-plot-to-file ;_是否打印到文件 [是(Y)/否(N)] <N>: y 
               (strcat (getvar "DWGPREFIX") (rtos i 2 0) ".plt" );_文件名.              
               "Y";_是否保存模型选项卡的修改 . 
               "Y";_是否继续打印 . 
              ) 
      (command "_.PLOT" 
               "Y";_是否需要详细打印配置？[是(Y)/否(N)] <否>: y 
               "";_输入布局名或 [?] <模型>: 
               plot;_输入输出设备的名称或 [?] <在 网管 上自动 HP LaserJet 5100 PCL 6>: 
               paper-size;_输入图纸尺寸或 [?] <A3>: 
                
               "m";_输入图纸单位 [英寸(I)/毫米(M] <毫米>:                
               paper-dir;_输入图形方向 [纵向(P)/横向(L)] <横向>: 
               "N";_是否反向打印？[是(Y)/否(N)] <否>: 
               "W";_输入打印区域 [显示(D)/范围(E)/图形界限(L)/视图(V)/窗口(W)] <范围>: w 
               pt1;_输入窗口的左下角 <0.000000,0.000000>: 输入窗口的右上角 <0.000000,0.000000>: 
               pt2;_输入窗口的右上角 <0.000000,0.000000>: 
               "f";_输入打印比例 (打印的 毫米=图形单位) 或 [布满(F)] <Fit>: fit 
               "c";_输入打印偏移 (x,y) 或 [居中打印(C)] <0.00,0.00>: c 
               "Y";_是否按样式打印？[是(Y)/否(N)] <是>: 
               style;_输入打印样式表名称或 [?] (输入 . 表示无) <hp5100.ctb>: 
               "Y";_是否打印线宽？[是(Y)/否(N)] <是>: 
               "N";_是否删除隐藏线？[是(Y)/否(N)] <否>: 
               paper-plot-to-file ;_是否打印到文件 [是(Y)/否(N)] <N>: y                
              "Y";_是否保存模型选项卡的修改 . 
               "Y";_是否继续打印 . 
              ) 
        );_if 
 
       
      (princ "\n*********************\n") 
    ) 
  ) 
)

wujimmy · 发表于 2007-6-17 07:35:25

预留画柱网程序之柱标注,柱归并
先传个旧版的画柱网程序
不传东西下让发表

wujimmy · 发表于 2007-6-17 07:38:42

计算书归并程序源码
有好几个版本了.
如果要研究程序开发的话,就可以比较一下各个版本的选择方式有什么不同
速度差很多的

第一版,速度最慢的

wujimmy · 发表于 2007-6-17 07:40:29

第二版,选择集的构造方式有所不同,所以速度会快很多

第二版带有配筋判断的功能,如果是只有两层的计算书
则会进行比较,用于新旧计算书的比较

lhg · 发表于 2007-6-17 15:05:16

楼主！不错！
不过程序中少了一些子程序！如：(myprogress i% lenss1)等等！不如一起发上来！

wujimmy · 发表于 2007-6-17 19:45:52

少掉的是一些无关紧要的函数,删掉就可以了

tc405003 · 发表于 2007-6-17 22:00:36

吴老大，配箍率好像少了个wjm_midp子程序

wujimmy · 发表于 2007-6-17 22:03:43

这个函数好长,用于求交点的.
晓东上面来的.

(progn
;_判断物体类型,选择相应函数求交点_______________________________________
(defun wjm_midp (en_1 en_2 lim / intersections)
(setq intersections nil)
(wjmf_Midp en_1 en_2 lim )
intersections
)
(defun wjmf_Midp (en_1 en_2 lim / )
;(setq intersections nil)
(IF (LISTP EN_1)
()
(SETQ EN_1 (ENTGET EN_1))
)
(IF (LISTP EN_2)
()
(SETQ EN_2 (ENTGET EN_2))
)
(setq e1_tp (cdr (assoc 0 EN_1)))
(setq e2_tp (cdr (assoc 0 EN_2)))
(cond
((= "LWPOLYLINE" e1_tp)
(pi? en_1 en_2 lim)
)
((= "LWPOLYLINE" e2_tp)
(pi? en_2 en_1 (change_order lim))
)
((and (= "CIRCLE" e1_tp) (= "CIRCLE" e2_tp))
(cic en_1 en_2 lim)
)
((and (= "ARC" e1_tp) (= "ARC" e2_tp))
(aia en_1 en_2 lim)
)
((and (= "LINE" e1_tp) (= "LINE" e2_tp))
(lil en_1 en_2 lim)
)
((and (= "CIRCLE" e1_tp) (= "ARC" e2_tp))
(cia en_1 en_2 lim)
)
((and (= "CIRCLE" e1_tp) (= "LINE" e2_tp))
(cil en_1 en_2 lim)
)
((and (= "ARC" e1_tp) (= "LINE" e2_tp))
(ail en_1 en_2 lim)
)
((and (= "ARC" e1_tp) (= "CIRCLE" e2_tp))
(cia en_2 en_1 (change_order lim))
)
((and (= "LINE" e1_tp) (= "CIRCLE" e2_tp))
(cil en_2 en_1 (change_order lim))
)
((and (= "LINE" e1_tp) (= "ARC" e2_tp))
(ail en_2 en_1 (change_order lim))
)
(T (princ "\n请选择圆、圆弧或者线段！"))
)
intersections
)
;_反转延长标志_________________________________________________________
(defun change_order (num)
(cond
((= num 1) (setq num 2))
((= num 2) (setq num 1))
)
num
)
;______________________________________________________________________
;______________________________________________________________________
;_________________求交点应用函数部分____BY__WKAI__晓东CAD论坛__________
;___________________2003.12.11.14.33___________________________________
;____limited__决定求交点时物体是否延伸_________________________________
;____0 都延伸,1 一号不延伸,2 二号不延伸,3 全部不延伸___________________
;_圆、圆交点___________________________________________________________
(defun cic (c1 c2 limited / c1_cn c2_cn c1_rd c2_rd ins)
(IF (LISTP C1)
()
(SETQ C1 (ENTGET C1))
)
(IF (LISTP C2)
()
(SETQ C2 (ENTGET C2))
)
(setq c1_cn (cdr (assoc 10 c1)))
(setq c2_cn (cdr (assoc 10 c2)))
(setq c1_rd (cdr (assoc 40 c1)))
(setq c2_rd (cdr (assoc 40 c2)))
(setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd))
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_圆、圆弧交点_________________________________________________________
(defun cia (c1 c2 limited / ins ins_tmp c1_cn c2_cn c1_rd c2_rd n)
(IF (LISTP C1)
()
(SETQ C1 (ENTGET C1))
)
(IF (LISTP C2)
()
(SETQ C2 (ENTGET C2))
)
(setq c1_cn (cdr (assoc 10 c1)))
(setq c2_cn (cdr (assoc 10 c2)))
(setq c1_rd (cdr (assoc 40 c1)))
(setq c2_rd (cdr (assoc 40 c2)))
(setq c2_an1 (cdr (assoc 50 c2)))
(setq c2_an2 (cdr (assoc 51 c2)))
(setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd))
(if (or (= limited 2) (= limited 3))
(progn
(foreach n ins
(if (p_on_arc n c2_cn c2_an1 c2_an2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(setq ins ins_tmp)
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_圆弧、圆弧交点________________________________________________________
(defun aia (c1 c2 limited / ins ins_tmp c1_cn
c2_cn c1_rd c2_rd c1_an1 c1_an2 c2_an1 c2_an2
n
)
(IF (LISTP C1)
()
(SETQ C1 (ENTGET C1))
)
(IF (LISTP C2)
()
(SETQ C2 (ENTGET C2))
)
(setq c1_cn (cdr (assoc 10 c1)))
(setq c2_cn (cdr (assoc 10 c2)))
(setq c1_rd (cdr (assoc 40 c1)))
(setq c2_rd (cdr (assoc 40 c2)))
(setq c1_an1 (cdr (assoc 50 c1)))
(setq c1_an2 (cdr (assoc 51 c1)))
(setq c2_an1 (cdr (assoc 50 c2)))
(setq c2_an2 (cdr (assoc 51 c2)))
(setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd))
(if (or (= limited 1) (= limited 3))
(progn
(foreach n ins
(if (p_on_arc n c1_cn c1_an1 c1_an2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(setq ins_tmp nil)
(if (or (= limited 2) (= limited 3))
(progn
(foreach n ins
(if (p_on_arc n c2_cn c2_an1 c2_an2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_圆、直线交点______________________________________________________
(defun cil (c1 l1 limited / end1 end2 cen rad ins ins_tmp n)
(IF (LISTP C1)
()
(SETQ C1 (ENTGET C1))
)
(IF (LISTP L1)
()
(SETQ L1 (ENTGET L1))
)
(setq end1 (cdr (assoc 10 l1)))
(setq end2 (cdr (assoc 11 l1)))
(setq cen (cdr (assoc 10 c1)))
(setq rad (cdr (assoc 40 c1)))
(setq ins (L_INT_C end1 end2 cen rad))
(if (or (= limited 2) (= limited 3))
(progn
(foreach n ins
(if (p_on_line n end1 end2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_圆弧、直线交点______________________________________________________
(defun ail
(c1 l1 limited / end1 end2 cen rad ang1 ang2 ins ins_tmp n)
(IF (LISTP C1)
()
(SETQ C1 (ENTGET C1))
)
(IF (LISTP L1)
()
(SETQ L1 (ENTGET L1))
)
(setq end1 (cdr (assoc 10 l1)))
(setq end2 (cdr (assoc 11 l1)))
(setq cen (cdr (assoc 10 c1)))
(setq rad (cdr (assoc 40 c1)))
(setq ang1 (cdr (assoc 50 c1)))
(setq ang2 (cdr (assoc 51 c1)))
(setq ins (L_INT_C end1 end2 cen rad))
(if (or (= limited 1) (= limited 3))
(progn
(foreach n ins
(if (p_on_arc n cen ang1 ang2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(setq ins_tmp nil)
(if (or (= limited 2) (= limited 3))
(progn
(foreach n ins
(if (p_on_line n end1 end2)
(if ins_tmp
(setq ins_tmp (append ins_tmp (list n)))
(setq ins_tmp (list n))
)
)
)
(setq ins ins_tmp)
)
)
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_直线、直线交点______________________________________________________
(defun lil
(l1 l2 limited / n ins ins_tmp l1_en1 l1_en2 l2_en1 l2_en2)
(if (listp l1)
()
(setq l1 (entget l1))
)
(if (listp l2)
()
(setq l2 (entget l2))
)
(setq l1_en1 (cdr (assoc 10 l1)))
(setq l1_en2 (cdr (assoc 11 l1)))
(setq l2_en1 (cdr (assoc 10 l2)))
(setq l2_en2 (cdr (assoc 11 l2)))
(if (setq ins_tmp (inters l1_en1 l1_en2 l2_en1 l2_en2 nil))
(setq ins (list ins_tmp))
)
(setq ins_tmp nil)
(if (or (= limited 1) (= limited 3))
(progn
(foreach n ins
(if (p_on_line n l1_en1 l1_en2)
(setq ins_tmp (list n))
)
)
(setq ins ins_tmp)
)
)
(setq ins_tmp nil)
(if (or (= limited 2) (= limited 3))
(progn
(foreach n ins
(if (p_on_line n l2_en1 l2_en2)
(setq ins_tmp (list n))
)
)
(setq ins ins_tmp)
)
)
(if ins
(setq intersections (append intersections ins))
)
intersections
)
;_复义线、其它实体交点______________________________________________________
;_如果是两条复义线通过递归求交______________________________________________
(defun pi? (pl1 e2 lim / p1 p2 p3
pts-pl1 n sym1 sym2 ang1 ang2
pl1-sub-ent
)
(if (listp pl1)
()
(setq pl1 (entget pl1))
)
(if (listp e2)
()
(setq e2 (entget e2))
)
(setq pts-pl1 (GET_ENDS_PL pl1))
(setq n 1)
(while (< (+ 1 n) (length pts-pl1))
(setq p1 (nth (- n 1) pts-pl1))
(setq p2 (nth n pts-pl1))
(setq p3 (nth (+ n 1) pts-pl1))
(if (listp p2)
(progn
(setq sym1 (car p2))
(setq p2 (cdr p2))
(if (= 1 sym1)
(setq ang1 (angle p2 p1)
ang2 (angle p2 p3)
)
(setq ang1 (angle p2 p3)
ang2 (angle p2 p1)
)
)
(setq pl1-sub-ent
(list (cons 0 "ARC")
(cons 10 p2)
(cons 40 (distance p1 p2))
(cons 50 ang1)
(cons 51 ang2)
(cons 62 1)
)
)
)
(setq pl1-sub-ent
(list (cons 0 "LINE") (cons 10 p1) (cons 11 p3) (cons 62 1))
)
)
(wjmf_Midp pl1-sub-ent e2 lim)
(setq n (+ 2 n))
)
)
;______________________________________________________________________
;______________________________________________________________________
;_________________求交点核心函数部分____BY__WKAI__晓东CAD论坛__________
;___________________2003.12.11.14.33___________________________________
;______________________________________________________________________
;_精度设置_____________________________________________________________
(setq min_num 0.0000001)
;___________________圆与圆交点函数,输入值圆心1,半径1,圆心2,半径2.返回值交点表
(defun c_int_c (c1_cen c1_rad c2_cen c2_rad / ints c1c2_dis dd ee)
(setq c1c2_dis (distance c1_cen c2_cen))
(cond
((equal c1c2_dis (+ c1_rad c2_rad) min_num)
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
((equal c1c2_dis (abs (- c1_rad c2_rad)) min_num)
(if (minusp (- c1_rad c2_rad))
(setq ints (list (polar c2_cen (angle c2_cen c1_cen) c2_rad)))
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
)
((and (> c1c2_dis (abs (- c1_rad c2_rad)))
(< c1c2_dis (+ c1_rad c2_rad))
)
(progn
(setq dd (/ (- (+ (* c1c2_dis c1c2_dis) (* c1_rad c1_rad))
(* c2_rad c2_rad)
)
(* 2 c1c2_dis)
)
)
(setq ee (sqrt (- (* c1_rad c1_rad) (* dd dd))))
(setq
ints (list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(+ (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
(setq ints
(append
ints
(list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(- (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
)
)
)
)
ints
)
;___________________直线与圆交点函数,输入值直线端点1,端点2,圆心,半径.返回值交点表
(defun L_INT_C (l_end1 l_end2 c_cen c_rad / pedal dist_cen_l int1 int2
ints)
(setq pedal (pedal_to_line c_cen l_end1 l_end2))
(setq dist_cen_l (distance pedal c_cen))
(cond
((equal c_rad dist_cen_l min_num) (setq ints (list pedal)))
((> c_rad dist_cen_l)
(progn
(setq int1
(polar pedal
(angle l_end1 l_end2)
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq int2
(polar pedal
(+ pi (angle l_end1 l_end2))
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq ints (list int1 int2))
)
)
)
ints
)
;______________________________________________________________________
;______________________________________________________________________
;_________________辅助测试函数部分____BY__WKAI__晓东CAD论坛____________
;___________________2003.12.11.14.33___________________________________
;______________________________________________________________________
;___________________求点到直线的垂足的函数,输入值测试点,直线端点1,端点2.返回值垂足坐标
(defun pedal_to_line (pt pt1 pt2)
(inters
pt
(polar pt (+ (/ pi 2) (angle pt1 pt2)) 1000)
pt1
pt2
nil
)
)
;___________________测试点是否在线段上,输入值测试点,线段端点1,端点2.返回值T或者NIL
(defun p_on_line (pt pt1 pt2)
(equal (+ (distance pt pt1) (distance pt pt2))
(distance pt1 pt2)
min_num
)
)
;___________________测试点是否在圆弧上,输入值测试点,圆心,起始角度,终止角度.返回值T或者NIL
(defun p_on_arc (pt cn an1 an2)
(if (> an1 an2)
(setq an1 (- an1 (* 2 pi)))
)
(or
(and (>= (+ (angle cn pt) pi pi) an1)
(<= (+ (angle cn pt) pi pi) an2)
)
(and (>= (angle cn pt) an1) (<= (angle cn pt) an2))
(and (>= (- (angle cn pt) pi pi) an1)
(<= (- (angle cn pt) pi pi) an2)
)
)
)
;___________________获取轻装多义线的各个端点和圆心(如果有),输入值复义线实体名或表.返回值端点及圆心表
(DEFUN GET_ENDS_PL (PL / dis dis1 m N
PT-LST PT-LST-TMP sym mid-p1p2
NTH-PT p1 p2 pl-tp pt1 rad
sym
)
(IF (LISTP PL)
()
(SETQ PL (ENTGET PL))
)
(SETQ PL-TP (CDR (ASSOC 70 PL)))
(FOREACH N PL
(IF (OR (= 10 (CAR N)) (= 42 (CAR N)))
(SETQ PT-LST (APPEND PT-LST (LIST (CDR N))))
)
)
(IF (= 1 PL-TP)
(SETQ PT-LST (APPEND PT-LST (LIST (CDR (ASSOC 10 PL)))))
(SETQ PT-LST (reverse (cdr (reverse PT-LST))))
)
(SETQ M 0)
(while (<= (+ 1 m) (LENGTH PT-LST))
(SETQ NTH-PT (NTH M PT-LST))
(IF (LISTP NTH-PT)
(SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST NTH-PT)))
(PROGN
(IF (EQUAL NTH-PT 0 MIN_NUM)
(SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST NTH-PT)))
(PROGN
(SETQ P1 (NTH (- M 1) PT-LST))
(SETQ P2 (NTH (+ M 1) PT-LST))
(SETQ MID-P1P2 (LIST (/ (+ (CAR P1) (CAR P2)) 2)
(/ (+ (CADR P1) (CADR P2)) 2)
)
)
(SETQ DIS (/ (DISTANCE P1 P2) 2))
(SETQ DIS1 (ABS (* DIS NTH-PT)))
(SETQ RAD (/ (+ (* DIS DIS) (* DIS1 DIS1)) (* 2 DIS1)))
(IF (minusp NTH-PT)
(SETQ
PT1 (append (list -1)
(POLAR MID-P1P2
(- (ANGLE P1 P2) (/ PI 2))
(- RAD DIS1)
)
)
)
(SETQ
PT1 (append (list 1)
(POLAR MID-P1P2
(+ (ANGLE P1 P2) (/ PI 2))
(- RAD DIS1)
)
)
)
)
(SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST PT1)))
)
)
)
)
(SETQ M (+ 1 M))
)
(SETQ PT-LST PT-LST-TMP)
)
;_________________________________________________________________________________________
;_________________________________________________________________________________________
;_________________________________________________________________________________________
;_________________________________________________________________________________________
)

(progn 
 ;_判断物体类型,选择相应函数求交点_______________________________________ 
  (defun wjm_midp (en_1 en_2 lim / intersections) 
    (setq intersections nil) 
    (wjmf_Midp en_1 en_2 lim ) 
    intersections 
    ) 
  (defun wjmf_Midp (en_1 en_2 lim / ) 
    ;(setq intersections nil) 
    (IF        (LISTP EN_1) 
      () 
      (SETQ EN_1 (ENTGET EN_1)) 
    ) 
    (IF        (LISTP EN_2) 
      () 
      (SETQ EN_2 (ENTGET EN_2)) 
    ) 
    (setq e1_tp (cdr (assoc 0 EN_1))) 
    (setq e2_tp (cdr (assoc 0 EN_2))) 
    (cond 
      ((= "LWPOLYLINE" e1_tp) 
       (pi? en_1 en_2 lim) 
      ) 
      ((= "LWPOLYLINE" e2_tp) 
       (pi? en_2 en_1 (change_order lim)) 
      ) 
      ((and (= "CIRCLE" e1_tp) (= "CIRCLE" e2_tp)) 
       (cic en_1 en_2 lim) 
      ) 
      ((and (= "ARC" e1_tp) (= "ARC" e2_tp)) 
       (aia en_1 en_2 lim) 
      ) 
      ((and (= "LINE" e1_tp) (= "LINE" e2_tp)) 
       (lil en_1 en_2 lim) 
      ) 
 
      ((and (= "CIRCLE" e1_tp) (= "ARC" e2_tp)) 
       (cia en_1 en_2 lim) 
      ) 
      ((and (= "CIRCLE" e1_tp) (= "LINE" e2_tp)) 
       (cil en_1 en_2 lim) 
      ) 
      ((and (= "ARC" e1_tp) (= "LINE" e2_tp)) 
       (ail en_1 en_2 lim) 
      ) 
 
      ((and (= "ARC" e1_tp) (= "CIRCLE" e2_tp)) 
       (cia en_2 en_1 (change_order lim)) 
      ) 
      ((and (= "LINE" e1_tp) (= "CIRCLE" e2_tp)) 
       (cil en_2 en_1 (change_order lim)) 
      ) 
      ((and (= "LINE" e1_tp) (= "ARC" e2_tp)) 
       (ail en_2 en_1 (change_order lim)) 
      ) 
      (T (princ "\n请选择圆、圆弧或者线段！")) 
    ) 
    intersections 
  ) 
 ;_反转延长标志_________________________________________________________ 
  (defun change_order (num) 
    (cond 
      ((= num 1) (setq num 2)) 
      ((= num 2) (setq num 1)) 
    ) 
    num 
  ) 
 ;______________________________________________________________________ 
 ;______________________________________________________________________ 
 ;_________________求交点应用函数部分____BY__WKAI__晓东CAD论坛__________ 
 ;___________________2003.12.11.14.33___________________________________ 
 ;____limited__决定求交点时物体是否延伸_________________________________ 
 ;____0 都延伸,1 一号不延伸,2 二号不延伸,3 全部不延伸___________________ 
 
 ;_圆、圆交点___________________________________________________________ 
  (defun cic (c1 c2 limited / c1_cn c2_cn c1_rd c2_rd ins) 
    (IF        (LISTP C1) 
      () 
      (SETQ C1 (ENTGET C1)) 
    ) 
    (IF        (LISTP C2) 
      () 
      (SETQ C2 (ENTGET C2)) 
    ) 
    (setq c1_cn (cdr (assoc 10 c1))) 
    (setq c2_cn (cdr (assoc 10 c2))) 
    (setq c1_rd (cdr (assoc 40 c1))) 
    (setq c2_rd (cdr (assoc 40 c2))) 
    (setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd)) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_圆、圆弧交点_________________________________________________________ 
  (defun cia (c1 c2 limited / ins ins_tmp c1_cn c2_cn c1_rd c2_rd n) 
    (IF        (LISTP C1) 
      () 
      (SETQ C1 (ENTGET C1)) 
    ) 
    (IF        (LISTP C2) 
      () 
      (SETQ C2 (ENTGET C2)) 
    ) 
    (setq c1_cn (cdr (assoc 10 c1))) 
    (setq c2_cn (cdr (assoc 10 c2))) 
    (setq c1_rd (cdr (assoc 40 c1))) 
    (setq c2_rd (cdr (assoc 40 c2))) 
    (setq c2_an1 (cdr (assoc 50 c2))) 
    (setq c2_an2 (cdr (assoc 51 c2))) 
    (setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd)) 
    (if        (or (= limited 2) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_arc n c2_cn c2_an1 c2_an2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (setq ins ins_tmp) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_圆弧、圆弧交点________________________________________________________ 
  (defun aia (c1      c2      limited /              ins     ins_tmp c1_cn 
              c2_cn   c1_rd   c2_rd   c1_an1  c1_an2  c2_an1  c2_an2 
              n 
             ) 
    (IF        (LISTP C1) 
      () 
      (SETQ C1 (ENTGET C1)) 
    ) 
    (IF        (LISTP C2) 
      () 
      (SETQ C2 (ENTGET C2)) 
    ) 
    (setq c1_cn (cdr (assoc 10 c1))) 
    (setq c2_cn (cdr (assoc 10 c2))) 
    (setq c1_rd (cdr (assoc 40 c1))) 
    (setq c2_rd (cdr (assoc 40 c2))) 
    (setq c1_an1 (cdr (assoc 50 c1))) 
    (setq c1_an2 (cdr (assoc 51 c1))) 
    (setq c2_an1 (cdr (assoc 50 c2))) 
    (setq c2_an2 (cdr (assoc 51 c2))) 
    (setq ins (c_int_c c1_cn c1_rd c2_cn c2_rd)) 
    (if        (or (= limited 1) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_arc n c1_cn c1_an1 c1_an2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (setq ins_tmp nil) 
    (if        (or (= limited 2) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_arc n c2_cn c2_an1 c2_an2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_圆、直线交点______________________________________________________ 
  (defun cil (c1 l1 limited / end1 end2 cen rad ins ins_tmp n) 
    (IF        (LISTP C1) 
      () 
      (SETQ C1 (ENTGET C1)) 
    ) 
    (IF        (LISTP L1) 
      () 
      (SETQ L1 (ENTGET L1)) 
    ) 
    (setq end1 (cdr (assoc 10 l1))) 
    (setq end2 (cdr (assoc 11 l1))) 
    (setq cen (cdr (assoc 10 c1))) 
    (setq rad (cdr (assoc 40 c1))) 
    (setq ins (L_INT_C end1 end2 cen rad)) 
    (if        (or (= limited 2) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_line n end1 end2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_圆弧、直线交点______________________________________________________ 
  (defun ail 
         (c1 l1 limited / end1 end2 cen rad ang1 ang2 ins ins_tmp n) 
    (IF        (LISTP C1) 
      () 
      (SETQ C1 (ENTGET C1)) 
    ) 
    (IF        (LISTP L1) 
      () 
      (SETQ L1 (ENTGET L1)) 
    ) 
    (setq end1 (cdr (assoc 10 l1))) 
    (setq end2 (cdr (assoc 11 l1))) 
    (setq cen (cdr (assoc 10 c1))) 
    (setq rad (cdr (assoc 40 c1))) 
    (setq ang1 (cdr (assoc 50 c1))) 
    (setq ang2 (cdr (assoc 51 c1))) 
    (setq ins (L_INT_C end1 end2 cen rad)) 
    (if        (or (= limited 1) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_arc n cen ang1 ang2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (setq ins_tmp nil) 
    (if        (or (= limited 2) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_line n end1 end2) 
            (if        ins_tmp 
              (setq ins_tmp (append ins_tmp (list n))) 
              (setq ins_tmp (list n)) 
            ) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_直线、直线交点______________________________________________________ 
  (defun lil 
         (l1 l2 limited / n ins ins_tmp l1_en1 l1_en2 l2_en1 l2_en2) 
    (if        (listp l1) 
      () 
      (setq l1 (entget l1)) 
    ) 
    (if        (listp l2) 
      () 
      (setq l2 (entget l2)) 
    ) 
    (setq l1_en1 (cdr (assoc 10 l1))) 
    (setq l1_en2 (cdr (assoc 11 l1))) 
    (setq l2_en1 (cdr (assoc 10 l2))) 
    (setq l2_en2 (cdr (assoc 11 l2))) 
    (if        (setq ins_tmp (inters l1_en1 l1_en2 l2_en1 l2_en2 nil)) 
      (setq ins (list ins_tmp)) 
    ) 
    (setq ins_tmp nil) 
    (if        (or (= limited 1) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_line n l1_en1 l1_en2) 
            (setq ins_tmp (list n)) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (setq ins_tmp nil) 
    (if        (or (= limited 2) (= limited 3)) 
      (progn 
        (foreach n ins 
          (if (p_on_line n l2_en1 l2_en2) 
            (setq ins_tmp (list n)) 
          ) 
        ) 
        (setq ins ins_tmp) 
      ) 
    ) 
    (if        ins 
      (setq intersections (append intersections ins)) 
    ) 
    intersections 
  ) 
 ;_复义线、其它实体交点______________________________________________________ 
 ;_如果是两条复义线通过递归求交______________________________________________ 
  (defun pi? (pl1     e2      lim     /              p1      p2      p3 
              pts-pl1 n              sym1    sym2    ang1    ang2 
              pl1-sub-ent 
             ) 
    (if        (listp pl1) 
      () 
      (setq pl1 (entget pl1)) 
    ) 
    (if        (listp e2) 
      () 
      (setq e2 (entget e2)) 
    ) 
    (setq pts-pl1 (GET_ENDS_PL pl1)) 
    (setq n 1) 
    (while (< (+ 1 n) (length pts-pl1)) 
      (setq p1 (nth (- n 1) pts-pl1)) 
      (setq p2 (nth n pts-pl1)) 
      (setq p3 (nth (+ n 1) pts-pl1)) 
      (if (listp p2) 
        (progn 
          (setq sym1 (car p2)) 
          (setq p2 (cdr p2)) 
          (if (= 1 sym1) 
            (setq ang1 (angle p2 p1) 
                  ang2 (angle p2 p3) 
            ) 
            (setq ang1 (angle p2 p3) 
                  ang2 (angle p2 p1) 
            ) 
          ) 
          (setq        pl1-sub-ent 
                 (list (cons 0 "ARC") 
                       (cons 10 p2) 
                       (cons 40 (distance p1 p2)) 
                       (cons 50 ang1) 
                       (cons 51 ang2) 
                       (cons 62 1) 
                 ) 
          ) 
        ) 
        (setq pl1-sub-ent 
               (list (cons 0 "LINE") (cons 10 p1) (cons 11 p3) (cons 62 1)) 
        ) 
      ) 
      (wjmf_Midp pl1-sub-ent e2 lim) 
      (setq n (+ 2 n)) 
    ) 
  ) 
 ;______________________________________________________________________ 
 ;______________________________________________________________________ 
 ;_________________求交点核心函数部分____BY__WKAI__晓东CAD论坛__________ 
 ;___________________2003.12.11.14.33___________________________________ 
 ;______________________________________________________________________ 
 ;_精度设置_____________________________________________________________ 
  (setq min_num 0.0000001) 
 ;___________________圆与圆交点函数,输入值圆心1,半径1,圆心2,半径2.返回值交点表 
  (defun c_int_c (c1_cen c1_rad c2_cen c2_rad / ints c1c2_dis dd ee) 
    (setq c1c2_dis (distance c1_cen c2_cen)) 
    (cond 
      ((equal c1c2_dis (+ c1_rad c2_rad) min_num) 
       (setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad))) 
      ) 
      ((equal c1c2_dis (abs (- c1_rad c2_rad)) min_num) 
       (if (minusp (- c1_rad c2_rad)) 
         (setq ints (list (polar c2_cen (angle c2_cen c1_cen) c2_rad))) 
         (setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad))) 
       ) 
      ) 
      ((and (> c1c2_dis (abs (- c1_rad c2_rad))) 
            (< c1c2_dis (+ c1_rad c2_rad)) 
       ) 
       (progn 
         (setq dd (/ (-        (+ (* c1c2_dis c1c2_dis) (* c1_rad c1_rad)) 
                        (* c2_rad c2_rad) 
                     ) 
                     (* 2 c1c2_dis) 
                  ) 
         ) 
         (setq ee (sqrt (- (* c1_rad c1_rad) (* dd dd)))) 
         (setq 
           ints        (list (polar (polar c1_cen (angle c1_cen c2_cen) dd) 
                             (+ (angle c1_cen c2_cen) (/ pi 2)) 
                             ee 
                      ) 
                ) 
         ) 
         (setq ints 
                (append 
                  ints 
                  (list        (polar (polar c1_cen (angle c1_cen c2_cen) dd) 
                               (- (angle c1_cen c2_cen) (/ pi 2)) 
                               ee 
                        ) 
                  ) 
                ) 
         ) 
 
       ) 
      ) 
    ) 
    ints 
  ) 
 ;___________________直线与圆交点函数,输入值直线端点1,端点2,圆心,半径.返回值交点表 
  (defun L_INT_C (l_end1 l_end2        c_cen c_rad / pedal dist_cen_l int1 int2 
                  ints) 
    (setq pedal (pedal_to_line c_cen l_end1 l_end2)) 
    (setq dist_cen_l (distance pedal c_cen)) 
    (cond 
      ((equal c_rad dist_cen_l min_num) (setq ints (list pedal))) 
      ((> c_rad dist_cen_l) 
       (progn 
         (setq int1 
                (polar pedal 
                       (angle l_end1 l_end2) 
                       (sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l))) 
                ) 
         ) 
         (setq int2 
                (polar pedal 
                       (+ pi (angle l_end1 l_end2)) 
                       (sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l))) 
                ) 
         ) 
         (setq ints (list int1 int2)) 
       ) 
      ) 
    ) 
    ints 
  ) 
 ;______________________________________________________________________ 
 ;______________________________________________________________________ 
 ;_________________辅助测试函数部分____BY__WKAI__晓东CAD论坛____________ 
 ;___________________2003.12.11.14.33___________________________________ 
 ;______________________________________________________________________ 
 ;___________________求点到直线的垂足的函数,输入值测试点,直线端点1,端点2.返回值垂足坐标 
  (defun pedal_to_line (pt pt1 pt2) 
    (inters 
      pt 
      (polar pt (+ (/ pi 2) (angle pt1 pt2)) 1000) 
      pt1 
      pt2 
      nil 
    ) 
  ) 
 ;___________________测试点是否在线段上,输入值测试点,线段端点1,端点2.返回值T或者NIL 
  (defun p_on_line (pt pt1 pt2) 
    (equal (+ (distance pt pt1) (distance pt pt2)) 
           (distance pt1 pt2) 
           min_num 
    ) 
  ) 
 ;___________________测试点是否在圆弧上,输入值测试点,圆心,起始角度,终止角度.返回值T或者NIL 
  (defun p_on_arc (pt cn an1 an2) 
    (if        (> an1 an2) 
      (setq an1 (- an1 (* 2 pi))) 
    ) 
    (or 
      (and (>= (+ (angle cn pt) pi pi) an1) 
           (<= (+ (angle cn pt) pi pi) an2) 
      ) 
      (and (>= (angle cn pt) an1) (<= (angle cn pt) an2)) 
      (and (>= (- (angle cn pt) pi pi) an1) 
           (<= (- (angle cn pt) pi pi) an2) 
      ) 
    ) 
  ) 
 ;___________________获取轻装多义线的各个端点和圆心(如果有),输入值复义线实体名或表.返回值端点及圆心表 
  (DEFUN GET_ENDS_PL (PL      /              dis     dis1    m              N 
                      PT-LST  PT-LST-TMP      sym     mid-p1p2 
                      NTH-PT  p1      p2      pl-tp   pt1     rad 
                      sym 
                     ) 
    (IF        (LISTP PL) 
      () 
      (SETQ PL (ENTGET PL)) 
    ) 
    (SETQ PL-TP (CDR (ASSOC 70 PL))) 
    (FOREACH N PL 
      (IF (OR (= 10 (CAR N)) (= 42 (CAR N))) 
        (SETQ PT-LST (APPEND PT-LST (LIST (CDR N)))) 
      ) 
    ) 
    (IF        (= 1 PL-TP) 
      (SETQ PT-LST (APPEND PT-LST (LIST (CDR (ASSOC 10 PL))))) 
      (SETQ PT-LST (reverse (cdr (reverse PT-LST)))) 
    ) 
    (SETQ M 0) 
    (while (<= (+ 1 m) (LENGTH PT-LST)) 
      (SETQ NTH-PT (NTH M PT-LST)) 
      (IF (LISTP NTH-PT) 
        (SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST NTH-PT))) 
        (PROGN 
          (IF (EQUAL NTH-PT 0 MIN_NUM) 
            (SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST NTH-PT))) 
            (PROGN 
              (SETQ P1 (NTH (- M 1) PT-LST)) 
              (SETQ P2 (NTH (+ M 1) PT-LST)) 
              (SETQ MID-P1P2 (LIST (/ (+ (CAR P1) (CAR P2)) 2) 
                                   (/ (+ (CADR P1) (CADR P2)) 2) 
                             ) 
              ) 
              (SETQ DIS (/ (DISTANCE P1 P2) 2)) 
              (SETQ DIS1 (ABS (* DIS NTH-PT))) 
              (SETQ RAD (/ (+ (* DIS DIS) (* DIS1 DIS1)) (* 2 DIS1))) 
              (IF (minusp NTH-PT) 
                (SETQ 
                  PT1 (append (list -1) 
                              (POLAR MID-P1P2 
                                     (- (ANGLE P1 P2) (/ PI 2)) 
                                     (- RAD DIS1) 
                              ) 
                      ) 
                ) 
                (SETQ 
                  PT1 (append (list 1) 
                              (POLAR MID-P1P2 
                                     (+ (ANGLE P1 P2) (/ PI 2)) 
                                     (- RAD DIS1) 
                              ) 
                      ) 
                ) 
              ) 
              (SETQ PT-LST-TMP (APPEND PT-LST-TMP (LIST PT1))) 
            ) 
          ) 
        ) 
      ) 
      (SETQ M (+ 1 M)) 
    ) 
    (SETQ PT-LST PT-LST-TMP) 
  ) 
 ;_________________________________________________________________________________________ 
 ;_________________________________________________________________________________________ 
 ;_________________________________________________________________________________________ 
 ;_________________________________________________________________________________________ 
)

tc405003 · 发表于 2007-6-17 23:13:36

不知有没有哪位能用起来的，不知是什么原因，加了子程序还是提示错误，图层都没有问题

wujimmy · 发表于 2007-6-17 23:50:43

上面的裤函数下载一下

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

[抛砖引玉]：结构精品程序源码下载

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

相关帖子

[原创]：结构软件]体积配箍率计算程序autolisp源码下载

[原创]：结构修改钢筋的智能程序=>黄金左手程序[源码]

计算书批量打印程序源码