文字连线

自贡黄明儒

网友花钱请我帮他写了<文字连线>这个程序,这个程序可能带有一点专业的味道。
下面的程序是我写的第一版
第一版写得确实不怎么样，我自己也不满意。后来经过n次改进，我自己也是觉得满意了，他也满意了。不管怎么说，用户既然付了钱，我们就要让用户满意舒服，这样才对得起人民币。
由于是商业程序，本程序放在这里不供大家下载的，只是便于自己查今后查阅。
凡是回复者，请自觉用100人民币充明经"通道币"，否则将负法律责任。
;;[功能] 编组开始;(command "_.undo" "be")
(defun _StartUndo (*DOC*)
  (_EndUndo *DOC*)
  (vla-StartUndoMark *DOC*)
)
;;[功能] 结束编组;(if (= 8 (logand (getvar "undoctl") 8)) (command "_.undo" "_e"))
(defun _EndUndo        (*DOC*)
  (if (= 8 (logand 8 (getvar 'UNDOCTL)))
    (vla-EndUndoMark *DOC*)
  )
)
;;[功能] 点表生成多段线
(defun Make-LWPOLYLINE (lst / PT)
  (entmakeX
    (append (list '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  (cons 90 (length lst))
            )
            (mapcar '(lambda (pt) (cons 10 pt)) lst)
    )
  )
)

;;[功能] 文字定位点组码10排序
;;(HH:ss:Sort (ssget) "xY" 0.001)->返回文字定位点组码10
(defun HH:ss:Sort1 (ssPts KEY FUZZ / E EN FUN LST N)
  ;;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 本程序主程序
  (repeat (setq n (sslength ssPts))
    (if        (and (setq e (ssname ssPts (setq n (1- n))))
             (setq en (entget e))
        )
      (setq lst (cons (cdr (assoc 10 en)) lst))
    )
  )
(sortpts1 lst KEY FUZZ)
)
;;*****************************************************************************通用点表排序


;;*****************************************************************************通用点表排序
;;ssPts: 1 选择集，返回图元列表
;;           2 点表(1到n维 1维时key只能是x或X)，返回点表
;;          3 图元列表，返回图元列表
;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
;;FUZZ: 允许误差
;;注:点表可以1到n维混合,Key长度不大于点的最小维数。
;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
;;示例3 (HH:ssPts:Sort '(<Entity name: 7ef79a28> <Entity name: 7ef79a10>) "YxZ" 0.5)
;;本程序是在fsxm的扩展 自贡黄明儒 2013年9月9日
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS)
  ;;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))
               )
         )
        )
  )
)
;;*****************************************************************************通用点表排序

;;*****************************************************************************文字连线
(defun CLL (/ CMD1 LST OBJ SHORTC SS);C:后面是命令，你自己可以修改成自己需要的
  ;;错误处理
  (defun *error* (msg)
    (vl-bt)
    (if        *DOC*
      (_EndUndo *DOC*)                                            ;块内图元增减
    )
    (while (not (equal (getvar "cmdnames") "")) (command nil))
    (if        cmd1
      (setvar "cmdecho" cmd1)
    )
    (if        SHORTC
      (setvar "SHORTCUTMENU" SHORTC)
    )
    (setvar "nomutt" 0)
    (princ "\n 出错啦!")
    (princ)
  )
  (if (cadr (ssgetfirst))
    (setq ss (ssget "_P" '((0 . "*TEXT"))))
  )
  (setq cmd1 (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (or *DOC*
      (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  (_StartUndo *DOC*)
  (cond
    (ss nil)
    (T
     (princ "\n 选择文字连线")
     (setvar "nomutt" 1)
     (setq ss (ssget '((0 . "*TEXT"))))
     (setvar "nomutt" 0)
    )
  )
  (if ss
    (progn
      ;;如果文字对齐方法式不同，可以先预处理
      (command "_.JUSTIFYTEXT" ss "" "BL");如果不处理，则去掉此句
      (setq obj (vlax-ename->vla-object (ssname ss 0)))
      (setq obj(vlax-get obj 'height));字高，用作排序误差
      (setq lst (VL-CATCH-ALL-APPLY 'HH:ss:Sort1 (list ss "Yx" obj)));"Yx",是连线顺序，自己可以修改
      (VL-CATCH-ALL-APPLY 'Make-LWPOLYLINE (list lst))
    )
  )
  (_EndUndo *DOC*)
  (setvar "cmdecho" cmd1)
  (gc)
  (princ "\n 文字连线命令LL")                                    ;执行命令时提示
  (princ)
)


(princ "\n 文字连线命令LL")                                    ;加载时提示
(princ)

gooday

gooday 发表于 2018-11-25 22:52
结合这个可以实现按顺序提取文字了，不错

不知道怎么用

月下闲人

凡是回复者，请自觉用100人民币充明经"通道币"，否则将负法律责任。

gooday

结合这个可以实现按顺序提取文字了，不错

lucas_3333

这有啥用？画北斗七星吗？

szx025

还是有用的

hao3ren

呵呵，黄大师好无聊啊

enn09

这是干什么用的？好奇怪哪个专业会用到

yoyoho

让我学习一下!

langjs

楼主赚钱请同志们搓一顿

风树

难道用来画测量路线的？

杜阳

Jack_PC

这是干什么用的？