分享一个自动插入图框的LSP源码，顺便求大师帮忙稍微修改一下

huxu823

该插件的作用是将预先准备好的图框图块插入绘图区，插入时能预估比例，然后自行根据预估比例手动输入要插入的图框比例，
需要提前将图框dwg文件放到CAD支持的目录下（如附图所示），然后加载本插件就可以直接使用。
命令：FR是插入横向图框，RF是插入竖向图框，插入时按提示选择A1\A2\A3\A4图框

由于A4图框工作中基本用不到，所以本人已经把A4图框改为A0图框！
应网友需求，上传本人自用的图框文件，有需要的可以自行下载根据自己的需求修改

此插件有个BUG，就是在插入选定的图框时（比如A2图框），如果鼠标框选的范围是A2图框的比例的100倍以内，那么能够推荐一个合适的比例，方便手动输入图框比例；但是如果鼠标框选的范围是A2图框的比例的100倍以上，那么推荐的比例就只能默认为100（上限只能提示到100），不能正确推荐100以上的比例（比如150或者200等等），而且此时如果手动输入100，那么插入的图框是完整的1:100的图框；但是，如果此时按照程序的提示，按空格默认为100比例，那么此时插入的图框会丢失部分线条。


希望高手帮忙修改一下：
1、不管鼠标框选的范围是所选图框比例的多少倍，都能提示正确的推荐比例（包括100以上），以便手动输入合适的图框比例；
2、去掉源码中按空格为默认比例100的功能，因为该功能导致插入的图框丢失部分线条；


源码如下：此源码为网上转载，然后把原作的A4图框改成了A0图框！
;;;;;;;;;;;;;;;;;;插入图框
;;;;插入横向图框
(DEFUN C:fr ()
  (addframe)
)
;;;;插入竖向图框
(DEFUN C:rf ()
  (addframe1)
)
;;;;;;;;;;;;;;;;;;插入图框

;;;;;;;;;;;;;;;;;;;;addframe
(DEFUN addframe ()
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;错误处理程序
  (defun *error* (msg)
  (setvar "cmdecho" cmdecho) ;_ 恢复cmdecho系统变量
  (setvar "osmode" osmode) ;_ 恢复osmode系统变量
  (princ "error:")
  (princ msg)      ;_ 打印错误信息
  (princ)         
  )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;错误处理程序

  (setq cmdecho (getvar "cmdecho")) ;保存系统变量cmdecho值
  (setvar "cmdecho" 0) ;关闭命令行的回显提示
  (setq osmode (getvar "osmode"));保存系统变量osmode值
  (setvar "osmode" 1)
  
  
  ;(setq osmodeold (getvar "osmode"))
  ;(setvar "cmdecho" 0)
  ;(setvar "osmode" 0)
  (vl-load-com)
  (setq cursorlocation-ucs (cadr (grread t 5)))
  (setq cursorlocation (trans cursorlocation-ucs 1 0) )
  (setq p0X (car cursorlocation))
  (setq p0Y (cadr cursorlocation))
  (setq systime (menucmd "M=$(edtime,$(getvar,date),YYMODD)"))
  (COMMAND "-LAYER" "S" "0" "")
  (SETQ LE (GETPOINT "\n A1请↙框选,A2请↘框选,A3请↗框选,A0请↖框选:"))
  (SETQ RI (GETCORNER le "\n A1请↙框选,A2请↘框选,A3请↗框选,A0请↖框选:"))
  (setq x1 (car LE))
  (setq y1 (cadr LE))
  (setq x2 (car RI))
  (setq y2 (cadr RI))
  
  (if (and (<= (- x2 x1) 0) (<= (- y2 y1) 0))
;;;右上往左下↙
    (progn
      (setq x3 x2)
      (setq y3 y2)
      (setq x4 x1)
      (setq y4 y1)
      (setq fr 1)
    )
  )
  
  (if (and (> (- x2 x1) 0) (< (- y2 y1) 0))
;;;左上往右下↘
    (progn
      (setq x3 x1)
      (setq y3 y2)
      (setq x4 x2)
      (setq y4 y1)
      (setq fr 2)
    )
  )
  
  (if (and (>= (- x2 x1) 0) (>= (- y2 y1) 0))
;;;左下往右上↗
    (progn
      (setq x3 x1)
      (setq y3 y1)
      (setq x4 x2)
      (setq y4 y2)
      (setq fr 3)
    )
  )
  (if (and (< (- x2 x1) 0) (> (- y2 y1) 0))
;;;右下往左上↖
    (progn
      (setq x3 x2)
      (setq y3 y1)
      (setq x4 x1)
      (setq y4 y2)
      (setq fr 4)
    )
  )
  
;;;;;;;;;;;;;;;;;;;;处理横向图框
  (if  (= fr 1)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 1.404181)
(setq scale-in (/ (- x4 x3) 806))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 1.404181)
(setq scale-in (/ (- y4 y3) 584))
      )
    )
  )
  (if  (= fr 2)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 1.3975)
