设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › 源码共享 › 【Gu_xl】[原创]实用工具：Block 自动转为Lisp源代码
12345678910... 27下一页
返回列表 发新帖
查看: 67989|回复: 268

【Gu_xl】[原创]实用工具：Block 自动转为Lisp源代码

  [复制链接]
Gu_xl
发表于 2010-7-18 19:39:00 | 显示全部楼层 |阅读模式
本帖最后由 Gu_xl 于 2016-2-25 14:14 编辑


我们在编写AutoCAD应用程序时，经常会使用到符号库，在程序分发时必须将符号库随程序一起分发，一般符号库的图形很多，拷贝分发不是很方便，而且符号库都暴露在任何人面前。为了避免这种情况，将符号在程序中用代码生成是一种很好的办法，但是这么多符号，一句一句用代码来写，好像不太现实！
好了，我这提供一个程序，能够自动将符号转成源代码，成百上千个符号，转瞬间即可全部转为lisp源代码，实现符号库的封装！
请下载附件，将“图块代码生成器.VLX”添加到AutoCAD启动组里，每次AutoCAD启动时程序可自动加载！调用命令：BlockToLisp.
使用方法：
1、假设符号库文件存放在“c:\符号库\”目录下，打开CAD，新建图形，将符号库内DWG文件以块全部插入该图形，使用下列程序可一次性将DWG文件插入图形图形：
代码:

  
(defun c:BlockIn (/ f)
  (setierr)
  (foreach f (vl-sort (gxl-file-Dos_dir "c:\\符号库\\*.dwg") '<)
    (command "-insert" (strcat "c:\\符号库\\" f) '(0 0 0) 1 1  0)
    )
  (reerr)
  )

2、图形插入后，在命令行键入：BlockToLisp，自动生成图块文件MakeBlock.Lsp。
3.、在生成的代码中定义如下函数，
代码:

  
;;;检查图块是否建立，如未建立图块则自动创建图块，参数：B_Name  块名
(defun gxl-Blk-Check (B_Name / curlay B_Name1)
  (setq B_Name1 (gxl-Str-Subst "]" ")" (gxl-Str-Subst "[" "(" B_Name)))
  (setq curlay (getvar "Clayer"))
  (if (not (member B_Name (GXL-TABLE "block")))
    (progn
      (if (or (= 'USUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
	      (= 'SUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
	      )
	(eval (read (strcat "(MakeBlock-" B_Name1 ")"))))
      )
    )
  (setvar "clayer" curlay)
  B_Name
  )

每次插入符号前调用该函数，即可实现图块的插入
，如符号库中有符号名为：路灯.dwg文件，则程序自动生成的函数名为：MakeBlock-路灯 ，块名为：“l路灯”，插入路灯前调用如下函数,即可实现图块“路灯”的创建：
代码:

  
(gxl-Blk-Check  "路灯")

说明：符号图形中实体可包括如下实体：Line/Arc/Circle/Lwpolyline/polyline/spline/Attdef/Block/solid/Hatch/Text/Mtext/Ellipse/Point,除此之外实体不能支持。Block支持嵌套！
附件见5楼！

本帖子中包含更多资源

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

x

本帖被以下淘专辑推荐:

回复

使用道具 举报

Gu_xl
 楼主| 发表于 2010-9-29 12:11:00 | 显示全部楼层
本帖最后由 Gu_xl 于 2012-3-16 20:00 编辑

应大家的要求，现将源码公布如下，供大家共同交流：

  3. ;;; gxl-Blk-Check 检查定义图块
  4. ;;;C:Block->Lisp1 由图块自动转为Lisp代码，可以处理嵌套块，但不能处理复杂的块
  5. ;;; c:BlockIn 在图形中插入某目录下的全部图形，
  6. ;;;******************************************************
  7. ;;;C:Block->Lisp1 由图块自动转为Lisp代码，可以处理嵌套块，但不能处理复杂的块
  8. (DEFUN C:BlockToLisp (/ ListMutiBlock       MakeEntity BlockLisp
  9.    BlockLisp1 blkList    OpenFile  en
  10.    ss    ss1       pt1  pt2
  11.    R    Ang1       Ang2  mk
  12.    mn    tmp_Fn     BlockName  BlockNameList
  13.          ) ;_ /
  14.   ;;;展开嵌套块中最基本图块单元，由低到高顺序
  15. (defun ListMutiBlock (BlockName / rtn listblkref blklst obj obj1 Bname)
  16.   (defun listblkref (Name / objblk rtn1 obj2)
  17.     (setq objblk (vla-item (vla-get-blocks *ACDOCUMENT*) Name)
  18.    rtn1 (list Name))
  19.   (vlax-for obj2 (vla-Item (vla-get-Blocks *AcDocument*) (vla-get-name objblk))
  20.    (if (= "AcDbBlockReference" (vla-get-ObjectName obj2))
  21.      (progn
  22.        (setq Name (vla-get-Name obj2))
  23.      ;(if (listblkref name) (setq rtn1 (append rtn1 (list (list name (listblkref name)))))(setq rtn1 (append (list name))))
  24.      (setq rtn1 (append rtn1 (list  (listblkref name))))
  25.      )
  26.      )
  27.     (setq obj2 nil)
  28.    )
  29.     (setq objblk nil)
  30.     (gxl-ListDumpAtom rtn1)
  31.   )
  32.   (setq obj (vla-item (vla-get-blocks *ACDOCUMENT*) BlockName))
  33.   (vlax-for obj1 obj
  34.      (if (= "AcDbBlockReference" (vla-get-ObjectName obj1))
  35.        (progn
  36.   (setq  Bname (vla-get-Name obj1))
  37.   ;(if (listblkref Bname) (setq rtn (append rtn (list (list Bname (listblkref Bname))))) (setq rtn (append (list Bname))))
  38.      (setq rtn (append rtn  (list  (listblkref Bname))))
  39.      )
  40.    )
  41.     (setq obj1 nil)
  42.    )
  43.   (setq obj nil)
  44. (setq rtn (gxl-RemoveItem nil (gxl-ListDumpAtom rtn)))
  45.   (reverse (setq rtn (gxl-onelist rtn)))
  46. )
  47.   ;;;块写实体,包含Hatch实体
  48.   (defun MakeEntity (obj /        pt1      pt2
  49.     La        Plottable     color
  50.     LaColor       lineType      LineTypeScale
  51.     R        pts      clo
  52.     CONSTANTWIDTH StartTangent  EndTangent
  53.     Height        xz      kb
  54.     qx        Alignment     style
  55.     objTextStyle  FontFile      BigFontFile
  56.     Font        styleHeight   stylebliqueAngle
  57.     styleScale    TextString    textaligmentpoint
  58.     Width        AttachmentPoint
  59.     InsertionPoint       mode
  60.     $Prompt       Tag      Value
  61.     P1        P2      P3
  62.     P4        Center      MajorAxis
  63.     RadiusRatio   StartAngle    EndAngle
  64.     PatternType   PatternName   Associative
  65.     NumberOfLoops PatternScale  PatternAngle
  66.     HatchStyle    HatchObjectType
  67.     InsPt        BName      Xscale
  68.     Yscale        Zscale      Rotation
  69.            lineweight
  70.    ) ;_ obj
  71.     (setq ObjectName (vla-get-ObjectName obj)
  72.    Handle (vla-get-Handle obj)
  73.    )
  74.     (cond ((= "AcDbLine" ObjectName)
  75.     (setq pt1 (GXL-STR-STOA (vlax-curve-getStartPoint obj))
  76.    pt2 (GXL-STR-STOA (vlax-curve-getEndPoint obj))
  77.    La (vla-get-Layer obj)
  78.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  79.    color (vla-get-color obj)
  80.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  81.    lineType (vla-get-linetype obj)
  82.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  83.    lineweight (rtos (vla-get-lineweight obj) 2)
  84.    )
  85.     (WRITE-LINE (strcat "   (setq obj1 (GXL-AX:ADDLINE obj \'" pt1 " \'" pt2 "))") OpenFile)
  86.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  87.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  88.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  89.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  90.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  91.     (WRITE-LINE (strcat
  92.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  93.     (WRITE-LINE (strcat
  94.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  95.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  96.     (WRITE-LINE (strcat
  97.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  98.     (WRITE-LINE (strcat "    (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  99.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  100.     )
  101.    ((= "AcDbCircle" ObjectName)
  102.     (setq pt1 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-center obj)))
  103.    R (rtos (vla-get-radius obj) 2)
  104.    La (vla-get-Layer obj)
  105.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  106.    color (vla-get-color obj)
  107.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  108.    lineType (vla-get-linetype obj)
  109.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  110.    lineweight (rtos (vla-get-lineweight obj) 2)
  111.    )
  112.     (WRITE-LINE (strcat "   (setq obj1 (GXL-AX:ADDCIRCLE obj \'" pt1 " " R "))") OpenFile)
  113.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  114.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  115.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  116.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  117.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  118.     (WRITE-LINE (strcat
  119.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  120.     (WRITE-LINE (strcat
  121.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  122.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  123.     (WRITE-LINE (strcat
  124.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  125.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  126.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  127.     )
  128.    ((= "AcDbArc" ObjectName)
  129.     (setq pt1 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-center obj)))
  130.    R (rtos (vla-get-radius obj) 2)
  131.    Ang1 (rtos (vla-get-StartAngle obj) 2)
  132.    Ang2 (rtos (vla-get-endAngle obj) 2)
  133.    La (vla-get-Layer obj)
  134.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  135.    color (vla-get-color obj)
  136.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  137.    lineType (vla-get-linetype obj)
  138.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  139.    lineweight (rtos (vla-get-lineweight obj) 2)
  140.    )
  141.     (WRITE-LINE (strcat "   (setq obj1 (gxl-AX:AddArc obj \'" pt1 " "  R " "  Ang1 " "  Ang2 "))") OpenFile)
  142.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  143.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  144.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  145.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  146.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  147.     (WRITE-LINE (strcat
  148.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  149.     (WRITE-LINE (strcat
  150.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  151.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  152.     (WRITE-LINE (strcat
  153.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  154.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  155.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  156.     )
  157.    ((= "AcDbPolyline" ObjectName)
  158.     (setq pts (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-Coordinates obj)))
  159.    bulges (cadr (GXL-GET_POLY_DATA obj))
  160.    clo (vla-get-Closed obj)
  161.    CONSTANTWIDTH (vla-get-ConstantWidth obj)
  162.    La (vla-get-Layer obj)
  163.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  164.    color (vla-get-color obj)
  165.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  166.    lineType (vla-get-linetype obj)
  167.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  168.    lineweight (rtos (vla-get-lineweight obj) 2)
  169.    )
  170.     (WRITE-LINE
  171.       (strcat
  172.         "   (setq obj1 (vla-AddLightWeightPolyline obj (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 1 "
  173.         (itoa (length (read pts)))
  174.         "))\'"
  175.         pts
  176.         "))))"
  177.       ) ;_ strcat
  178.       OpenFile
  179.     ) ;_ WRITE-LINE
  180.     (setq n 0)
  181.     (foreach bulge bulges
  182.       (if (/= bulge 0.0) (WRITE-LINE (strcat "  (vla-SetBulge obj1 " (itoa n) " " (rtos bulge 2) ")") OpenFile))
  183.       (setq n (1+ n))
  184.       )
  185.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  186.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  187.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  188.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  189.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  190.     (if (= clo :vlax-true)
  191.       (WRITE-LINE  "   (vla-put-Closed obj1 :vlax-true)" OpenFile)
  192.       )
  193.     (if (not (equal CONSTANTWIDTH 0.0))
  194.       (progn
  195.         (setq CONSTANTWIDTH (rtos CONSTANTWIDTH 2))
  196.         (WRITE-LINE  (strcat "   (vla-put-ConstantWidth obj1 " CONSTANTWIDTH ")") OpenFile)
  197.         )
  198.       )
  199.     (WRITE-LINE (strcat
  200.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  201.     (WRITE-LINE (strcat
  202.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  203.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  204.     (WRITE-LINE (strcat
  205.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  206.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  207.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  208.     )
  209.    ((= "AcDb2dPolyline" ObjectName)
  210.     (setq pts (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-Coordinates obj)))
  211.    bulges (cadr (GXL-GET_POLY_DATA obj))
  212.    clo (vla-get-Closed obj)
  213.    CONSTANTWIDTH (vla-get-ConstantWidth obj)
  214.    La (vla-get-Layer obj)
  215.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  216.    color (vla-get-color obj)
  217.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  218.    lineType (vla-get-linetype obj)
  219.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  220.    lineweight (rtos (vla-get-lineweight obj) 2)
  221.    )
  222.     (WRITE-LINE
  223.       (strcat
  224.         "   (setq obj1 (vla-AddPolyline obj (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 1 "
  225.         (itoa (length (read pts)))
  226.         "))\'"
  227.         pts
  228.         "))))"
  229.       ) ;_ strcat
  230.       OpenFile
  231.     ) ;_ WRITE-LINE
  232.     (setq n 0)
  233.     (foreach bulge bulges
  234.       (if (/= bulge 0.0) (WRITE-LINE (strcat "  (vla-SetBulge obj1 " (itoa n) " " (rtos bulge 2) ")") OpenFile))
  235.       (setq n (1+ n))
  236.       )
  237.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  238.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  239.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  240.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  241.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  242.     (if (= clo :vlax-true)
  243.       (WRITE-LINE  "   (vla-put-Closed obj1 :vlax-true)" OpenFile)
  244.       )
  245.     (if (not (equal CONSTANTWIDTH 0.0))
  246.       (progn
  247.         (setq CONSTANTWIDTH (rtos CONSTANTWIDTH 2))
  248.         (WRITE-LINE  (strcat "   (vla-put-ConstantWidth obj1 " CONSTANTWIDTH ")") OpenFile)
  249.         )
  250.       )
  251.     (WRITE-LINE (strcat
  252.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  253.     (WRITE-LINE (strcat
  254.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  255.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  256.     (WRITE-LINE (strcat
  257.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  258.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  259.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  260.     )
  261.    ((= "AcDbSpline" ObjectName)
  262.     (setq pts (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-FitPoints obj)))
  263.    clo (vla-get-Closed obj)
  264.    La (vla-get-Layer obj)
  265.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  266.    StartTangent (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-StartTangent obj)))
  267.    EndTangent (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-endTangent obj)))
  268.    color (vla-get-color obj)
  269.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  270.    lineType (vla-get-linetype obj)
  271.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  272.    lineweight (rtos (vla-get-lineweight obj) 2)
  273.    )
  274.     (WRITE-LINE
  275.       (strcat
  276.         "   (setq obj1 (vla-AddSpline obj (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 1 "
  277.         (itoa (length (read pts)))
  278.         "))\'"
  279.         pts
  280.         ")) (vlax-3d-point \'" StartTangent ") (vlax-3d-point \'" EndTangent ")))"
  281.       ) ;_ strcat
  282.       OpenFile
  283.     ) ;_ WRITE-LINE
  284.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  285.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  286.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  287.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  288.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  289.     (if (= clo :vlax-true)
  290.       (WRITE-LINE  "   (vla-put-Closed obj1 :vlax-true)" OpenFile)
  291.       )
  292.    
  293.     (WRITE-LINE (strcat
  294.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  295.     (WRITE-LINE (strcat
  296.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  297.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  298.     (WRITE-LINE (strcat
  299.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  300.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  301.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  302.     )
  303.    ((= "AcDbText" ObjectName)
  304.     (setq pt1 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-InsertionPoint obj)))
  305.    Height (rtos (vla-get-Height obj) 2)
  306.    xz (rtos (vla-get-Rotation obj) 2)
  307.    kb (rtos (vla-get-ScaleFactor obj) 2)
  308.    qx (rtos (vla-get-ObliqueAngle obj) 2)
  309.    Alignment (vla-get-alignment obj)
  310.    style (vla-get-StyleName obj)
  311.    objTextStyle (vla-Item (vla-get-textstyles *AcDocument*) style)
  312.    FontFile (vla-get-FontFile objTextStyle)
  313.    BigFontFile (vla-get-BigFontFile objTextStyle)
  314.    Font (strcat FontFile "," BigFontFile)
  315.    styleHeight (rtos (vla-get-Height objTextStyle) 2)
  316.    stylebliqueAngle (rtos (vla-get-ObliqueAngle objTextStyle)2)
  317.    ;styleScale (rtos (vla-get-ScaleFactor objTextStyle) 2)
  318.    TextString (vla-get-TextString obj)
  319.    La (vla-get-Layer obj)
  320.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  321.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  322.    color (vla-get-color obj)
  323.    textaligmentpoint (GXL-STR-STOA (GXL-NUM-AX->LISPVALUE(vla-get-TextAlignmentPoint obj)))
  324.    lineweight (rtos (vla-get-lineweight obj) 2)
  325.    )
  326.     (cond ((= 0 Alignment) (setq Alignment "acAlignmentLeft"))
  327.    ((= 1 Alignment) (setq Alignment "acAlignmentCenter"))
  328.    ((= 2 Alignment) (setq Alignment "acAlignmentRight"))
  329.    ((= 3 Alignment) (setq Alignment "acAlignmentAligned"))
  330.    ((= 4 Alignment) (setq Alignment "acAlignmentMiddle"))
  331.    ((= 5 Alignment) (setq Alignment "acAlignmentFit"))
  332.    ((= 6 Alignment) (setq Alignment "acAlignmentTopLeft"))
  333.    ((= 7 Alignment) (setq Alignment "acAlignmentTopCenter"))
  334.    ((= 8 Alignment) (setq Alignment "acAlignmentTopRight"))
  335.    ((= 9 Alignment) (setq Alignment "acAlignmentMiddleLeft"))
  336.    ((= 10 Alignment) (setq Alignment "acAlignmentMiddleCenter"))
  337.    ((= 11 Alignment) (setq Alignment "acAlignmentMiddleRight"))
  338.    ((= 12 Alignment) (setq Alignment "acAlignmentBottomLeft"))
  339.    ((= 13 Alignment) (setq Alignment "acAlignmentBottomCenter"))
  340.    ((= 14 Alignment) (setq Alignment "acAlignmentBottomRight"))
  341.    (t (setq Alignment (rtos Alignment 2)))
  342.    )
  343.     (WRITE-LINE (strcat "   (gxl-AX:MakeStyle "" style "" 0.0 1 0 "" FontFile "" "" BigFontFile "")") OpenFile)
  344.     (WRITE-LINE (strcat "   (setq obj1 (gxl-AX:AddText obj "" TextString "" \'" pt1 " " Height " " xz " " kb " " qx " " Alignment " "" style ""))") OpenFile)
  345.     (if (/= Alignment "acAlignmentLeft") (WRITE-LINE (strcat "   (vla-put-TextAlignmentPoint obj1 (vlax-3d-point \'" textaligmentpoint "))") OpenFile))
  346.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  347.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  348.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  349.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  350.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  351.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  352.     )
  353.    ((= "AcDbMText" ObjectName)
  354.     (setq pt1 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-InsertionPoint obj)))
  355.    Height (rtos (vla-get-Height obj) 2)
  356.    xz (rtos (vla-get-Rotation obj) 2)
  357.    Width (rtos (vla-get-width obj) 2)
  358.    style (vla-get-StyleName obj)
  359.    objTextStyle (vla-Item (vla-get-textstyles *AcDocument*) style)
  360.    FontFile (vla-get-FontFile objTextStyle)
  361.    BigFontFile (vla-get-BigFontFile objTextStyle)
  362.    Font (strcat FontFile "," BigFontFile)
  363.    styleHeight (rtos (vla-get-Height objTextStyle) 2)
  364.    stylebliqueAngle (rtos (vla-get-ObliqueAngle objTextStyle)2)
  365.    TextString (vla-get-TextString obj)
  366.    La (vla-get-Layer obj)
  367.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  368.    color (vla-get-color obj)
  369.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  370.    AttachmentPoint (vla-get-AttachmentPoint obj)
  371.    lineweight (rtos (vla-get-lineweight obj) 2)
  372.    )
  373.     (cond ((= 1 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointTopLeft"))
  374.    ((= 2 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointTopCenter"))
  375.    ((= 3 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointTopRight"))
  376.    ((= 4 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointMiddleLeft"))
  377.    ((= 5 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointMiddleCenter"))
  378.    ((= 6 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointMiddleRight"))
  379.    ((= 7 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointBottomLeft"))
  380.    ((= 8 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointBottomCenter"))
  381.    ((= 9 AttachmentPoint) (setq AttachmentPoint "acAttachmentPointBottomRight"))
  382.    )
  383.     (WRITE-LINE (strcat "   (gxl-AX:MakeStyle "" style "" 0.0 1 0  "" FontFile "" "" BigFontFile "")") OpenFile)
  384.     (WRITE-LINE (strcat "   (setq obj1 (gxl-AX:AddMText obj "  "\'" pt1 " " Width " "" (substr (gxl-strunparse (GXL-STRPARSE TextString "\") "\\\") 2) "" " Height " " xz   " "" style ""))") OpenFile)
  385.     (WRITE-LINE (strcat "   (vla-put-AttachmentPoint obj1 " AttachmentPoint ")") OpenFile)
  386.     (WRITE-LINE (strcat "   (vla-put-InsertionPoint obj1 (vlax-3d-point \'" pt1 "))") OpenFile)
  387.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  388.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  389.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  390.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  391.     )
  392.    ((= "AcDbAttributeDefinition" ObjectName)
  393.     (setq InsertionPoint (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-InsertionPoint obj)))
  394.    Height (rtos (vla-get-Height obj) 2)
  395.    mode (vla-get-mode obj)
  396.    $Prompt (vla-get-promptString obj)
  397.    Tag (vla-get-TagString obj)
  398.    Value (vla-get-TextString obj)
  399.    Alignment (vla-get-alignment obj)
  400.    style (vla-get-StyleName obj)
  401.    objTextStyle (vla-Item (vla-get-textstyles *AcDocument*) style)
  402.    FontFile (vla-get-FontFile objTextStyle)
  403.    BigFontFile (vla-get-BigFontFile objTextStyle)
  404.    Font (strcat FontFile "," BigFontFile)
  405.    styleHeight (rtos (vla-get-Height objTextStyle) 2)
  406.    stylebliqueAngle (rtos (vla-get-ObliqueAngle objTextStyle)2)
  407.    kb (rtos (vla-get-ScaleFactor obj) 2)
  408.    La (vla-get-Layer obj)
  409.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  410.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  411.    color (vla-get-color obj)
  412.    textaligmentpoint (GXL-STR-STOA (GXL-NUM-AX->LISPVALUE(vla-get-TextAlignmentPoint obj)))
  413.    )
  414.     (cond ((= 0 Alignment) (setq Alignment "acAlignmentLeft"))
  415.    ((= 1 Alignment) (setq Alignment "acAlignmentCenter"))
  416.    ((= 2 Alignment) (setq Alignment "acAlignmentRight"))
  417.    ((= 3 Alignment) (setq Alignment "acAlignmentAligned"))
  418.    ((= 4 Alignment) (setq Alignment "acAlignmentMiddle"))
  419.    ((= 5 Alignment) (setq Alignment "acAlignmentFit"))
  420.    ((= 6 Alignment) (setq Alignment "acAlignmentTopLeft"))
  421.    ((= 7 Alignment) (setq Alignment "acAlignmentTopCenter"))
  422.    ((= 8 Alignment) (setq Alignment "acAlignmentTopRight"))
  423.    ((= 9 Alignment) (setq Alignment "acAlignmentMiddleLeft"))
  424.    ((= 10 Alignment) (setq Alignment "acAlignmentMiddleCenter"))
  425.    ((= 11 Alignment) (setq Alignment "acAlignmentMiddleRight"))
  426.    ((= 12 Alignment) (setq Alignment "acAlignmentBottomLeft"))
  427.    ((= 13 Alignment) (setq Alignment "acAlignmentBottomCenter"))
  428.    ((= 14 Alignment) (setq Alignment "acAlignmentBottomRight"))
  429.    (t (setq Alignment (rtos Alignment 2)))
  430.    )
  431.     (cond ((= 0 mode) (setq mode "acAttributeModeNormal"))
  432.    ((= 1 mode) (setq mode "acAttributeModeInvisible"))
  433.    ((= 2 mode) (setq mode "acAttributeModeConstant"))
  434.    ((= 3 mode) (setq mode "acAttributeModeVerify"))
  435.    ((= 4 mode) (setq mode "acAttributeModePreset"))
  436.    (t (setq mode (rtos mode 2)))
  437.    )
  438.     (WRITE-LINE (strcat "   (gxl-MakeStyle "" style "" 0.0 1 0 1 "" FontFile "" "" BigFontFile "")") OpenFile)
  439.     (WRITE-LINE (strcat "   (setq obj1 (GXL-AX:ADDATT obj " Height " "  Mode " ""  $Prompt "" \'"  InsertionPoint " ""  Tag  "" """ "))") OpenFile)
  440.     (WRITE-LINE (strcat "   (vla-put-ScaleFactor obj1 " kb ")") OpenFile)
  441.            (WRITE-LINE (strcat "   (vla-put-alignment obj1 " Alignment ")") OpenFile)
  442.            ;(WRITE-LINE (strcat "  (vla-put-TextAlignmentPoint obj1 (vlax-3d-point \'" InsertionPoint "))") OpenFile)
  443.     (if (/= Alignment "acAlignmentLeft") (WRITE-LINE (strcat "   (vla-put-TextAlignmentPoint obj1 (vlax-3d-point \'" textaligmentpoint "))") OpenFile))
  444.            (WRITE-LINE (strcat "   (vla-put-StyleName obj1 "" style "")") OpenFile)
  445.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  446.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La "") " Plottable ")") OpenFile))
  447.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  448.     (if (/= "0" La) (WRITE-LINE (strcat "   (vla-put-Layer obj1 "" La "")") OpenFile))
  449.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  450.     )
  451.    ((= "AcDbPoint" ObjectName)
  452.     (setq InsertionPoint (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-coordinates obj)))
  453.    La (vla-get-Layer obj)
  454.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  455.    color (vla-get-color obj)
  456.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  457.    )
  458.     (WRITE-LINE (strcat "   (setq obj1 (gxl-AX:AddPoint obj \'" InsertionPoint "))") OpenFile)
  459.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  460.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  461.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  462.     (if (/= "0" La) (WRITE-LINE (strcat "   (vla-put-Layer obj1 "" La "")") OpenFile))
  463.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  464.    
  465.     )
  466.    ((= "AcDbSolid" ObjectName)
  467.     (setq P1 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-coordinate obj 0)))
  468.    P2 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-coordinate obj 1)))
  469.    P3 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-coordinate obj 2)))
  470.    P4 (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-coordinate obj 3)))
  471.    La (vla-get-Layer obj)
  472.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  473.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  474.    color (vla-get-color obj)
  475.    )
  476.     (WRITE-LINE (strcat "(setq obj1 (gxl-AX:AddSolid obj \'" p1 " \'" p2 " \'" p3 " \'" p4 "))") OpenFile)
  477.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  478.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  479.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  480.     (if (/= "0" La) (WRITE-LINE (strcat "   (vla-put-Layer obj1 "" La "")") OpenFile))
  481.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)   
  482.     )
  483.    ((= "AcDbEllipse" ObjectName)
  484.     (setq Center (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-center obj)))
  485.    MajorAxis (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-MajorAxis obj)))
  486.    RadiusRatio (rtos (vla-get-RadiusRatio obj) 2)
  487.    StartAngle (rtos (vla-get-StartAngle obj) 2)
  488.    EndAngle (rtos (vla-get-endAngle obj) 2)
  489.    La (vla-get-Layer obj)
  490.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  491.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  492.    color (vla-get-color obj)
  493.    lineType (vla-get-linetype obj)
  494.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  495.    lineweight (rtos (vla-get-lineweight obj) 2)
  496.    )
  497.     (WRITE-LINE (strcat "   (setq obj1 (GXL-AX:ADDELLIPSE obj \'" Center " \'"  MajorAxis " " RadiusRatio  "))") OpenFile)
  498.     (WRITE-LINE (strcat "   (vla-put-StartAngle obj1 " StartAngle ")") OpenFile)
  499.     (WRITE-LINE (strcat "   (vla-put-endAngle obj1 " EndAngle ")") OpenFile)
  500.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  501.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  502.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  503.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  504.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  505.     (WRITE-LINE (strcat
  506.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  507.     (WRITE-LINE (strcat
  508.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  509.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  510.     (WRITE-LINE (strcat
  511.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  512.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  513.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-lineweight obj1 "" lineweight "")") OpenFile))
  514.     )
  515.            ((= "AcDbHatch" ObjectName)
  516.     (setq PatternType (vla-get-PatternType obj)
  517.    PatternName  (vla-get-PatternName obj)
  518.    Associative (GXL-STR-STOA (vla-get-AssociativeHatch obj))
  519.    NumberOfLoops (vla-get-NumberOfLoops obj)
  520.    PatternScale (rtos (vla-get-PatternScale obj) 2)
  521.    PatternAngle (rtos (vla-get-PatternAngle obj) 2)
  522.    HatchStyle (vla-get-HatchStyle obj)
  523.    HatchObjectType (vla-get-HatchObjectType obj)
  524.    La (vla-get-Layer obj)
  525.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  526.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  527.    color (vla-get-color obj)
  528.    lineType (vla-get-linetype obj)
  529.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  530.    lineweight (rtos (vla-get-lineweight obj) 2)
  531.    )
  532.     (if (/= 0 NumberOfLoops)
  533.       (progn
  534.     (cond ((= 0 PatternType) (setq PatternType "acHatchPatternTypePreDefined"))
  535.    ((= 1 PatternType) (setq PatternType "acHatchPatternTypeUserDefined"))
  536.    ((= 2 PatternType) (setq PatternType "acHatchPatternTypeCustomDefined"))
  537.    )
  538.     (cond ((= 0 HatchObjectType) (setq HatchObjectType "AcHatchObject"))
  539.    ((= 1 HatchObjectType) (setq HatchObjectType "AcGradientObject"))
  540.    )
  541.     (cond ((= 0 HatchStyle) (setq HatchStyle "acHatchStyleNormal"))
  542.    ((= 1 HatchStyle) (setq HatchStyle "acHatchStyleOuter"))
  543.    ((= 2 HatchStyle) (setq HatchStyle "acHatchStyleIgnore"))
  544.    )
  545.     (setq Loops nil
  546.    k 0)
  547.     (repeat NumberOfLoops
  548.       (vla-getloopat obj k 'OuterLoop)
  549.       (setq Loops (append Loops (list OuterLoop)))
  550.       (setq k (1+ k))
  551.       )
  552.     (setq k 0)
  553.     (foreach Arays Loops
  554.       (if (= (type Arays) 'safearray)
  555.         (progn
  556.    (setq Arayl (GXL-NUM-AX->LISPVALUE Arays))
  557.       (WRITE-LINE  "    (setq HatchobjAray nil)" OpenFile)
  558.       (if (= k 0)
  559.         (progn
  560.    (WRITE-LINE (strcat "   (setq objHatch (vla-AddHatch obj " PatternType " "" PatternName "" " Associative " " HatchObjectType "))") OpenFile)
  561.    (foreach HatchObj Arayl
  562.      (MakeEntity HatchObj);此处嵌套调用容易溢出
  563.      (WRITE-LINE  "(setq HatchobjAray (Append HatchobjAray (list obj1)))" OpenFile)
  564.      )
  565.    (WRITE-LINE  "(setq HatchobjAray (gxl-num-ObjList->AX:Array HatchobjAray))" OpenFile)
  566.    ;(WRITE-LINE  "(vla-AppendOuterLoop objHatch HatchobjAray)" OpenFile)
  567.    (WRITE-LINE "(setq axErr1 (VL-CATCH-ALL-APPLY \'vla-AppendOuterLoop (list objHatch HatchobjAray)))" OpenFile)
  568.    );_ progn
  569.         (progn
  570.    (foreach HatchObj Arayl
  571.      (MakeEntity HatchObj);此处嵌套调用容易溢出
  572.      (WRITE-LINE  "(setq HatchobjAray (Append HatchobjAray (list obj1)))" OpenFile)
  573.      )
  574.    (WRITE-LINE  "(setq HatchobjAray (gxl-num-ObjList->AX:Array HatchobjAray))" OpenFile)
  575.    ;(WRITE-LINE  "(vla-AppendInnerLoop objHatch HatchobjAray)" OpenFile)
  576.    (WRITE-LINE "(setq axErr (VL-CATCH-ALL-APPLY \'vla-AppendInnerLoop (list objHatch HatchobjAray)))" OpenFile)
  577.    );_ progn
  578.         );_ if
  579.       (setq k (1+ k))
  580.       )
  581.         )
  582.       );_ foreach
  583.     (WRITE-LINE   "   (if (not (VL-CATCH-ALL-ERROR-P axErr1))" OpenFile)
  584.     (WRITE-LINE   "     (progn" OpenFile)
  585.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  586.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  587.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  588.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer objHatch "" La "")") OpenFile))
  589.     (WRITE-LINE (strcat "   (vla-put-color objHatch "" (itoa color) "")") OpenFile)
  590.     (if (not(or (= "-1" lineweight)(= "-2" lineweight)(= "-3" lineweight))) (WRITE-LINE (strcat "   (vla-put-layer objHatch "" lineweight "")") OpenFile))
  591.     (WRITE-LINE (strcat
  592.     "   (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  593.     (WRITE-LINE (strcat
  594.     "   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  595.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  596.     (WRITE-LINE (strcat
  597.     "   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype objHatch "" lineType ""))") OpenFile)
  598.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale objHatch " LineTypeScale ")") OpenFile)
  599.     (WRITE-LINE (strcat "   (vla-put-PatternScale objHatch " PatternScale ")") OpenFile)
  600.     (WRITE-LINE (strcat "   (vla-put-PatternAngle objHatch " PatternAngle ")") OpenFile)
  601.     (WRITE-LINE (strcat "   (vla-put-HatchStyle objHatch " HatchStyle ")") OpenFile)
  602.     (WRITE-LINE   "     )" OpenFile)
  603.     (WRITE-LINE   "    )" OpenFile)
  604.     );_ progn
  605.       );_ if
  606.     )
  607.    ((= "AcDbBlockReference" ObjectName)
  608.     ;(BlockLisp (vla-get-Name obj))
  609.    
  610.     (setq InsPt (GXL-STR-STOA (gxl-num-ax->lispvalue(vla-get-InsertionPoint obj)))
  611.    BName (vla-get-Name obj)
  612.    Xscale (rtos (vla-get-XScaleFactor obj) 2)
  613.    Yscale (rtos (vla-get-YScaleFactor obj))
  614.    Zscale (rtos (vla-get-ZScaleFactor obj))
  615.    Rotation (rtos (vla-get-Rotation obj))
  616.    La (vla-get-Layer obj)
  617.    Plottable (GXL-STR-STOA (vla-get-Plottable (vla-Item (vla-get-layers *ACDOCUMENT*) La)))
  618.    LaColor (vla-get-color (vla-item (vla-get-Layers *ACDOCUMENT*) La))
  619.    color (vla-get-color obj)
  620.    lineType (vla-get-linetype obj)
  621.    LineTypeScale (rtos (vla-get-LineTypeScale obj))
  622.    )
  623.    ; (WRITE-LINE (strcat "    (if (not (member ""  BName "" (gxl-table "block"))) (BlockLisp "" BName ""))") OpenFile)
  624.     ;(BlockLisp BName)
  625.      (WRITE-LINE (strcat "   (setq obj1 (vla-InsertBlock obj (vlax-3d-point \'"InsPt ") "" BName "" " Xscale " " Yscale " " ZScale " " Rotation "))") OpenFile)
  626.     (if (/= "0" La)(WRITE-LINE (strcat "   (setq objLay (vla-add (vla-get-Layers *ACDOCUMENT*) "" La ""))") OpenFile))
  627.     (WRITE-LINE (strcat "   (vla-put-color (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") "" (itoa Lacolor) "")") OpenFile)
  628.     (if (/= Plottable ":vlax-true")(WRITE-LINE (strcat "   (vla-put-Plottable (vla-item (vla-get-Layers *ACDOCUMENT*) "" La"") " Plottable ")") OpenFile))
  629.     (if (/= "0" La)(WRITE-LINE (strcat "   (vla-put-layer obj1 "" La "")") OpenFile))
  630.     (WRITE-LINE (strcat "   (vla-put-color obj1 "" (itoa color) "")") OpenFile)
  631.     (WRITE-LINE (strcat
  632.     "    (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) "" lineType "" "acadiso.lin")))") OpenFile)
  633.     (WRITE-LINE (strcat
  634.     "    (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY \'vla-load (list (vla-get-Linetypes *ACDOCUMENT*) ""
  635.     lineType "" "EstateCADTools.lin"))))") OpenFile)
  636.     (WRITE-LINE (strcat
  637.     "    (if (not (VL-CATCH-ALL-ERROR-P axErr)) (vla-put-linetype obj1 "" lineType ""))") OpenFile)
  638.     (WRITE-LINE (strcat "   (vla-put-LinetypeScale obj1 " LineTypeScale ")") OpenFile)
  639.     )
  640.    (t nil)
  641.    )
  642.     )
  643.   
  644. ;;;图块定义
  645.   (defun BlockLisp (blkName / EnObj Handle HatchEntList enObj ObjectName NumberOfLoops Loops k OuterLoop Arays Arayl a)
  646.     ;(if (> (vla-get-Count (vla-Item (vla-get-Blocks *AcDocument*) blkName)) 0)
  647.       (progn
  648.    ;(WRITE-LINE (strcat " (if (not (member "" blkName ""( gxl-table "block")))") OpenFile)
  649.    ;(WRITE-LINE  "  (progn" OpenFile)
  650.    (WRITE-LINE   "   (setvar "clayer" "0")" OpenFile)
  651.    (WRITE-LINE (strcat "   (setq obj (GXL-AX:ADDBLOCK \'(0 0 0) "" blkName ""))") OpenFile)
  652.    ;;;遍历blkName，找出Hatch关联的边界实体的Handle，添加到表 HatchEntList 中
  653.    (setq HatchEntList nil)
  654.    ; 不支持 Hatch 实体，Hatch容易溢出
  655.    (vlax-for enObj (vla-Item (vla-get-Blocks *AcDocument*) blkName)
  656.      (setq ObjectName (vla-get-ObjectName enObj)
  657.    Handle (vla-get-Handle enObj)
  658.    )
  659.      (if (= "AcDbHatch" ObjectName)
  660.        (progn
  661.   (setq NumberOfLoops (vla-get-NumberOfLoops enObj))
  662.   
  663.     (setq Loops '()
  664.    k 0)
  665.     (repeat NumberOfLoops
  666.       (vla-getloopat enObj k 'OuterLoop)
  667.       (setq Loops (append Loops (list OuterLoop)))
  668.       (setq k (1+ k))
  669.       )
  670.   (foreach Arays Loops
  671.     ;;;问题出在这儿，溢出？(GXL-NUM-AX->LISPVALUE OuterLoop)
  672.       (if (= (type Arays) 'safearray)
  673.         (progn
  674.    (setq Arayl (GXL-NUM-AX->LISPVALUE Arays))
  675.     (foreach a  Arayl (setq HatchEntList (cons (vla-get-handle a) HatchEntList))(setq a nil))
  676.    )
  677.         )
  678.     )
  679.   
  680.   )
  681.        )
  682.      (setq enobj nil)
  683.     )
  684.    ;(setq HatchEntList nil)
  685.   (vlax-for enObj (vla-Item (vla-get-Blocks *AcDocument*) blkName)
  686.          
  687.     (setq Handle (vla-get-Handle enObj))
  688.    
  689.      (if (not (member Handle HatchEntList)) (MakeEntity enObj))
  690.     (setq enobj nil)
  691.     )
  692.    
  693.   ;(WRITE-LINE "    )" OpenFile)
  694.   ;(WRITE-LINE "   )" OpenFile)
  695.   );_ progn
  696.       ;);_ if

  698.       )
  699.   ;;;本函数添加了图块是否存在的判断
  700.   (defun BlockLisp1 (blkName / EnObj Handle HatchEntList enObj ObjectName NumberOfLoops Loops k OuterLoop Arays Arayl a)
  701.     ;(if (> (vla-get-Count (vla-Item (vla-get-Blocks *AcDocument*) blkName)) 0)
  702.       (progn
  703. ;;;添加图块是否存在判断语句
  704.    (WRITE-LINE (strcat " (if (not (member "" blkName ""( gxl-table "block")))") OpenFile)
  705.    (WRITE-LINE  "  (progn" OpenFile)
  706.    (WRITE-LINE   "   (setvar "clayer" "0")" OpenFile)
  707.    (WRITE-LINE (strcat "   (setq obj (GXL-AX:ADDBLOCK \'(0 0 0) "" blkName ""))") OpenFile)
  708.       ;;;遍历blkName，找出Hatch关联的边界实体的Handle，添加到表 HatchEntList 中
  709.    (setq HatchEntList nil)
  710.    (vlax-for enObj (vla-Item (vla-get-Blocks *AcDocument*) blkName)
  711.      (setq ObjectName (vla-get-ObjectName enObj)
  712.    Handle (vla-get-Handle enObj)
  713.    )
  714.      (if (= "AcDbHatch" ObjectName)
  715.        (progn
  716.   (setq NumberOfLoops (vla-get-NumberOfLoops enObj))
  717.     (setq Loops '()
  718.    k 0)
  719.     (repeat NumberOfLoops
  720.       (vla-getloopat enObj k 'OuterLoop)
  721.       (setq Loops (append Loops (list OuterLoop)))
  722.       (setq k (1+ k))
  723.       )
  724.   (foreach Arays Loops
  725.     (if (= (type Arays) 'safearray)
  726.       (progn
  727.       (setq Arayl (GXL-NUM-AX->LISPVALUE Arays))
  728.     (foreach a  Arayl (setq HatchEntList (cons (vla-get-handle a) HatchEntList))(setq a nil))
  729.       )
  730.       )
  731.     )
  732.   
  733.   )
  734.        )
  735.      (setq enobj nil)
  736.     )
  737.    (vlax-for enObj (vla-Item (vla-get-Blocks *AcDocument*) blkName)
  738.     (setq Handle (vla-get-Handle enObj))
  739.     (if (not (member Handle HatchEntList)) (MakeEntity enObj))
  740.      (setq enobj nil)
  741.     )
  742.    
  743.   (WRITE-LINE "    )" OpenFile)
  744.   (WRITE-LINE "   )" OpenFile)
  745.   );_ progn
  746.       ;);_ if

  748.       )
  749.   ;;;主程序
  750.   ;(setierr)
  751.   ;(setq OpenFile (open "MakeBlock.Lsp" "w"))
  752.   (setq OpenFile (open (setq tmp_Fn (vl-filename-mktemp)) "w"))
  753.   ;(setq enss (ssget "x" '((0 . "insert"))))
  754.   ;;;剔除无名块
  755.   (setq BlockNameList (VL-REMOVE-IF '(lambda (x) (= "*U" (substr x 1 2))) (vl-sort (GXL-TABLE "block") '<)))
  756.   (if (not BlockNameList)(progn (alert "图形中没有图块可供生成代码！") (abcdefg)))
  757.   (setq ;enss (GXL-SEL-SS->LIST enss)
  758. mk 0
  759. mn 0)
  760.   ;(WRITE-LINE "(defun Create_block0 (Name / obj obj1)" OpenFile)
  761.   ;(WRITE-LINE " (cond " OpenFile)
  762.   (foreach blockName BlockNameList;enblk enss
  763.     (setq blockName1 (gxl-Str-Subst "]" ")" (gxl-Str-Subst "[" "(" blockName)))
  764.      (WRITE-LINE (strcat "(defun MakeBlock-" blockName1 " (/ obj obj1 obj2 objHatch HatchobjAray )") OpenFile)
  765.    ;;;列出嵌套子块，由低到高定义块实体
  766.     (setq BL (ListMutiBlock blockName))
  767.     (if bl (mapcar '(lambda (x) (BlockLisp1 x)) BL))
  768.     ;;;定义非块实体
  769.     (BlockLisp blockName)
  770.     (WRITE-LINE "  )" OpenFile)
  771.     );_ Foreach
  772.   
  773.   ;;;定义调用函数 gxl-Blk-Check
  774.   ;|
  775.   (WRITE-LINE "(defun gxl-Blk-Check (B_Name / curlay B_Name1)" OpenFile)
  776.   (WRITE-LINE "  (setq B_Name1 (gxl-Str-Subst "]" ")" (gxl-Str-Subst "[" "(" B_Name)))" OpenFile)
  777.   (WRITE-LINE "  (setq curlay (getvar "Clayer"))" OpenFile)
  778.   (WRITE-LINE "  (if (not (member B_Name (GXL-TABLE "block")))" OpenFile)
  779.   (WRITE-LINE "    (progn" OpenFile)
  780.   (WRITE-LINE "(if (or (= \'USUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))" OpenFile)
  781.   (WRITE-LINE "        (= \'SUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))" OpenFile)
  782.   (WRITE-LINE "      )" OpenFile)
  783.   (WRITE-LINE "    (eval (read (strcat "(MakeBlock-" B_Name1 ")"))))" OpenFile)
  784.   (WRITE-LINE "      )" OpenFile)
  785.   (WRITE-LINE "    )" OpenFile)
  786.   (WRITE-LINE "  (setvar "clayer" curlay)" OpenFile)
  787.   (WRITE-LINE "  B_Name" OpenFile)
  788.   (WRITE-LINE "  )" OpenFile)
  789.   |;
  790.     (close OpenFile)
  791.   ;(startapp "notepad.exe" "MakeBlock.Lsp")
  792.   (startapp "notepad.exe" tmp_Fn)
  793.   ;(reerr)
  794.   )
  795. ;;; c:BlockIn 在图形中插入"E:\\lisp\\symbol"目录下的全部图形，
  796. (defun c:BlockIn (/ f)
  797.   (setierr)
  798.   (foreach f (vl-sort (gxl-file-Dos_dir "E:\\lisp\\symbol\\*.dwg") '<)
  799.     (command "-insert" (strcat "E:\\lisp\\symbol\" f) '(0 0 0) 1 1  0)
  800.     )
  801.   (reerr)
  802.   )
  803. ;;; gxl-Blk-Check 检查定义图块
  804. (defun gxl-Blk-Check (B_Name / curlay B_Name1)
  805.   (setq B_Name1 (gxl-Str-Subst "]" ")" (gxl-Str-Subst "[" "(" B_Name)))
  806.   (setq curlay (getvar "Clayer"))
  807.   (if (not (member B_Name (GXL-TABLE "block")))
  808.     (progn
  809.       (if (or (= 'USUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
  810.        (= 'SUBR (type (eval(read (strcat "MakeBlock-" B_Name1)))))
  811.        )
  812. (eval (read (strcat "(MakeBlock-" B_Name1 ")"))))
  813.       )
  814.     )
  815.   (setvar "clayer" curlay)
  816.   B_Name
  817.   )

代码中涉及到一些自定义公用函数，需要前贴中附件打包的函数支持！
回复 支持 2 反对 0

使用道具 举报

hpy
发表于 2010-7-22 09:07:00 | 显示全部楼层

使用程序出现下列问题是怎么回事？cad版本2008

命令: blocktolisp
; 错误: ActiveX 服务器返回错误: 无效索引。

回复 支持 0 反对 1

使用道具 举报

stonedesign
发表于 2021-10-29 08:47:55 | 显示全部楼层
加载后出现此软件的使用未获得软件作者的授权呀     说QQ联系 919420899
回复 支持 反对

使用道具 举报

yoyoho
发表于 2010-7-20 18:10:00 | 显示全部楼层

哇!不是源码啊!

只能纯欣赏了!

感谢楼主分享!

回复 支持 反对

使用道具 举报

Gu_xl
 楼主| 发表于 2010-7-22 11:21:00 | 显示全部楼层
我机器未装2008版，所以程序未经2008版本测试，在2000~2005有效！等我装了08版我会再调试一下！
回复 支持 反对

使用道具 举报

Gu_xl
 楼主| 发表于 2010-7-25 18:53:00 | 显示全部楼层
本帖最后由 Gu_xl 于 2013-3-14 12:33 编辑

2010年7月25日对块中含PolyLine线进行了修改

本帖子中包含更多资源

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

x
回复 支持 反对

使用道具 举报

461045462
发表于 2010-8-2 06:32:00 | 显示全部楼层

Block 自动转为Lisp源代码 下载来看看学习学习

不知道在2006上能否用

谢谢楼主

回复 支持 反对

使用道具 举报

sachindkini
发表于 2010-8-2 14:49:00 | 显示全部楼层

dear sir

plz shere sample file

 

回复 支持 反对

使用道具 举报

自贡黄明儒
发表于 2010-8-2 22:49:00 | 显示全部楼层
看起来是很神奇的,明天我试试
回复 支持 反对

使用道具 举报

20100
发表于 2010-8-6 11:04:00 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复 支持 反对

使用道具 举报

hpy
发表于 2010-8-9 13:23:00 | 显示全部楼层
如果能支持高版本的CAD就更好了。
回复 支持 反对

使用道具 举报

12345678910... 27下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-12-29 15:20 , Processed in 0.235392 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表