布局-2020年06月05日

;;说明:图框代码
;;2019年01月04日更新: 提示图框生成确认长度是否正确
;;2019年08月04日更新: 图形已存在图块，提示你如何处理
;;2019年08月04日新增：去重复图框
;;2019年08月05日新增：新增批量插入指北针
;;2019年10月23日新增: 惠州竣工测量图框
;;2019年10月23日新增: 图框扩展数据重新赋值
;;2020年07月21日新增: 广东省交通规划设计研究院图框
(vl-load-com)
;;说明:3.布局输出(201902210136)
(defun c:TKOUTPUT()
    (setvar "CMDECHO" 0)
    (setvar "OSMODE" 0)
    (setq
        wordStr
        (GetWord
            "请选择成图单位:
\nA 广东省建科建筑设计院有限公司
\nB 广东省冶金建筑设计研究院
\nC 广东有色工程勘察设计院
\nD 广州地铁设计研究院有限公司
\nE 广州市科城建筑设计有限公司
\nF 广州市市政工程设计研究院
\nG 广州市天驰测绘技术有限公司
\nH 中国有色金属长沙勘察设计研究院有限公司
\nI 核工业赣州工程勘察院
\nJ 广东省建筑设计研究院
\nK 核工业鹰潭工程勘察院
\nL 建材广州工程勘测院有限公司
\nN 惠州竣工
\nM 天津市市政工程设计研究院
\nO 湖南省地质工程勘察院
\nP 中国电建集团
\nQ 广东省交通规划设计研究院
"
            '("A建科" "B冶金" "C有色" "D地铁" "E科城" "F市政" "G天驰" "H长沙勘察" "I核工业" "J省院" "K鹰潭" "L建材" "N惠州竣工" "M天津市政" "O湖南地质" "P中国电建集团" "Q交通规划院")
        )
    )
    (setq intNum (substr wordStr 1 1))
    (setq cldw
        (cdr
            (assoc
                intNum
                (list
                    (cons "A" "广东省建科建筑设计院有限公司")
                    (cons "B" "广东省冶金建筑设计研究院")
                    (cons "C" "广东有色工程勘察设计院")
                    (cons "D" "广州地铁设计研究院有限公司")
                    (cons "E" "广州市科城建筑设计有限公司")
                    (cons "F" "广州市市政工程设计研究院")
                    (cons "G" "广州市天驰测绘技术有限公司")
                    (cons "H" "中国有色金属长沙勘察设计研究院有限公司")
                    (cons "I" "核工业赣州工程勘察院")
                    (cons "J" "广东省建筑设计研究院")
                    (cons "K" "核工业鹰潭工程勘察院")
                    (cons "L" "建材广州工程勘测院有限公司")
                    (cons "N" "惠州竣工")
                    (cons "M" "天津市市政工程设计研究院")
                    (cons "O" "湖南省地质工程勘察院")
                    (cons "P" "中国电建集团")
                    (cons "Q" "广东省交通规划设计研究院")
                )
            )
        )
    )
    (setq bjNum (getint "\n每布局输出图框个数<默认个数 10> :"))
    (setq leng (getint "\n输入总图幅号 <默认当前图形图框总数> :"))
    (if (= bjNum nil)(setq bjNum 10))
    (setq strsat (car(_vl-times)))
    (setvar "CMDECHO" 0)
    (setq tkname (strcat cldw ".dwg"))
    (if (setq tkFlieName (findfile tkname))
        (progn
            ;;;视口坐标表
            (setq tkpts
                (cond
                    ((= wordStr "A建科")
                        (setq withd 184 height 121)
                        '((-97.5 -64 0.0) (97.5 -64 0.0) (97.5 64 0.0) (-97.5 64 0.0))
                    )
                    ((= wordStr "J省院")
                        (setq withd 184 height 121)
                        '((-92 -60.5 0.0) (92 -60.5 0.0) (92 60.5 0.0) (-92 60.5 0.0))
                    )
                    ((= wordStr "N惠州竣工")
                        (setq withd 190 height 130.5)
                        '((-95.0 65.25 0.0) (-95.0 -65.25 0.0) (77.9851 -65.25 0.0) (77.9851 -62.699 0.0) (95.0 -62.699 0.0) (95.0 65.25 0.0) (-95.0 65.25 0.0))
                    )
                    ((= wordStr "M天津市政")
                        (setq withd 200 height 130)
                        '((-100 -65 0.0) (100 -65 0.0) (100 65 0.0) (-100 65 0.0))
                    )
                    (t (setq withd 190 height 130.5)'((-95 -65.25 0.0) (95 -65.25 0.0) (95 65.25 0.0) (-95 65.25 0.0)))
                )
            )
            (setq AcadApplic (vlax-get-acad-object))
            (setq AcadDocuments (vla-get-Documents         AcadApplic))
            (setq AcadDocument  (vla-get-ActiveDocument AcadApplic))
            (setq preferenceSel (vla-get-Preferences    AcadApplic))
            (setq ModelSpace    (vla-get-ModelSpace AcadDocument))
            (setq AcadLayouts   (vla-get-Layouts    AcadDocument))
            (setq BLOCK         (vla-get-Blocks     AcadDocument))
            (setq LayerSel      (vla-get-Layers     AcadDocument))
            (setq AcadPref      (vla-get-display    preferenceSel))
            (vla-ZoomExtents AcadApplic)
            (vla-put-ActiveSpace AcadDocument 1)
            (vla-put-LayoutCreateViewport AcadPref :vlax-false)
            ;;;创建图层
            (if (not (tblsearch "layer" "图框"))
                (vla-add LayerSel  "图框")
            )
            (if (not (tblsearch "layer" "不打印"))
                (vla-PUT-Plottable (vla-add LayerSel  "不打印") :vlax-false)
            )
            ;;;过滤图框选择集
            (setq ss (ssget "X" (list (cons 0 "INSERT")(cons 2 "Lzx图框")(cons 8 "不打印")))  i 0 num_ang_list nil)
            ;;;省院需要
            (repeat (sslength ss)
                (setq en (ssname ss i))
                (setq entBox (BF-ent-getbox en 0.01))
                (setq obj (vlax-ename->vla-object en))
                (setq lst_att (vlax-safearray->list (vlax-variant-value (vla-GetAttributes obj))))
                (setq num (vla-get-textstring (car lst_att)))
                (setq ang (vla-get-Rotation obj))
                (setq point (vlax-get obj 'InsertionPoint))
                ;;创建块
                (setq ssbox (ssget "c" (car entBox)(cadr entBox) (list (cons 2 "Lzx图框")(cons 8 "不打印"))))
                (setq ssblock (ssadd))
                (setq w 0)
                (repeat (sslength ssbox)
                    (setq ename (ssname ssbox w))
                    (setq obj (vla-Copy(vlax-ename->vla-object ename)))
                    (VxSetAtts obj (list (cons "图幅号" (strcat "T"(cdr(car(VxGetAtts obj)))))))
                    (ssadd (vlax-vla-object->ename obj) ssblock)
                    (setq w (1+ w))
                )
                (setq blockName (rtos (car(_vl-times))2 8))
                (if (tblsearch "BLOCK" blockName)(setq blockName (strcat blockName (rtos (BF-Math-Rand) 2 10))))
                (command "_.BLOCK" blockName point ssblock "")
                (setq ssblock NIL)
                (setq num_ang_list (cons (list (atoi num) ang en point blockName) num_ang_list))
                (setq i (1+ i))
            )
            (setq ent_num_list (bf-List-Sort num_ang_list '<))
            ;;每布局输出图框个数分割
            (setq splitList (BF-list-split ent_num_list bjNum))
            (if (= leng nil)(setq leng (length ent_num_list)))
            (setq i 0 gx 1 tunum 1)
            ;;;循环创建布局
            (foreach lst splitList
                ;(setq lst (nth 0 splitList))
                (setq qsh (car (car lst)))
                (setq jdh (car (car(reverse lst))))
                (setq newLayout(vla-add AcadLayouts (strcat (rtos qsh 2 0)"-" (rtos jdh 2 0))))
                (vla-put-ActiveLayout (vla-Item AcadDocuments (vla-get-Name AcadDocument)) newLayout);;激活布局
                ;;;循环创建当前布局的视口
                (setq startPoint '(1000 1000 0))
                (foreach jxk lst
                    ;;计算数据
                    (setq interPoint (polar startPoint 3.74343 115.25))
                    (setq Center (vlax-3D-point startPoint))
                    ;计算缩放比例
                    (setq dxfList (entget (caddr jxk)(list"*")))
                    (setq height (cdr(cadr(assoc "图框高" (cdr(assoc -3 dxfList))))))
                    (setq scbl
                        (cond
                            ((= wordStr "M天津市政") (/ height 130))
                            ((= wordStr "J省院") (/ height 120))
                            ((= wordStr "A建科") (/ height 128))
                            (t (/ height 130.5))
                        )
                    )
                    ;;窗口缩放
                    (vla-ZoomCenter AcadApplic Center 200)
                    ;;创建视口
                    (setq matPts (BF-Mat-ScaleByMatrix  (BF-Mat-TranslateByMatrix tkpts '(0 0 0) startPoint) startPoint scbl))
                    (mapcar 'command (append  (list "_-vports" "P") matPts (list "c")))
                    (setq pviewportObj (vlax-ename->vla-object (entlast)))
                    (vla-put-Layer pviewportObj "图框")
                    (vla-Display pviewportObj :vlax-true)
                    (vla-put-MSpace Acaddocument :vlax-true)
                    (vla-put-ActivePViewport Acaddocument pviewportObj)
                    (vla-Regen Acaddocument acAllViewports)
                    ;;视口旋转与缩放
                    (vl-cmdf "_.ucs" "W")
                    (vl-cmdf "_.Plan" "")
                    (setq degress (BF-math-radions->degress (cadr jxk)))
                    (vl-cmdf "ucs" "z" degress)
                    (vl-cmdf "_.Plan" "")
                    (setq newPoint (trans (nth 3 jxk) 0 1))
                    (vl-cmdf "_.zoom" "c" newPoint height)
                    (vla-put-MSpace Acaddocument :vlax-false)
                    ;;
                    (if (tblsearch "block" cldw)
                        (setq tkFlieName cldw)
                    )
                  (setq tkObject (vla-InsertBlock (vla-get-PaperSpace AcadDocument) Center tkFlieName 1 1 1 0))
                    (vla-ScaleEntity tkObject Center scbl)
                    (vla-put-Layer tkObject "图框")
                    ;;
                    (setq str (rtos (car jxk) 2 0))
                    (cond
            ;;;;交通规划院
                        ((= intNum "Q")
                            (setq txtPt (polar startPoint 0.66130465 (* scbl 103.806)))
                            (entmakeX(list '(0 . "TEXT") (cons 1 (strcat "第" str "页"))              (cons 8 "图框") (cons 10 txtPt)(cons 11 txtPt)(cons 7 "GHDI")(cons 40 2.2)(cons 41 0.8)(cons 72 1)(cons 73 2)))
                            (setq txtPt (polar startPoint 0.61276709 (* scbl 110.848)))
                            (entmakeX(list '(0 . "TEXT") (cons 1 (strcat "共" (rtos leng  2 0)  "页"))(cons 8 "图框") (cons 10 txtPt)(cons 11 txtPt)(cons 7 "GHDI")(cons 40 2.2)(cons 41 0.8)(cons 72 1)(cons 73 2)))
                        )
                        ;;;;惠州竣工
                        ((= intNum "N")
                            (setq txtPt (polar startPoint 5.67517 (* scbl 111.9925)))
                            (entmakeX(list '(0 . "TEXT") (cons 1 (strcat "图幅" str))(cons 8 "图框") (cons 10 txtPt)(cons 11 txtPt)(cons 7 "ST") (cons 40 1)(cons 72 1)(cons 73 2)))
                        )
                        ;;;;广东省建科建筑设计院有限公司
                        ((= intNum "E")
                            (setq str1
                                (cond
                                    ((= (strlen str) 0 )(strcat "000" str))
                                    ((= (strlen str) 1 )(strcat "00" str))
                                    ((= (strlen str) 2 )(strcat "0" str))
                                    ((= (strlen str) 3 )str)
                                )
                            )
                            (BF-ent-addtext (strcat "DX-" str1) (polar startPoint 5.62258 115.7625) 1.25 0 22)
                            (BF-ent-putdxf (entlast) 7 "图框")
                        )
                        ;;;;广州地铁设计研究院有限公司
                        ((= intNum "D")
                            (setq str1
                                (cond
                                    ((= (strlen str) 0 )(strcat "000" str))
                                    ((= (strlen str) 1 )(strcat "00" str))
                                    ((= (strlen str) 2 )(strcat "0" str))
                                    ((= (strlen str) 3 )str)
                                )
                            )
                            (BF-ent-addtext (strcat "附图2-" str1) (polar interPoint 5.64074 112.273) 1.4 0 22)
                            (BF-ent-putdxf (entlast) 7 "图框")
                        )
                        ;;;;广州市天驰测绘技术有限公司  中国有色金属长沙勘察设计研究院有限公司 广东有色工程勘察设计院 核工业赣州工程勘察院 建材广州工程勘测院有限公司
                        ((wcmatch intNum "G,H,C,I,L,K,F,O")
                            (setq obj (vlax-ename->vla-object (BF-ent-addcircle (polar startPoint 5.60258 113.2279) 1.9)))
                            (vla-put-layer obj "图框")
                            (vla-ScaleEntity obj Center (/ height 130.5))
                            (setq obj (vlax-ename->vla-object (BF-ent-addline (polar startPoint 5.58586 113.0453) (polar startPoint 5.61924 113.4421))))
                            (vla-put-layer obj "图框")
                            (vla-ScaleEntity obj Center (/ height 130.5))
                            (setq obj (vlax-ename->vla-object (BF-ent-addtext str (polar startPoint 5.60345 112.29) 0.9 0 22)))
                            (vla-put-layer obj "图框")
                            (vla-ScaleEntity obj Center (/ height 130.5))
                            (setq obj (vlax-ename->vla-object (BF-ent-addtext (rtos leng  2 0) (polar startPoint 5.60128 114.1489) 0.9 0 22)))
                            (vla-put-layer obj "图框")
                            (vla-ScaleEntity obj Center (/ height 130.5))
                        )
                        ((= intNum "J");;;;广东省建筑设计研究院
                            (BF-ent-addtext (strcat "T" str) (polar startPoint 5.5918 114.0695) 1.4 0 22)
                            (BF-ent-putdxf (entlast) 8 "图框")
                            ;;;创建接边相邻图块
                            ;;插入图块 (SSLENGTH ssblock)
                            (setq xltkPoint (polar startPoint 5.13313 74.2163))
                            (setq tkObject (vla-InsertBlock (vla-get-PaperSpace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3D-point xltkPoint) (nth 4 jxk) 1 1 1 0))
                            (setq tkBox (BF-ent-getbox (vlax-vla-object->ename tkObject) 0.01))
                            (setq pbox1 (mapcar '- xltkPoint (car tkBox) ))
                            (setq pbox2 (mapcar '- (cadr tkBox) xltkPoint  ))
                            (vla-ScaleEntity tkObject (vlax-3D-point xltkPoint) 
                                (min 
                                    (/ 7 (max (cadr pbox1)(cadr pbox2)))
                                    (/ 15 (max (car pbox1)(car pbox2)))
                                )
                            )
                            (vla-put-Layer tkObject "图框")
                        )
                        ((= intNum "P");;;;中国电建集团
                            (setq txtPt (polar startPoint 5.60258 (* scbl 113.2279)))
                            (entmakeX(list '(0 . "TEXT") (cons 1 (strcat "图幅" str))(cons 8 "图框") (cons 10 txtPt)(cons 11 txtPt)(cons 7 "ST") (cons 40 1.8)(cons 72 1)(cons 73 2)))
                        )
                    )
                    ;;计算下一个图框位置
                    (setq tunum (1+ tunum))
                    (setq startPoint (polar startPoint 0 (* scbl (+ withd 100))))
                )
                ;(vla-ZoomExtents (vlax-get-acad-object))
                (setq i (1+ i))
            )
        )
        (alert (strcat "程序:布局输出\n搜索路径下找不到:【" tkname "】模板文件"))
    )
    (prompt (strcat "布局输出程序运行时间: " (rtos (/ (- (car(_vl-times))strsat)1000.0)2 3) " 毫秒" ))
    (princ)
)
(defun AddViewports(pts)
    (command "_VIEWPORTS" "p")
    (mapcar 'command pts )
    (command "c" )
    (entlast)
)
;;返回关联表指定KEY后指定数量的所有数据
(defun XD::AssocList:AddSubItem(lst key val / new old)
  (if (setq old (assoc key lst))
    (progn
            (setq new (cons key (reverse (cons val (reverse (cdr old))))))
            (setq lst (subst new old lst))
    )
    (progn
      (setq lst (reverse (cons (list key val) (reverse lst))))
    )
  )
  lst
)
;;;关联表添加一个子项
(defun XD::AssocList:GetDataByKeyWithNums (lst key s / d el i)
  (if (and
        (setq key (assoc key lst))
        (setq d (member key lst))
      )
    (progn
      (setq i 0)
      (repeat s
        (setq el (cons (nth i d) el))
        (setq i (1+ i))
      )
    )
  )
  (reverse el)
)
;;说明:布局程序使用函数
(defun BF-pickset-sort (ssPts KEY FUZZ / E EN FUN LST N sortpts sortpts1)
  ;;1 点列表排序
  (defun sortpts (PTS FUN xyz FUZZ)
    (vl-sort pts
            '(lambda (a b)
                 (if (not (equal (xyz a) (xyz b) fuzz))
                     (fun (xyz a) (xyz b))
                 )
             )
    )
  )
  ;;2 排序
  (defun sortpts1 (PTS KEY FUZZ)
    (setq Key (vl-string->list Key))
    (foreach xyz (reverse Key)
      (cond ((< xyz 100)
                            (setq fun >)
                            (setq xyz (nth (- xyz 88) (list car cadr caddr)))
                        )
                (T
                    (setq fun <)
                    (setq xyz (nth (- xyz 120) (list car cadr caddr)))
                )
      )
      (setq Pts (sortpts Pts fun xyz fuzz))
    )
  )
  ;;3 本程序主程序
  (cond
    ((= (type ssPts) 'PICKSET)
      (repeat (setq n (sslength ssPts))
        (if (and (setq e (ssname ssPts (setq n (1- n))))
                            (setq en (entget e))
                        )
          (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
        )
      )
      (mapcar 'last (sortpts1 lst KEY FUZZ))
    )
    ((Listp ssPts)
      (cond
        ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
        ((= (type (car ssPts)) 'ENAME)
          (foreach e ssPts
            (if (setq en (entget e))
              (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
            )
          )
          (mapcar 'last (sortpts1 lst KEY FUZZ))
        )
        (T
          (cond ((equal key "X") (vl-sort ssPts '>))
                        (T (vl-sort ssPts '<))
          )
        )
      )
    )
  )
)
(defun VxSetAtts (Obj Lst / AttVal)
    (mapcar
        '(lambda (Att)
             (if (setq AttVal (cdr (assoc (vla-get-TagString Att) Lst)))
                 (vla-put-TextString Att AttVal)
             )
         )
        (vlax-invoke Obj "GetAttributes")
    )
    (vla-update Obj)
    (princ)
)
(defun VxGetAtts (Obj)
    (mapcar
        '(lambda (Att)
             (cons (vla-get-TagString Att)
                 (vla-get-TextString Att)
             )
         )
        (vlax-invoke Obj "GetAttributes")
    )
)
(defun BF-ent-addtext (text pt zg ang dq)
  (BF-ent-maketext text pt zg ang 0.8 0 dq)
)
(defun BF-ent-maketext (text pt zg ang kgb qx dqys / y1 y2)
  (cond
    ((= dqys 0)
            (setq y1 (cons 72 4)
                y2 (cons 73 0)
            )
    )
    ((= dqys 11)
            (setq y1 (cons 72 0)
                y2 (cons 73 3)
            )
    )
    ((= dqys 12)
            (setq y1 (cons 72 0)
                y2 (cons 73 2)
            )
    )
    ((= dqys 13)
            (setq y1 (cons 72 0)
                y2 (cons 73 1)
            )
    )
    ((= dqys 21)
            (setq y1 (cons 72 1)
                y2 (cons 73 3)
            )
    )
    ((= dqys 22)
            (setq y1 (cons 72 1)
                y2 (cons 73 2)
            )
    )
    ((= dqys 23)
            (setq y1 (cons 72 1)
                y2 (cons 73 1)
            )
    )
    ((= dqys 31)
            (setq y1 (cons 72 2)
                y2 (cons 73 3)
            )
    )
    ((= dqys 32)
            (setq y1 (cons 72 2)
                y2 (cons 73 2)
            )
    )
    ((= dqys 33)
            (setq y1 (cons 72 2)
                y2 (cons 73 1)
            )
    )
  )
  (entmakex
    (list
      '(0 . "TEXT")
      (cons 10 pt)
      (cons 1 text)
      (cons 40 zg)
      (cons 50 ang)
      (cons 41 kgb)
      (cons 51 qx)
      (cons 7 "standard")
      '(71 . 0)
      y1
      y2
      (cons 11 pt)
    )
  )
)
(defun BF-ent-addline (startpt endpt)
  (entmakex
    (list '(000 . "LINE")
            '(100 . "AcDbEntity")
            '(100 . "AcDbLine")
            (cons 10 startpt)        ;起点
            (cons 11 endpt)        ;终点
    )
  )
)
(defun BF-ent-addcircle    (cen rad)
  (entmakex
    (list
      '(000 . "circle")
      '(100 . "AcDbEntity")
      '(100 . "AcDbCircle")
      (cons 10 cen)
      (cons 40 rad)
    )
  )
)
(defun BF-list-split (lst x / lst2)
  (foreach n lst
    (if    (and lst2 (/= x (length (car lst2))))
      (setq lst2 (cons (append (car lst2) (list n)) (cdr lst2)))
      (setq lst2 (cons (list n) lst2))
    )
  )
  (reverse lst2)
)
(defun bf-List-Sort (lst oper / x1 x2)
    (vl-sort lst
        '(lambda (x1 x2)
             (if
                 (and
                     (atom x1)
                     (atom x2)
                 )
                 (apply oper (list x1 x2))
                 (apply oper (list (car x1) (car x2)))
             )
         )
    )
)
(defun BF-math-radions->degress    (radions)
    (if    (numberp radions)
        (* radions (/ 180.0 pi))
    )
)
(defun BF-ent-getbox (ent offset / lst obj p1 p2 p3 p4)
  (setq obj (vlax-ename->vla-object ent))
  (vla-GetBoundingBox obj 'p1 'p3)
  (setq    p1 (vlax-safearray->list p1)
        p3 (vlax-safearray->list p3)
  )
  (if (= "SPLINE" (cdr (assoc 0 (entget ent))))
    (progn
      (setq lst
                (mapcar
                    '(lambda    (a b)
                         (vlax-curve-getClosestPointToProjection ent a b t)
                     )
                    (list p1
                        (list (car p1) (cadr p3) (caddr p1))
                        p3
                        (list (car p3) (cadr p1) (caddr p1))
                    )
                    '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
                )
      )
      (setq
                p1 (apply 'mapcar (cons 'min lst))
                p3 (apply 'mapcar (cons 'max lst))
      )
    )
  )
  (if (or (not offset) (equal offset 0 0.0001))
    (list p1 p3)
    (list
      (BF-list- p1 (list offset offset 0))
      (BF-list+ p3 (list offset offset 0))
    )
  )
)
(defun BF-list-    (lst1 lst2)
  (mapcar '- lst1 lst2)
)
(defun BF-list+    (lst1 lst2)
  (mapcar '+ lst1 lst2)
)
(defun BF-Math-Rand (/ a c m)
  (setq    m   4294967296.0
        a   1664525.0
        c   1013904223.0
        $xn (rem (+ c
                             (* a
                                 (cond ($xn)
                                     ((getvar 'date))
                                 )
                             )
                         )
                    m
                )
  )
  (/ $xn m)
)
(defun BF-lst->str    (lst del)
    (if    (cdr lst)
        (strcat (car lst) del (BF-lst->str (cdr lst) del))
        (car lst)
    )
)
(defun GetWord(promptStr kwordList / acadobj doc)
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
    (vla-InitializeUserInput (vla-get-Utility doc) 1 (BF-lst->str kwordList " "))
    (vla-GetKeyword (vla-get-Utility doc) (strcat(BF-lst->str kwordList "/")"\n"))
    ;(vla-GetKeyword (vla-get-Utility doc) (strcat promptStr "[" (BF-lst->str kwordList "/") "]"))
)
(defun BF-Mat-TranslateByMatrix (target p1 p2)
  (BF-Mat-ApplyMatrixTransformation target
    (list
      (list 1. 0. 0.)
      (list 0. 1. 0.)
      (list 0. 0. 1.)
    )
    (mapcar '- p2 p1)
  )
)
(defun BF-Mat-ScaleByMatrix (target p1 scale / m)
  (BF-Mat-ApplyMatrixTransformation target
    (setq m
      (list
        (list scale 0. 0.)
        (list 0. scale 0.)
        (list 0. 0. scale)
      )
    )
    (mapcar '- p1 (BF-Mat-MxV m p1))
  )
)
(defun BF-Mat-ApplyMatrixTransformation (target matrix vector)
  (cond
    ((eq 'VLA-OBJECT (type target))
      (vla-TransformBy target
        (vlax-tMatrix
          (append (mapcar (function (lambda (x v) (append x (list v)))) matrix vector)
                        '((0. 0. 0. 1.))
          )
        )
      )
    )
    ((listp target)
      (mapcar
        (function
          (lambda (point) (mapcar '+ (BF-Mat-MxV matrix point) vector))
        )
        target
      )
    )
  )
)
(defun BF-Mat-MxV (m v)
  (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
)
(defun BF-ent-putdxf (ename code val /)
  (cond
    ((BF-enamep ename)
            (setq ent (entget ename))
            (if (and (listp code) (listp val))
                (mapcar '(lambda (x y) (BF-ent-putdxf ename x y)) code val)
                (progn
                    (if (null (BF-ent-getdxf ename code))
                        (entmod (append ent (list (cons code val))))
                        (entmod (subst (cons code val) (assoc code ent) ent))
                    )
                    (entupd ename)
                )
            )
    )
    ((BF-picksetp ename)
            (foreach s1 (BF-pickset->list ename)
                (BF-ent-putdxf s1 code val)
            )
    )
    ((BF-ename-listp ename)
            (foreach s1 ename
                (BF-ent-putdxf s1 code val)
            )
    )
  )
  ename
)
;;;======================================
;;;===========以下为内裤部分=============
;;;======================================
(defun BF-enamep (arg) (equal (type arg) 'ename))
(defun BF-ent-getdxf ( ent i  / getdxf)
    ;;取组码函数
    (defun getdxf (ent i)
        (mapcar 'cdr
            (vl-remove-if-not '(lambda (x) (= (car x) i)) ent)
        )
    )
    ;;主函数体(equal (type ent) 'vla-object)
    (cond
        ((equal (type ent) 'vla-object) (setq ent (entget (vlax-vla-object->ename ent) '("*"))))
        ((equal (type ent) 'ENAME)      (setq ent (entget ent '("*"))))
    )
    (cond
        ((atom i)
            (setq result (getdxf ent i))
        )
        ((listp i)
            (setq result (apply 'append (mapcar '(lambda (x) (getdxf ent x)) i)))
        )
    )
    (if (= 1 (length result))
        (car result)
        result
    )
)
(defun BF-picksetp (x)
  (and (= (type x) 'pickset) (> (sslength x) 0))
)
(defun BF-pickset->list (SS)(vl-remove-if-not 'BF-enamep (mapcar 'cadr (ssnamex SS))))
(defun BF-ename-listp (lst)
    (apply 'and (mapcar 'BF-enamep lst))
)