(setq scale-in (/ (- x4 x3) 559))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 1.3975)
(setq scale-in (/ (- y4 y3) 400))
      )
    )
  )
  (if (= fr 3)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 1.358885)
(setq scale-in (/ (- x4 x3) 390))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 1.358885)
(setq scale-in (/ (- y4 y3) 287))
      )
    )
  )

  (if (= fr 4)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 1.405603)
(setq scale-in (/ (- x4 x3) 1154))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 1.405603)
(setq scale-in (/ (- y4 y3) 821))
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;处理横向图框

;;;;;;;;;;;;;;;;;;;;计算推荐的scale
  (setq scale-for 0.1)
  (setq scc 100)
  (setq scd 100)    ;;;推荐的比例
  (while (<= scale-for 100)
      (if (<= (abs (- scale-in scale-for)) scc)
          (progn
             (setq scc (abs (- scale-in scale-for)))
             (setq scd scale-for)
         )
      )
      (setq scale-for (+ scale-for 0.1))
  )
;;;;;;;;;;;;;;;;;;;;计算推荐的scale

;;;;;;;;;;;;;;;;;;;;让用户选择是否使用推荐的scale
  (princ "\n")
  (setq tishi (strcat "请输入缩放比例,使用推荐比例请直接输入空格<" (rtos scd 2 1) ">:"))
  (setq scaleget (getreal tishi))
  (if (= scaleget nil)
      (progn
            (setq sc scd)
      )
      (progn
            (setq sc scaleget)
      )
  )
;;;;;;;;;;;;;;;;;;;;让用户选择是否使用推荐的scale

