[LISP程序]：关于不等比缩放的一个小程序

hb198075

主要提供了一个比较方便的交互方式，缩放是使用块的不等比缩放特性。
[php]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;suoFang-SF;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                       自由缩放程序，快捷键: SF                   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq m_delss nil) ;临时物体，程序出错时将由error函数删除清空
(setq sf_drag "S")

;;;主程序
(defun c:sf (/ ss n_plst rec base)
  (HB_START (list (cons "cmdecho" 0)) t)
  (setq ss (ssget))
  (if ss
    (progn
      (setq n_plst (sf-ssBox ss) ;获得所选目标的范围
            rec           (sf-drawRectang) ;生成一个矩形的操作框
            base   (sf-drawBase) ;绘制基点
      )
      (sf-caoZuo ss rec base) ;进行缩放操作
    )
  )
  (hb_start nil nil)
  (princ)
)

;;;缩放操作
(defun sf-caoZuo
       (ss rec base / is pt tmp p0 p1 bpt llst itm gr reclst hs str)
  (setq        reclst        (HB_SSTOLST rec)
        m_delss        rec
        bpt        (cdr (assoc 10 (entget base)))
  )
  (ssadd base m_delss)
  (sssetfirst nil m_delss) ;夹点显示操作框，该框的变量在意外退出时将由error删除
  
;;;进入夹点操作模式，该模式下允许用户选择矩形框的夹点操作
  (while (null is)
    (initget "S  ")
    (setq pt (getpoint "\n选择夹点操作[设置(S)]<退出>:"));[设置[S]/放弃(U)]
    (cond
      ;;如果用户选择的是一个点
      ((= (type pt) 'list)
       (setq pt (osnap pt "_ins,_end,_mid"))
       (cond
         ;;判断是否为矩形角点
         ((SF-ISJIADIAN pt n_plst)
           (SSSETFIRST nil nil)
           (prompt "\n请输入新的角点位置:")
           (if (= sf_drag "S")
             (while (and (setq gr (grread t 5 0)) (/= (car gr) 3))
               (if (= (car gr) 5)
                 (setq
                   tmp (sf-moveRectang reclst n_plst bpt pt (cadr gr))
                 )
               )
             )
             (setq tmp (sf-moveRectang reclst n_plst bpt pt (getpoint bpt)))
           )
           (setq n_plst        tmp
                 is t
           )
           (sf-gaiRec ss rec bpt pt (car n_plst))
         )
         ;;判断是否为中点
         ((setq hs (SF-ISZHONGDIAN pt n_plst))
          (SSSETFIRST nil nil)
          (prompt "\n请输入新的中点位置:")
          (if (= sf_drag "S")
            (while (and (setq gr (grread t 13 0)) (/= (car gr) 3))
              (if (= (car gr) 5)
                (setq tmp (sf-moveRectangMid
                            reclst
                            n_plst
                            bpt
                            pt
                            (cadr gr)
                            hs
                          )
                )
              )
            )
            (setq tmp (sf-moveRectangMid
                        reclst
                        n_plst
                        bpt
                        pt
                        (getpoint bpt)
                        hs
                      )
            )
          )
          (setq        n_plst (cdr tmp)
                is t
          )
          (sf-gaiRec ss rec bpt pt (car tmp))
         )
         ;;判断是否为基点
         ((equal pt bpt)
          (setq bpt (sf-moveBase base))
         )
         ;;其它位置
         (t (prompt "请选择夹点或基点"))
       )
      )
;;;      ;;如果输入“U”，则。。。
;;;      ((= pt "U")
;;;       ()
;;;      )
      ;;如果输入“S”，则。。。
      ((= pt "S")
        (initget "S J")
        (if (= sf_drag "S")
          (setq str "实时")
          (setq str "精确")
        )
        (if (setq tmp
                   (getkword
                     (strcat "\n选择拖放模式[实时(S)/精确(J)]<" str ">")
                   )
            )
          (setq sf_drag tmp)
        )
      )
      ;;输入为空时退出
      (t
       (setq is t)
      )
    )
  )
  (sssetfirst nil nil)
  (vl-cmdf "_.erase" m_delss "") ;删除临时矩形
)

;;;判断是否为中点
(defun sf-isZhongDian (pt plst / pl hs zd n)
  (setq        pl (list (nth 0 plst)
                 (list (caar plst) (cadadr plst))
                 (nth 1 plst)
                 (list (caadr plst) (cadar plst))
                 (nth 0 plst)
           )
        pt (list (car pt) (cadr pt))
  )
  (setq n 0)
  (repeat 4
    (setq zd (HB_ZHONGDIAN (nth n pl) (nth (1+ n) pl)))
    (if        (equal pt zd 0.001)
      (if (= (rem n 2) 0)
        (setq hs car)
        (setq hs cadr)
      )
    )
    (setq n (1+ n))
  )
  hs
)

;;;判断是否为角点
(defun sf-isJiaDian (pt plst /)
  (if (and (or (= (car pt) (caar plst))
               (= (car pt) (caadr plst))
           )
           (or (= (cadr pt) (cadar plst))
               (= (cadr pt) (cadadr plst))
           )
      )
    pt
  )
)

;;;建立无名块
(defun sf-buildNoNameBk        (ss pt / tmp n na ent rel)
  (setq pt (trans pt 1 0))
  (entmake (list '(0 . "BLOCK")
                 '(2 . "*U")
                 (cons 10 pt)
                 (cons 70 1)
           )
  )
  (setq n 0)
  (repeat (sslength ss)
    (setq na  (ssname ss n)
          ent (entget na)
          n   (1+ n)
    )
    (entmake ent)
  )
  (setq tmp (entmake (list (cons 0 "ENDBLK"))))
  (if tmp
    (entmake (list (cons 0 "INSERT")
                   (cons 2 tmp)
                   (cons 10 pt)
             )
    )
  )
  (setq rel (entlast))
  (vl-cmdf "_.erase" ss "")
  rel
)

;;;矩形变换
(defun sf-gaiRec (ss rec bpt pt p1 / bk bl1 bl2 ent csx csy)
  (setq        csx (- (car pt) (car bpt))
        csy (- (cadr pt) (cadr bpt))
  )
  (setq        bk  (sf-buildNoNameBk ss bpt)
        ent (entget bk)
  )
  (if (equal csx 0 0.0000001)
    (setq bl1 1)
    (setq bl1 (/ (- (car p1) (car bpt))
                 (- (car pt) (car bpt))
              )
    )
  )
  (if (equal csy 0 0.0000001)
    (setq bl2 1)
    (setq bl2 (/ (- (cadr p1) (cadr bpt))
                 (- (cadr pt) (cadr bpt))
              )
    )
  )
  (if (= bl1 0) (setq bl1 1))
  (if (= bl2 0) (setq bl2 0))
  (setq        ent (subst (cons 41 bl1)
                   (assoc 41 ent)
                   ent
            )
        ent (subst (cons 42 bl2)
                   (assoc 42 ent)
                   ent
            )
  )
  (entmod ent)
  (entupd bk)
  (vl-cmdf "_.explode" bk "")
)

;;;获得矩形的对角点
(defun sf-duiJiaoDian (plst pt / px py)
  (if (/= (caar plst) (car pt))
    (setq px (caar plst))
    (setq px (caadr plst))
  )
  (if (/= (cadar plst) (cadr pt))
    (setq py (cadar plst))
    (setq py (cadadr plst))
  )
  (list px py)
)

;;;角点变换矩形
(defun sf-moveRectang (nalst plst bpt pt newpt / p0 newp0 newang blx bly
                       n rel cx        cy)
  (setq        p0    (SF-DUIJIAODIAN plst pt)
        blx   (/ (- (car newpt) (car bpt)) (- (car pt) (car bpt)))
        bly   (/ (- (cadr newpt) (cadr bpt)) (- (cadr pt) (cadr bpt)))
        )
  (if (= blx 0) (setq blx 1))
  (if (= bly 0) (setq bly 1))
  (setq newp0 (sf-getNewPoint (list blx bly) bpt p0))
  (setq        lp  (list newpt
                  (list (car newpt) (cadr newp0))
                  newp0
                  (list (car newp0) (cadr newpt))
                  newpt
            )
        rel (list newpt newp0)
  )
  (setq n 0)
  (repeat (length nalst)
    (setq ent (entget (nth n nalst)))
    (setq ent (subst (cons 10 (nth n lp)) (assoc 10 ent) ent)
          ent (subst (cons 11 (nth (1+ n) lp)) (assoc 11 ent) ent)
    )
    (entmod ent)
    (setq n (1+ n))
  )
  rel
)

;;;中点变换矩形
(defun sf-moveRectangMid (nalst        plst  bpt   pt          newpt        hs    /
                          newJl        oldJl bl    p0          p1        lp    rel
                          ent
                         )
  (setq        newJl (- (hs newpt) (hs bpt))
        oldJl (- (hs pt) (hs bpt))
  )
  (if (/= newJl 0)
    (progn
      (if (= oldJl 0)
        (setq bl 1)
        (setq bl (/ newJl oldJl))
      )
      (if (= hs car)
        (setq p0 (SF-GETNEWPOINT (list bl 1) bpt (nth 0 plst))
              p1 (SF-GETNEWPOINT (list bl 1) bpt (nth 1 plst))
        )
        (setq p0 (SF-GETNEWPOINT (list 1 bl) bpt (nth 0 plst))
              p1 (SF-GETNEWPOINT (list 1 bl) bpt (nth 1 plst))
        )
      )
      (setq lp        (list p0
                      (list (car p0) (cadr p1))
                      p1
                      (list (car p1) (cadr p0))
                      p0
                )
            rel        (list newpt p0 p1)
      )
      (setq n 0)
      (repeat (length nalst)
        (setq ent (entget (nth n nalst)))
        (setq ent (subst (cons 10 (nth n lp)) (assoc 10 ent) ent)
              ent (subst (cons 11 (nth (1+ n) lp)) (assoc 11 ent) ent)
        )
        (entmod ent)
        (setq n (1+ n))
      )
    )
  )
  rel
)

;;;获得新的点
(defun sf-getNewPoint (bllst bpt pt /)
  (list        (+ (car bpt) (* (- (car pt) (car bpt)) (nth 0 bllst)))
        (+ (cadr bpt) (* (- (cadr pt) (cadr bpt)) (nth 1 bllst)))
  )
)

;;;移动基点
(defun sf-moveBase (bna / pt ent e10)
  (setq        ent (entget bna)
        e10 (cdr (assoc 10 ent))
        pt  (getpoint e10 "\n输入新的基点:")
  )
  (if pt
    (progn
      (setq ent (subst (cons 10 pt) (assoc 10 ent) ent))
      (entmod ent)
      (entupd bna)
      (setq rel pt)
    )
    (setq rel e10)
  )
  rel
)

;;;获得选择目标的矩形范围
(defun sf-ssBox
                (ss        /      rel    vlaxObj            minP   maxP
                 minExt        maxExt n      xx     xy            dx           dy
                 oldvar
                )
  (setq n 0)
  (repeat (sslength ss)
    (setq vlaxObj (vlax-ename->vla-object (ssname ss n))
          minP          (vlax-make-variant)
          maxP          (vlax-make-variant)
          n          (1+ n)
    )
    (vla-GetBoundingBox vlaxObj 'minP 'maxP)
    (setq minExt (vlax-safearray->list minP)
          maxExt (vlax-safearray->list maxP)
    )
    (if        (= n 1)
      (setq xx (car minExt)
            xy (cadr minExt)
            dx (car maxExt)
            dy (cadr maxExt)
      )
      (progn
        (if (> xx (car minExt))
          (setq xx (car minExt))
        )
        (if (> xy (cadr minExt))
          (setq xy (cadr minExt))
        )
        (if (< dx (car maxExt))
          (setq dx (car maxExt))
        )
        (if (< dy (cadr maxExt))
          (setq dy (cadr maxExt))
        )
      )
    )
  )
  (list (list xx xy) (list dx dy))
)

;;;最后的对象
(defun sf-zdLastent (/ tmp rel)
  (setq        tmp (entlast)
        rel tmp
  )
  (while (setq tmp (entnext tmp))
    (setq rel tmp)
  )
  rel
)
;;;新画的对象
(defun sf-newDraw (end / rel tmp)
  (setq        tmp end
        rel (ssadd)
  )
  (while (setq tmp (entnext tmp))
    (ssadd tmp rel)
  )
  rel
)

;;;绘制矩形
(defun sf-drawRectang (/ oldvar end)
  (setq        oldvar (HB_SETVAR (list (cons "osmode" 0)))
        end    (sf-zdLastent)
  )
  (vl-cmdf "_.line"
           (car n_plst)
           (list (caar n_plst) (cadadr n_plst))
           (cadr n_plst)
           (list (caadr n_plst) (cadar n_plst))
           "c"
  )
  (HB_SETVAR oldvar)
  (sf-newDraw end)
)

;;;绘制基点
(defun sf-drawBase (/ bkna l1 l2 ssa pt bl)
  (setq bkna "hb_sf_base")
  (if (null (TBLSEARCH "block" bkna))
    (progn
      (setq l1        (list '(1 1) '(-1 -1))
            l2        (list '(-1 1) '(1 -1))
            ssa        (ssadd)
      )
      (HB_DRAWPL l1)
      (ssadd (entlast) ssa)
      (HB_DRAWPL l2)
      (ssadd (entlast) ssa)
      (vl-cmdf "_.block" bkna '(0 0) ssa "")
    )
  )
  (setq        pt (HB_ZHONGDIAN (car n_plst) (cadr n_plst))
        bl (fix (/ (DISTANCE (car n_plst) (cadr n_plst)) 50))
  )
  (entmake (list (cons 0 "INSERT")
                 (cons 2 bkna)
                 (cons 10 pt)
                 (cons 41 bl)
                 (cons 42 bl)
           )
  )
  (entlast)
)
[/php]

下面是通用的函数，需要加载后才能使用上面的程序
[php]

;;;
;;;个人通用函数
;;;
;;;
;;;
;;;
;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;----全局变量----;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(VL-LOAD-COM)
;;;加载 ActiveX
(setq vlaxDoc(vla-get-ActiveDocument
           (vlax-get-Acad-Object)
         )
      *ModelSpace* (vla-get-ModelSpace vlaxDoc)
)
;;;获取模型空间的指针

(setq n_lst(list ""))

(setq olderr *error*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;程序初始及结束设置
(defun hb_start        (lst is /)
  (if is
    (progn
      (vla-StartUndoMark vlaxDoc)
      (setq n_lst(HB_SETVAR lst))
      (setq *error* hb_error)
    )
    (progn
      (setq *error* olderr)
      (HB_SETVAR n_lst)
      (vla-EndUndoMark VLAXDOC)
    )
  )
)


;;;自定义出错函数
(defun hb_error        (a /)
  (if (not (member a '("函数被取消" "Function cancelled" "quit / exit abort")))
  (princ a)
    )
  (if m_redraw
    (progn
      (redraw m_reDraw 4)
      (setq m_reDraw nil)
    )
  )
  (if m_delss
    (progn
      (vl-cmdf "_.erase" m_delss "")
      (setq m_delss nil)
    )
  )
  (HB_SETVAR n_lst)
  (setq *error* olderr)
  (vla-EndUndoMark VLAXDOC)
)

;;;三维点转二维点
(defun hb_3dpto2dp (point / rel)
  (list (car point) (cadr point))
)

;;;获得当前UCS相对于WCS的角度
(defun hb_ucsAng (/ rel)
  (ANGLE (trans '(0 0) 1 0) (trans '(1 0) 1 0))
)

;;;将度转换为弧度
(defun hb_duToHu (du) (* pi (/ du 180.0)))

;;;将弧度转换为度
(defun hb_HuToDu (hu) (* 180 (/ hu pi)))

;;;将表转换为包含双精度实数数组
(defun hb_ltoa (ptsList / arraySpace sArray)
                                        ; 给以双精度实数表示的二维点数组分配空间
  (setq        arraySpace
         (vlax-make-safearray
           vlax-vbdouble                ; 元素类型
           (cons 0
                 (- (length ptsList) 1)
           )                                ; 数组维数
         )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
                                        ; 返回数组变体
  (vlax-make-variant sArray)
)


;;;使用ActiveX绘制多段线
(defun hb_drawPL (plst / n point dp)
  (setq n 0)
  (repeat (length plst)
    (setq point        (nth n plst)
          point        (HB_3DPTO2DP (trans point 1 0))
          dp        (append dp point)
    )
    (setq n (+ n 1))
  )
  (setq dp (HB_LTOA dp))
  (vla-AddLightWeightPolyline
    *MODELSPACE*
    dp
  )
)


;;;注册表操作函数
(defun hb_Reg (lst keyWz isRead / key mykey n na rd rel)
  (setq        key   (vlax-product-key)
        mykey (strcat "HKEY_CURRENT_USER\\\\" key "\\\\HbSet\\\\" keyWz)
  )
  (setq n 0)
  (if isRead
    (repeat (length lst)
      (setq na (nth n lst))
      (setq rd (VL-REGISTRY-READ mykey (car na)))
      (if rd
        (setq rel (cons (cons (car na) rd) rel))
        (setq rel (cons na rel))
      )
      (setq n (+ n 1))
    )
    (repeat (length lst)
      (setq na (nth n lst))
      (VL-REGISTRY-WRITE mykey (car na) (cdr na))
      (setq n (+ n 1))
    )
  )
  rel
)


;;;设置系统变量
(defun hb_setVar (lst / n na rel)
  (if lst
    (progn
      (setq n 0)
      (repeat (length lst)
        (setq na (nth n lst))
        (setq rel (cons (cons (car na) (getvar (car na))) rel))
        (setvar (car na) (cdr na))
        (setq n (+ n 1))
      )
    )
  )
  rel
)


;;;获得系统变量
(defun hb_getVar (lst / n na rel)
  (if lst
    (progn
      (setq n 0)
      (repeat (length lst)
        (setq na (nth n lst))
        (setq rel (cons (cons na (getvar na)) rel))
        (setq n (+ n 1))
      )
    )
  )
  rel
)

;;;计算中点
(defun hb_zhongDian(dian1 dian2 / ax ay)
  (setq ax (- (car dian2) (car dian1))
        ay (- (cadr dian2) (cadr dian1))
        )
  (list (+ (car dian1) (/ ax 2)) (+ (cadr dian1) (/ ay 2)))
  )


;;;获取一个字符串中的数字
(defun hb_getShuzi (str / sz n len tmp cha isdian rel)
  (if str
    (progn
      (setq sz "1234567890.")
      (setq n 1)
      (setq len (strlen str))
      (repeat len
        (setq cha (substr str n 1))
        (if (VL-STRING-SEARCH cha sz)
          (progn
            (if        (= cha ".")
              (if isdian
                (setq cha "")
                (setq isdian t)
              )
            )
            (if        tmp
              (setq tmp (strcat tmp cha))
              (setq tmp cha)
            )
          )
        )
        (setq n (1+ n))
      )
    )
  )
  (setq rel tmp)
)




;;;从选择集中获取数据列表
(defun hb_getShuju (ss lst / m n tmp tmp0 rel na ent a0)
  (setq n 0)
  (repeat (sslength ss)
    (setq na  (ssname ss n)
          ent (entget na)
    )
    (setq m (length lst))
    (repeat (length lst)
      (setq m (- m 1))
      (setq a0 (cdr (assoc (nth m lst) ent)))
      (if (not tmp)
        (setq tmp (list a0))
        (setq tmp (append (list a0) tmp))
      )
    )
    (if        (not rel)
      (setq rel (list tmp))
      (setq rel (cons tmp rel))
    )
    (setq tmp nil)
    (setq n (+ n 1))
  )
  rel
)

(defun hb_getNameText (na / rel ent lx lst)
  (setq        lst '("TEXT" "MTEXT" "ATTDEF" ));;"ATTRIB" "INSERT"))
  (setq ent (entget na)
        lx  (cdr (assoc 0 ent))
        )
  (if (member lx lst)
    (setq rel (cdr (assoc 1 ent)))
    )
  rel
)

;;;获取目标中的文字信息
(defun hb_getText (msg / sel rel ent lx tmp lst i)
  (setq        lst '("TEXT" "MTEXT" "ATTDEF" "ATTRIB" "INSERT")
  )

  (while (not i)
    (setq sel (car (entsel msg)))
    (if        sel
      (progn
        (setq ent (entget sel)
              lx  (cdr (assoc 0 ent))
        )
        (setq i (member lx lst))
        (if (not i)
          (princ "选择的目标不含有效信息！")
        )
      )
      (princ msg)
    )
  )

  (if (or (= lx "TEXT")
          (= lx "MTEXT")
          (= lx "ATTDEF")
          (= lx "ATTRIB")
      )
    (setq rel (cdr (assoc 1 ent)))
  )
  (if (and (= lx "INSERT") (= (cdr (assoc 66 ent)) 1))
    (setq tmp (acet-insert-attrib-get (list sel 1))
          rel (nth 1 (nth 0 tmp))
    )
  )
  rel
)


(defun hb_tableList (na is / rel tmp i)
  (setq rel (list (cdr (assoc 2 (tblnext na t)))))
  (while (not i)
    (setq tmp (cdr (assoc 2 (tblnext na))))
    (if        tmp
      (if is
        (if (/= (substr tmp 1 1) "*")
          (setq rel (append rel (list tmp)))
        )
        (setq rel (append rel (list tmp)))
      )
      (setq i t)
    )
  )
  rel
)

(defun hb_addCons ( ent cns at / n rel nlt)
  (setq nlt (length ent))
  (setq n (- nlt 1))
  (if (> nlt at)
  (repeat nlt
    (setq rel(cons (nth n ent) rel))
    (if (= n at)
      (setq rel (cons cns rel))
      )
    (setq n (1- n))
    )
    (progn
      (setq rel (cons cns rel))
      (repeat nlt
        (setq rel(cons (nth n ent) rel))
        (setq n (1- n))
        )
      )
    )
  rel
  )

(defun hb_getEntCount(ent ename / tmp n rel cns)
  (foreach cns ent
    (if (= (car cns) ename)
      (progn
        (setq tmp (cdr cns))
        (setq rel (cons tmp rel))
        )
      )
    )
  (reverse rel)
  )

(defun hb_list_fanXu(ent / rel tmp n len)
  (setq n 0)
  (repeat (length ent)
    (setq tmp(nth n ent)
          rel(cons tmp rel)
          n (1+ n)
          )
    )
  rel
  )

(defun hb_list_enaDel(lst ena / tmp rel)
  (foreach tmp lst
    (if (/= (car tmp) ena)
      (setq rel (cons tmp rel))
      )
    )
  (reverse rel)
  )

(defun hb_list_replaceAt(lst nitem at / tmp rel n)
  (setq n 0)
  (repeat (length lst)
    (setq tmp(nth n lst))
    (if (= n at)
      (setq rel (cons nitem rel))
      (setq rel (cons tmp rel))
      )
    (setq n(1+ n))
    )
  (reverse rel)
  )

(defun hb_list_delAt(lst at / tmp rel n)
  (setq n 0)
  (repeat (length lst)
    (setq tmp(nth n lst))
    (if (/= n at)
      (setq rel(cons tmp rel))
      )
    (setq n(1+ n))
    )
  (REVERSE rel)
  )

(defun hb_list_replaceEnt(ent lst / tmp)
  (foreach tmp lst
    (if (assoc (car tmp) ent)
    (setq ent(subst tmp (assoc (car tmp) ent) ent))
      (setq ent (REVERSE ent)
            ent (cons tmp ent)
            ent (REVERSE ent))
      )
    )
  ent
  )

(defun hb_list_replaceFor(lst newlst cns / tmp rel n)
  (setq n 0)
  (foreach tmp lst
    (if (= (car tmp) cns)
      (setq rel (cons (cons cns (nth n newlst)) rel)
            n (1+ n)
            )
      (setq rel (cons tmp rel))
      )
    )
  (reverse rel)
  )

(defun hb_ss_copy (ss / rel tmp n)
  (setq n 0)
  (setq rel(ssadd))
  (if ss
    (progn
      (repeat (sslength ss)
        (setq tmp (ssname ss n))
        (ssadd tmp rel)
        (setq n(1+ n))
        )
      )
    )
  rel
  )

(defun hb_ssToLst (ss / na ent ena n rel)
  (setq n 0)
  (repeat (sslength ss)
    (setq na  (ssname ss n)
          ent (entget na)
          ena (cdr (assoc -1 ent))
    )
    (setq rel (cons ena rel)
          n   (1+ n)
    )
  )
  (reverse rel)
)


(defun hb_ss_delByEnt
       (ss lst is / tmp n rel na ent tmpar tmpdr tmpent pd)
  (if ss
    (progn
      (setq rel (ssadd))
      (setq n  0)
      (repeat (sslength ss)
        (setq na  (ssname ss n)
              ent (entget na)
              pd t
        )
        (foreach tmp lst
          (setq        tmpar (car tmp)
                tmpdr (cdr tmp)
          )
          (if
            (and (setq tmpent (assoc tmpar ent)) (WCMATCH (cdr tmpent) tmpdr))
             ()
             (setq pd nil)
          )
        )
        (if is
          (if (not pd)
            (ssadd na rel)
          )
          (if pd
            (ssadd na rel)
          )
        )
        (setq n (1+ n))
      )
    )
  )
  rel
)

(defun hb_dlg_image(key sldna / dimx dimy)
   (setq dimx(dimx_tile key)
        dimy(dimy_tile key))
  (start_image key)
  (fill_image 0 0 dimx dimy 0)
  (slide_image 0 0 dimx dimy sldna)
  (end_image)
  )

(defun hb_get_entX(ent cnt / rel e )
  (foreach e ent
    (if (= (car e) cnt)
      (setq rel(cons (cdr e) rel))
      )
    )
  (reverse rel)
  )

(defun hb_get_SupDir (/ path n)
  (setq        path (getvar "ACADPREFIX")
        n    (VL-STRING-SEARCH ";" path)
        path (substr path 1 n)
        path (strcat path "\\\\")
  )
)

(defun hb_getFileDate (fna / rel tmp file)
  (if (setq file (open fna "r"))
    (progn
      (while (setq tmp (read-line file))
        (setq rel (cons tmp rel))
      )
      (setq rel (reverse rel))
      (close file)
    )
  )
  rel
)

(defun hb_setMyVar
                   (na          vla        /     file  path  fna        tmp   str
                    is          rel        wtvla sjlst n          qm        hm    sj
                   )
  (setq        path  (HB_GET_SUPDIR)
        fna   (strcat path "hb_var102.ini")
        is    t
        na    (strcase na)
        wtvla (strcat na "=" vla)
        sjlst (HB_GETFILEDATE fna)
        n     0
  )
  (while (and is (< n (length sjlst)))
    (setq tmp (nth n sjlst))
    (if        (/= (substr tmp 1 1) ";")
      (if (setq sj (HB_STRING_BYCHAR tmp "="))
        (progn
          (setq qm (strcase (car sj)))
          (if (= na qm)
            (setq sjlst        (subst wtvla tmp sjlst)
                  is        nil
                  rel        (cdr sj)
            )
          )
        )
      )
    )
    (setq n (1+ n))
  )
  (if is
    (setq sjlst (append sjlst (list wtvla)))
    (setq is t)
  )
  (setq file (open fna "w"))
  (MAPCAR '(LAMBDA (itm) (write-line itm file))
          sjlst
  )
  (close file)
  rel
)




(defun hb_getMyVar (na / file path fna tmp str is rel sj)
  (setq        path (HB_GET_SUPDIR)
        fna  (strcat path "hb_var102.ini")
        is   t
        na  (strcase na)
  )
  (if (setq file (open fna "r"))
    (progn
      (while (and is (setq tmp (read-line file)))
        (setq tmp (strcase tmp))
        (if (/= (substr tmp 1 1) ";")
          (if (setq sj (HB_STRING_BYCHAR tmp "="))
            (progn
              (setq qm (car sj)
                    hm (cadr sj)
              )
              (if (= na qm)
                (setq rel hm
                      is  nil
                )
              )
            )
          )
        )
      )
      (close file)
    )
  )
  rel
)

(defun hb_string_byChar(str char / n lft rig rel)
  (if (setq n  (VL-STRING-SEARCH "=" str))
    (setq lft (substr str 1 n)
          rig (substr str (+ n 2) (- (strlen str) n 1))
          rel  (list lft rig)
          )
    )
  rel
  )

(defun hb_dlg_listAdd(key lst / )
  (start_list key)
  (MAPCAR 'add_list lst)
  (end_list)
  )

(defun hb_dlg_start(dlgname dlg wz / rel dlgloaded dlgshow)
  (setq dlgloaded t
        dlgshow  t)
  (if (null wz)
    (setq wz '(-1 -1))
    )
  (if (= -1 (setq rel(load_dialog dlgname)))
    (progn
      (princ (strcat "\n" dlgname "文件无法加载"))
      (setq dlgloaded nil
            rel nil)
    )
    )
  (if (and dlgloaded (not (new_dialog dlg rel "" wz)))
    (progn
      (princ "\n无法显示该对话框")
      (setq dlgshow nil
            rel nil)
      )
    )
  rel
  )

(defun hb_txt_lstToStr (lst cha / rel)
  (setq rel "")
  (MAPCAR '(LAMBDA (itm) (setq rel (strcat rel itm cha)))
          lst
  )
  (setq rel(substr rel 1 (- (strlen rel) 1)))
)

(defun hb_txt_strToLst (str cha / rel)
  (while (setq n (VL-STRING-SEARCH cha str))
    (setq rel (cons (substr str 1 n) rel)
          str (substr str (+ 2 n) (- (strlen str) n 1))
    )
  )
  (REVERSE rel)
)

(defun hb_getSysTime(wei / n)
  (setq rel (HB_XIAOSHU (getvar "cdate") 8)
        n (VL-STRING-SEARCH "." rel)
        rel (substr rel (+ n 2) wei))
  )

[/php]

c3a139

不错，谢谢分享！

predestinate

每次都是先做块，缩放后再炸开。呵呵，比较粗暴

lisell

同意3楼的说法.

jx2008

程序很好，多谢！

hh2776

怎么用啊？