注册 登录
明经CAD社区 返回首页

wowan1314的个人空间 http://www.mjtd.com/?282351 [收藏] [复制] [分享] [RSS]

日志

VLA方法处理面域,含数字排序,切换快捷键,快速打印,PL3种画法。

热度 1已有 4588 次阅读2012-12-13 19:35 |系统分类:应用

  1. (vl-load-com)
  2. (setvar "cmdecho" 0)
  3. (setq *AcadDoc* (vla-get-ActiveDocument (vlax-get-Acad-Object)))
  4. (setq *MoSpace* (vla-get-ModelSpace *AcadDoc*))
  5. (defun c:test (/            ss                 blockname    blocklist
  6.                ocirlist            regionlist         blocklength  i
  7.                j            tempregion1         tempregion2  intersectlist
  8.                intersectregion                 ocir              oregion
  9.                cenptlist    pt                 hatchlist    ohatch
  10.                code
  11.               )
  12.   (if (and
  13.         (setq blockname (getstring "\n请输入块名:"))
  14.         (setq CenRad (getreal "\n请输入圆半径:"))
  15.         (setq ss (ssget        "_W"
  16.                         (setq pt (getpoint "\n选取第一点:"))
  17.                         (getcorner pt "\n选取第二点:")
  18.                         (list
  19.                           '(0 . "INSERT")
  20.                           (cons 2 blockname)
  21.                         )
  22.                  )
  23.         )
  24.       )
  25.     (progn
  26.       (setq blocklength
  27.              (sslength ss)
  28.             i 0
  29.       )
  30.       (while (< i blocklength)
  31.         (setq blocklist        (cons (ssname ss i) blocklist)
  32.               i                (1+ i)
  33.         )
  34.       )
  35.       (setq ss nil)
  36.       (setq
  37.         cenptlist (mapcar '(lambda (x)
  38.                              (cdr (assoc 10 (entget x)))
  39.                            )
  40.                           blocklist
  41.                   )
  42.       )
  43.       (setq ocirlist
  44.              (mapcar '(lambda (x)
  45.                         (vla-addCircle *mospace* (vlax-3d-point x) cenrad)
  46.                       )
  47.                      cenptlist
  48.              )
  49.       )
  50.       (setq regionlist
  51.              (vlax-safearray->list
  52.                (vlax-variant-value
  53.                  (vla-addregion
  54.                    *mospace*
  55.                    (Xr:list->Obj-Array ocirlist)
  56.                  )
  57.                )
  58.              )
  59.             i 0
  60.       )
  61.       (while (< i blocklength)
  62.         (setq j (1+ i))
  63.         (while (< j blocklength)
  64.           (setq        tempregion1
  65.                             (vlax-invoke-method (nth i regionlist) 'Copy)
  66.                 tempregion2
  67.                             (vlax-invoke-method (nth j regionlist) 'Copy)
  68.           )
  69.           (vlax-invoke-method
  70.             tempregion1
  71.             'Boolean
  72.             1
  73.             tempregion2
  74.           )
  75.           (if (not (equal
  76.                      (vlax-get-property tempregion1 'Area)
  77.                      0.0
  78.                      0.000001
  79.                    )
  80.               )
  81.             (progn
  82.               (setq intersectlist (cons tempregion1 intersectlist))
  83.               (if (not (vlax-erased-p tempregion2))
  84.                 (vla-erase tempregion2)
  85.               )
  86.             )
  87.             (progn
  88.               (if (not (vlax-erased-p tempregion1))
  89.                 (vla-erase tempregion1)
  90.               )
  91.               (if (not (vlax-erased-p tempregion2))
  92.                 (vla-erase tempregion2)
  93.               )
  94.             )
  95.           )
  96.           (setq j (1+ j))
  97.         )
  98.         (setq i (1+ i))
  99.       )
  100.       (setq
  101.         hatchlist (mapcar '(lambda (x) (Xr:addhatch x)) intersectlist)
  102.       )
  103. ;;;      (vlax-invoke-method *acaddoc* 'Regen 0)
  104. ;;;      (prompt "\n按回车结束!")
  105. ;;;      (while (equal
  106. ;;;               (setq code (grread T 8))
  107. ;;;               '(2 13)
  108. ;;;             )
  109. ;;;      )
  110. ;;;      (Xr:delete (append hatchlist intersectlist regionlist ocirlist))
  111.     )
  112.   )
  113.   (princ)
  114. )
  115. (defun Xr:addhatch (obj / ohatch)
  116.   (setq ohatch (vla-AddHatch *mospace* 0 "ANSI31" T))
  117.   (vlax-invoke-method
  118.     ohatch
  119.     'AppendOuterLoop
  120.     (Xr:list->Obj-Array (list obj))
  121.   )
  122.   ohatch
  123. )
  124. (defun Xr:delete (objlist / obj)
  125.   (foreach obj objlist
  126.     (if        (not (vlax-erased-p obj))
  127.       (vla-erase obj)
  128.     )
  129.   )
  130. )
  131. (defun Xr:list->Obj-Array (objList / arraySpace sArray)
  132.   (setq        arraySpace
  133.          (vlax-make-safearray
  134.            vlax-vbObject                ; 元素类型
  135.            (cons 0
  136.                  (1- (length objList))
  137.            )                                ; 数组维数
  138.          )
  139.   )
  140.   (setq sArray (vlax-safearray-fill arraySpace objList))
  141. )
    ;;;切换快捷键,还不知怎么用。
    (defun c:SWitchPGP(/ f1 f2 tmpfile)
      ;;假设要切换的pgp文件放在CAD的acad.pgp同一目录下,文件名为acadBak.pgp
      (setq f1 (findfile "acad.pgp"))
      (setq f2 (strcat (VL-FILENAME-DIRECTORY f1) "\\acadBak.pgp"))
      (setq tmpfile (strcat (VL-FILENAME-DIRECTORY f1) "\\acadtmp.pgp"))
      (if (findfile tmpfile) (vl-file-delete tmpfile))
      (VL-FILE-RENAME f1 tmpfile)
      (vl-file-rename f2 f1)
      (vl-file-rename tmpfile f2)
      (setvar "RE-INIT" 16)
      (princ)
      )
    1. ;;;\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    2. (strsort strlst) = 含数字后缀的字符串排序-v1.1-------------------lxx.2004.6 ok!
    3. 测试:
    4. (setq lst '("w45""w-3""s""z1""z-4""df676""df24""bff4""bff""bff2""A34""A""A2""A5""bff-5"))
    5. (strsort lst) ->("A" "A2" "A5" "A34" "bff-5" "bff" "bff2" "bff4" "df24" "df676" "s" "w-3" "w45" "z-4" "z1") ok!
    6. |;
    7. (defun strsort (strlst)
    8.   (defun strbrk (str / i st1 n)
    9.     (setq i 0)
    10.     (while (not(or(= "" (setq st1(substr str(setq i(1+ i)))))(setq n(distof st1)))))
    11.     (list (substr str 1 (1- i)) (if n n 0) str)
    12.   )
    13.   (defun x-sort (lst do n)
    14.     (vl-sort lst '(lambda(x y)((eval do)(nth n x)(nth n y))))
    15.   )
    16.   (mapcar 'last (x-sort (x-sort (mapcar 'strbrk strlst) '< 1) '< 0))
    17. )


    ;;;返回多个面域的表
    (defun CreateRegion (/ ModelSpace Lst ReVal)
      (vl-load-com)
      (setq ModelSpace
                 (vla-get-modelspace
                   (vla-get-ActiveDocument (vlax-get-acad-object))
                 )
      )
      (defun list->variantArray (VlaObjLst / arrayspace sArray)
        (setq arrayspace (vlax-make-safearray
                                      vlax-vbobject
                                      (cons 0 (1- (length VlaObjLst)))
           )
                 sArray        (vlax-safearray-fill arrayspace VlaObjLst)
        )
        (vlax-make-variant sArray)
      )
      (defun ss->Lst (/ ReLst n)
        (if (setq ss (ssget))
          (progn
            (setq ReLst nil
                     n     -1
            )
            (repeat (sslength ss)
              (setq n        (1+ n)
                       ReLst (cons (ssname ss n) ReLst)
               )
            )
            (setq ss nil)
            ReLst
          )
        )
      )
      (if (setq Lst (ss->Lst))
        (progn
          (setq Lst   (mapcar 'vlax-ename->vla-object Lst)
                ReVal (vla-addregion ModelSpace (list->variantArray Lst))
          )
          (vlax-safearray->list (vlax-variant-value ReVal))
         )
      )
    )

    (defun c:T11 ();!!!画PL线1
      (defun restore ()
        (redraw)
      (setq p1  (getpoint "\n 请指定起点: ")
            sum 0
            PTLST (CONS P1 '())
      )
      (while (setq p2 (getpoint "\n指定下一点: " p1))
           (grdraw p1 p2 -1 1)  
           (SETQ PTLST (CONS P2 PTLST))     
           (setq sum (+ sum (distance p1 p2)))
           (SETQ P1 P2)
      )
       PTLST
       );如果中间缩放一下,示意的路径就没有了。先画出P1,P2直线,最后画完PL线后删除直线。
      (SETQ PTLST (reverse (CONS (LIST "") (restore))))
      (setvar "PLINEWID" 50);指定线宽
      (COMMAND "PLINE")
      (APPLY 'COMMAND PTLST)
      (SETQ PL (ENTLAST)
            ZHONGP (vlax-curve-getPointAtDist PL (* 0.5 SUM))
            ZHONGP1 (vlax-curve-getPointAtDist PL (+ (* 0.5 SUM) 0.000001));这样计算角度不精准。
            WW_angle (/ (* 180 (angle ZHONGP ZHONGP1)) pi)
            WW_p (polar ZHONGP1 (/ (* pi (+ WW_angle 90)) 180) 50))
    (if (and (> WW_angle 90) (<= WW_angle 270))
     (setq WW_angle (+ WW_angle 180))
     )
    (command "style" "WW" "TXT,HZTXT" "0" "0.7" "0" "" "" "")
    (command "text" "J" "C" WW_p 300 WW_angle (strcat "打劫路线总长=" (rtos SUM 2 1)));可ENTMAKE制作。
    (PRINC)
    )

    ;;;command画PL线2

    (command "pline")
    (while (= (logand (getvar "CmdActive") 1) 1) (command pause))

    (setq ename(entlast))

    LASTPOINT取得上一点(系统变量)。系统变量怎么什么都存呢?! 

     { horizontal_margin = none;vertical_margin = none;}话说这个属性没见过哦!亲。

    (CAD什么时候再漏点好东西出来啊,VLISP已经无法满足需求了<需要再加强啊>)

    ;;;取得多段线上某点处的文字角度(ob为VLA对象)
    (defun getPolyLineAngle (ob qidian)
        (setq lt (vlax-safearray->list
    (vlax-variant-value (vla-get-Coordinates ob))
        )
        );得到多段线坐标点列表
        (setq ep (list (nth qidian lt) (nth (1+ qidian) lt) 0))
        (setq sp (list (nth (+ qidian 2) lt) (nth (+ qidian 3) lt) 0))
        (setq ang (angle sp ep))
     (fixAngle ang)
    )

    (defun fixAngle (rot)
     (cond
    ((and (> rot (/ pi 2)) (<= rot pi))
    (setq rot (- rot pi))
    ) ;90<rot<=180
    ((and (> rot pi) (<= rot (* pi 1.5)))
    (setq rot (- rot pi))
    ) ;180<rot<=270
    (t (setq rot rot))
     )
     (setq rot rot)
    )
    画PL3
    1.       ;;绘制边框
    2.       (command "pline")
    3.       (foreach a pl (command "_non" (trans a 0 1)))
    4.       (command "c")
    ;;;求设置了那些捕捉值
    除了logand \logor的方法之外,还可以这样:
    ;; [功能] 按位编码分解--CAOYIN
    ;; [参数] maxi----整型数。因子的最大范围
    ;;        cost----整型数。要分解的值
    ;; [返回] 包含按位编码的整型数列表
    ;; [测试] (lt:factor 171)->(1 2 8 32 128)
    (defun lt:factor (cost / fact lst)
      (setq maxi 1)
      (while (< maxi cost) (setq maxi (* maxi 2)))
      (while (< fact cost)
        (setq fact (gcd maxi cost)
              lst  (cons fact lst)
              cost (- cost fact)
        )
      )
      (reverse lst)
    )

    ;;读取字符串后面数字
    命令: (qmwsz "abcd123")
    "123"
    命令: (qmwsz "abcd12")
    "12" 
    1. (defun qmwsz(Xstr / fhz n i)
    2.         (setq n (strlen Xstr)  i n  fhz nil) 
    3.         (while (<= 1 i n)
    4.            (setq fhz (substr Xstr i))
    5.            (if (/= (read fhz) (atof fhz))
    6.                (setq fhz (substr fhz 2)
    7.                      i  0
    8.                )
    9.                (setq i (1- i))
    10.            )
    11.         )
    12.         (setq fhz fhz)
           )
      ;;;-------------------------------------------------------------------------------------------------------------------
      ;;; ★gws  改尾数
      ;;;   By  Andyhon
      ;;;-------------------------------------------------------------------------------------------------------------------
      (defun C:gws()
      (setq ss (ssget '((0 . "TEXT") (1 . "*#")))
             Num (getstring "\n新的编号: ") 
              i  0
        )
        (while (setq ee (ssname ss i))
          (setq obj (vlax-ename->vla-object ee)
                txt (vla-get-textstring obj)
                txt (reverse (vl-string->list txt))
                txt (vl-list->string (reverse (cdr txt)))
                i   (1+ i)
          )
          (vla-put-textstring obj (strcat txt Num))
        )
      )

      ;;;(strsort strlst) = 含数字后缀的字符串排序-无痕.2004.6 ok!
      (defun strsort (strlst)
        (defun strbrk (str / i st1 n)
          (setq i 0)
          (while (not (or (= "" (setq st1 (substr str (setq i (1+ i)))))
            (setq n (distof st1))
        )
          )
          )
          (list (substr str 1 (1- i))
         (if n n 0)
         str
          )
        )
        (defun x-sort (lst do n)
          (vl-sort lst
            '(lambda (x y) ((eval do) (nth n x) (nth n y)))
          )
        )
        (mapcar 'last
         (x-sort (mapcar 'strbrk strlst) '< 1) ;;针对你的情况调整
        )
      )

      ;;; 快速打印程序,选一堆矩图框,再批量打印
      (defun c:ksdy (/ ent fx i maxpoint maxx0 maxy0 minpoint minx0 miny0 os pmax pmin ptlist ss sstk)
        (vl-load-com)
        (setvar "cmdecho" 0) (setq os (getvar "osmode")   ss (ssadd)    sstk (ssadd)  )
        (princ "\n 请选取矩形图框:")
        (while (setq ss (ssget ":E:S" (list '(0 . "LWPOLYLINE") '(90 . 4))))
          (setq ent (ssname ss 0))
          (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
          (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint)
                minx0 (car pmin)  miny0 (cadr pmin)   maxx0 (car pmax)  maxy0 (cadr pmax))
          (if (>= (- maxx0 minx0) (- maxy0 miny0))   (setq fx "L")      (setq fx "P") )
          (entmake (list '(0 . "LINE") (cons 62 6) (cons 10 (list minx0 miny0 0)) (cons 11 (list maxx0 maxy0 0))))
          (setq sstk (ssadd (entlast) sstk))
          (entmake (list '(0 . "LINE") (cons 62 6) (cons 10 (list minx0 maxy0 0)) (cons 11 (list maxx0 miny0 0))))
          (setq sstk (ssadd (entlast) sstk))
          (setq ptlist (cons (list pmin pmax fx) ptlist))
        )
        (initget "Y N ")
        (if (/= (getpoint (strcat "\n 确定批量打印?[确认(Y)/退出(N)]:<Y> ")) "N")
          (progn
            (command "erase" sstk "")
            (repeat (setq i (length ptlist))
              (setq ent (nth (setq i (1- i)) ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent))
              (command "_.PLOT" "Y" "" "pdffactory pro" "A3" "M" fx "N" "W" pmin pmax "F" "C" "Y" "monochrome.ctb" "Y" "N" "N" "N" "Y")
              (princ (strcat "\n 程序正在打印第" (itoa (- (length ptlist) i)) "张>>>>>>>> "))
            )
          )
          (command "erase" sstk "")
        )
        (setvar "osmode" os)                 ; 恢复捕捉模式
        (princ)
      )



      (vla-getinterfaceobject ACAD (strcat "AutoCAD.AcCmColor." (substr (getvar "AcadVer") 1 2)));;加载真彩色对象

      (vla-SetRGB colObj 252 219 161);;设置真彩色对象的Red Green Blue各自的值

      (vla-put-TrueColor LayObj colObj);;将真彩赋与图层对象



      (defun TrueColor2RGB (col /)
        (strcat (itoa (lsh (fix col) -16))
                ","
                (itoa (lsh (lsh (fix col) 16) -24))
                ","
                (itoa (lsh (lsh (fix col) 24) -24))
        )
      )


路过

雷人

握手
1

鲜花

鸡蛋

刚表态过的朋友 (1 人)

评论 (0 个评论)

facelist doodle 涂鸦板

您需要登录后才可以评论 登录 | 注册

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

GMT+8, 2024-3-29 05:37 , Processed in 0.129130 second(s), 15 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

返回顶部