;;;;;;;;;;;;;;;;;;;;;;;;;;求横向图框左下角所在的基点
  (if  (= fr 1)
    (progn
      (setq x33 (- x3 (- (* sc 420.5000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 297.0000) (/ (- y4 y3) 2))))
    )
  )
  
  (if  (= fr 2)
    (progn
      (setq x33 (- x3 (- (* sc 297.0000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 210.0000) (/ (- y4 y3) 2))))
    )
  )
  (if (= fr 3)
    (progn
      (setq x33 (- x3 (- (* sc 210.0000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 148.5000) (/ (- y4 y3) 2))))
    )
  )

  (if (= fr 4)
    (progn
      (setq x33 (- x3 (- (* sc 594.5000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 420.5000) (/ (- y4 y3) 2))))
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;求横向图框左下角所在的基点

  (SETQ IN (list x33 y33))
;;;;;;;;;;;;;;;;;;;;;;插入横向图框
  (if (= fr 1)
    (progn
      (COMMAND "-INSERT" "A1-H" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  
  (if  (= fr 2)
    (progn
      (COMMAND "-INSERT" "A2-H" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  (if (= fr 3)
    (progn
      (COMMAND "-INSERT" "A3-H" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  
  (if  (= fr 4)
    (progn
      (COMMAND "-INSERT" "A0-H" IN sc sc "")
      (setq ss1 (ssget "L"))
      (command "EXPLODE" ss1 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;插入横向图框
  (setvar "osmode" osmode)
  (setvar "cmdecho" cmdecho)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;addframe

;;;;;;;;;;;;;;;;;;;;addframe1
(DEFUN addframe1()
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;错误处理程序
  (defun *error* (msg)
  (setvar "cmdecho" cmdecho) ;_ 恢复cmdecho系统变量
  (setvar "osmode" osmode) ;_ 恢复osmode系统变量
  (princ "error:")
  (princ msg)      ;_ 打印错误信息
  (princ)         
  )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;错误处理程序

  (setq cmdecho (getvar "cmdecho")) ;保存系统变量cmdecho值
  (setvar "cmdecho" 0) ;关闭命令行的回显提示
  (setq osmode (getvar "osmode"));保存系统变量osmode值
  (setvar "osmode" 1)
  
  
  (vl-load-com)
  (setq cursorlocation-ucs (cadr (grread t 5)))
  (setq cursorlocation (trans cursorlocation-ucs 1 0) )
  (setq p0X (car cursorlocation))
  (setq p0Y (cadr cursorlocation))
  (setq systime (menucmd "M=$(edtime,$(getvar,date),YYMODD)"))
  (COMMAND "-LAYER" "S" "0" "")
  (SETQ LE (GETPOINT "\n A1请↙框选,A2请↘框选,A3请↗框选,A0请↖框选:"))
  (SETQ RI (GETCORNER le "\n A1请↙框选,A2请↘框选,A3请↗框选,A0请↖框选:"))
  (setq x1 (car LE))
  (setq y1 (cadr LE))
  (setq x2 (car RI))
  (setq y2 (cadr RI))

  (if (and (<= (- x2 x1) 0) (<= (- y2 y1) 0))
;;;右上往左下↙
    (progn
      (setq x3 x2)
      (setq y3 y2)
      (setq x4 x1)
      (setq y4 y1)
      (setq fr 1)
    )
  )
  (if (and (> (- x2 x1) 0) (< (- y2 y1) 0))
;;;左上往右下↘
    (progn
      (setq x3 x1)
      (setq y3 y2)
      (setq x4 x2)
      (setq y4 y1)
      (setq fr 2)
    )
  )
  
  (if (and (>= (- x2 x1) 0) (>= (- y2 y1) 0))
;;;左下往右上↗
    (progn
      (setq x3 x1)
      (setq y3 y1)
      (setq x4 x2)
      (setq y4 y2)
      (setq fr 3)
    )
  )
  (if (and (< (- x2 x1) 0) (> (- y2 y1) 0))
;;;右下往左上↖
    (progn
      (setq x3 x2)
      (setq y3 y1)
      (setq x4 x1)
      (setq y4 y2)
      (setq fr 4)
    )
  )

;;;;;;;;;;;;;;;;;;;;处理竖向图框
  (if  (= fr 1)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 0.712159)
(setq scale-in (/ (- x4 x3) 574))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 0.712159)
(setq scale-in (/ (- y4 y3) 806))
      )
    )
  )
  (if  (= fr 2)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 0.715564)
(setq scale-in (/ (- x4 x3) 400))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 0.715564)
(setq scale-in (/ (- y4 y3) 559))
      )
    )
  )
  (if (= fr 3)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 0.735897)
(setq scale-in (/ (- x4 x3) 287))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 0.735897)
(setq scale-in (/ (- y4 y3) 390))
      )
    )
  )
  (if (= fr 4)
    (progn
      (if (>= (/ (- x4 x3) (- y4 y3)) 0.711438)
(setq scale-in (/ (- x4 x3) 821))
      )
      (if (< (/ (- x4 x3) (- y4 y3)) 0.711438)
(setq scale-in (/ (- y4 y3) 1154))
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;处理竖向图框

;;;;;;;;;;;;;;;;;;;;计算推荐的scale
  (setq scale-for 0.1)
  (setq scc 100)
  (setq scd 100)    ;;;推荐的比例
  (while (<= scale-for 100)
      (if (<= (abs (- scale-in scale-for)) scc)
          (progn
             (setq scc (abs (- scale-in scale-for)))
             (setq scd scale-for)
         )
      )
      (setq scale-for (+ scale-for 0.1))
  )
;;;;;;;;;;;;;;;;;;;;计算推荐的scale

;;;;;;;;;;;;;;;;;;;;让用户选择是否使用推荐的scale
  (princ "\n")
  (setq tishi (strcat "请输入缩放比例,使用推荐比例请直接输入空格<" (rtos scd 2 1) ">:"))
  (setq scaleget (getreal tishi))
  (if (= scaleget nil)
      (progn   
            (setq sc scd)
      )
      (progn
            (setq sc scaleget)
      )
  )
;;;;;;;;;;;;;;;;;;;;让用户选择是否使用推荐的scale

;;;;;;;;;;;;;;;;;;;;;;;;;;求竖向图框左下角所在的基点
  (if  (= fr 1)
    (progn
      (setq x33 (- x3 (- (* sc 297.0000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 420.5000) (/ (- y4 y3) 2))))
    )
  )
  (if  (= fr 2)
    (progn
      (setq x33 (- x3 (- (* sc 210.0000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 297.0000) (/ (- y4 y3) 2))))
    )
  )
  (if (= fr 3)
    (progn
      (setq x33 (- x3 (- (* sc 148.5000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 210.0000) (/ (- y4 y3) 2))))
    )
  )
  (if (= fr 4)
    (progn
      (setq x33 (- x3 (- (* sc 420.5000) (/ (- x4 x3) 2))))
      (setq y33 (- y3 (- (* sc 594.5000) (/ (- y4 y3) 2))))
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;求竖向图框左下角所在的基点

  (SETQ IN (list x33 y33))
;;;;;;;;;;;;;;;;;;;;;;插入竖向图框
  (if (= fr 1)
    (progn
      (COMMAND "-INSERT" "A1-V" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  (if  (= fr 2)
    (progn
      (COMMAND "-INSERT" "A2-V" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  (if (= fr 3)
    (progn
      (COMMAND "-INSERT" "A3-V" IN sc sc "")
      (setq ss2 (ssget "L"))
      (command "EXPLODE" ss2 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
  (if  (= fr 4)
    (progn
      (COMMAND "-INSERT" "A0-V" IN sc sc "")
      (setq ss1 (ssget "L"))
      (command "EXPLODE" ss1 "")
      (setq nnn 0)
      (setq dateD (ssget "X"
    (list (cons 0 "TEXT")
          (cons 8 "frame")
          (cons 1 "120915")
    )
    )
      )
      (repeat (sslength dateD)
(progn
   (setq ent1 (ssname dateD nnn))
   (setq riqi1 (vlax-ename->vla-object ent1))
   (vlax-put-property riqi1 'TextString systime)
   (setq nnn (+ nnn 1))
)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;插入竖向图框
  (setvar "osmode" osmode)
  (setvar "cmdecho" cmdecho)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;addframe1

zcsoft

我最初做的图框LISP程序也采用你的办法，做了10个图框原图形。并且还可自动填标题栏。实际上这是个比较笨的办法。后来我把它改了，改成只需要一个原图形（标题栏）即可，其他用代码自动划线即可，这样好方便携带。换图框或改比例，原填写的标题栏会保留并且跟着变比例。

对往事说

感觉这种将图框优先设定好的方式，通用性不好。很多时候，我们不止一种图框，所以，感觉还是原先的那种先选定一种图框作为源图框的方式可能通用性更好。希望能修改出一版，框选用的程序。

huxu823

已经解决，只要把(while (<= scale-for 100)这一句中的100改为大一点的数值，建议改为1000或者更大的数字

逍遥无声

xvjiex

恳请同时也分享一下图框文档("A0-H"等)，谢谢！

huxu823

xvjiex 发表于 2020-7-13 14:04
恳请同时也分享一下图框文档("A0-H"等)，谢谢！

图框文件已上传！

海风1688

你好，恳请加上图框加长的

偶尔郁闷

可以插入 但是提示个 error:参数类型错误: lselsetp nil  版本2021

ZJKUSO

这个比例可以自动匹配吗？通过识别选框内最大边框直接套上去
然后用 分堆算法 批量插入图框？