也谈Lisp生成二维码之调用命令行exe版

edata

以前写了一个用于DCL版本基于MFC的二维码生成程序，有人说不能动态生成。
这不动态的他来了。
exe附件,例子解压到D盘，
2022-05-21更新附件，隐蔽运行

代码更新，添加边框，指定左上角点，单个方块大小

1. (defun c:tt(/ wscript stdout wsreturn outstr pt n k lst ptbase h ptleftdown ptleftup ptrightdown ptrightup size w)
   
2.   (setq WScript (vlax-get-or-create-object "WScript.Shell"))
   
3.   (setq WSreturn (vlax-invoke WScript 'exec "\"D:\\QRencodeForLisp.exe\" \"明经通道\r\ncode by edata\r\n\""))
   
4.   (setq stdout (vlax-get WSreturn 'StdOut))
   
5.   (setq outstr (vlax-invoke stdout 'Readall))
   
6.         (setq lst(read outstr))
   
7.         (if (and lst (setq ptbase(getpoint "\n左上角点:")))
   
8.                 (progn
   
9.                         ;(setq ptbase '(0 0))
   
10.                         (setq h(length lst) w(length (car lst)))
    
11.                         ;;方块的大小
    
12.                         (setq size 100.0)
    
13.                         (setq ptLeftUp (polar ptbase (* pi 1.75) (* (sqrt 2.0) (* size 0.5))))
    
14.                         (setq ptRightUp(polar ptLeftUp 0 (+ (* w size) size )))
    
15.                         (setq ptLeftDown(polar ptLeftUp (* pi 1.5) (+ (* w size) size )))
    
16.                         (setq ptRightDown(polar ptRightUp  (* pi 1.5) (+ (* w size) size )))
    
17.                         (mkFrame ptLeftUp ptLeftDown ptRightDown ptRightUp 16777215 size)
    
18.                         (setq ptbase(polar (polar ptLeftUp 0 (* 0.5 size)) (* pi 1.5) size))
    
19.                         (foreach n lst
    
20.                                 (setq pt ptbase)
    
21.                                 (foreach k n                                       
    
22.                                         (if (= k 1) (mkpline pt 0 size) (mkpline pt 16777215 size))
    
23.                                         (setq pt(polar pt 0 size))
    
24.                                         )                               
    
25.                                 (setq ptbase(polar ptbase (* pi 1.5) size))
    
26.                                 )                       
    
27.                         )
    
28.                 )
    
29.         (princ)
    
30.   )
    
31. (defun mkpline(pt col size)
    
32.         (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col) (cons 90 2) (cons 10 pt) (cons 10 (polar pt 0 size))(cons 43 size)))
    
33.         )
    
34. (defun mkFrame(p1 p2 p3 p4 col size / lst pt)
    
35.         (setq lst(list p1 p2 p3 p4))
    
36.         (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col)(cons 90 (length lst))(cons 70 1)(cons 43 size))
    
37.                                                  (mapcar '(lambda (pt)(cons 10 pt)) lst ))
    
38.                                          )
    
39.         )
    
40.        
    
41.   

(defun c:tt(/ wscript stdout wsreturn outstr pt n k lst ptbase h ptleftdown ptleftup ptrightdown ptrightup size w)<br />   (setq WScript (vlax-get-or-create-object "WScript.Shell"))<br />   (setq WSreturn (vlax-invoke WScript 'exec "\"D:\\QRencodeForLisp.exe\" \"明经通道\r\ncode by edata\r\n\""))<br />   (setq stdout (vlax-get WSreturn 'StdOut))<br />   (setq outstr (vlax-invoke stdout 'Readall))<br />         (setq lst(read outstr))<br />         (if (and lst (setq ptbase(getpoint "\n左上角点:")))<br />                 (progn<br />                         ;(setq ptbase '(0 0))<br />                         (setq h(length lst) w(length (car lst)))<br />                         ;;方块的大小<br />                         (setq size 100.0)<br />                         (setq ptLeftUp (polar ptbase (* pi 1.75) (* (sqrt 2.0) (* size 0.5))))<br />                         (setq ptRightUp(polar ptLeftUp 0 (+ (* w size) size )))<br />                         (setq ptLeftDown(polar ptLeftUp (* pi 1.5) (+ (* w size) size )))<br />                         (setq ptRightDown(polar ptRightUp  (* pi 1.5) (+ (* w size) size )))<br />                         (mkFrame ptLeftUp ptLeftDown ptRightDown ptRightUp 16777215 size)<br />                         (setq ptbase(polar (polar ptLeftUp 0 (* 0.5 size)) (* pi 1.5) size))<br />                         (foreach n lst<br />                                 (setq pt ptbase)<br />                                 (foreach k n                                        <br />                                         (if (= k 1) (mkpline pt 0 size) (mkpline pt 16777215 size))<br />                                         (setq pt(polar pt 0 size))<br />                                         )                                <br />                                 (setq ptbase(polar ptbase (* pi 1.5) size))<br />                                 )                        <br />                         )<br />                 )<br />         (princ)<br />   )<br /> (defun mkpline(pt col size)<br />         (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col) (cons 90 2) (cons 10 pt) (cons 10 (polar pt 0 size))(cons 43 size)))<br />         )<br /> (defun mkFrame(p1 p2 p3 p4 col size / lst pt)<br />         (setq lst(list p1 p2 p3 p4))<br />         (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col)(cons 90 (length lst))(cons 70 1)(cons 43 size))<br />                                                  (mapcar '(lambda (pt)(cons 10 pt)) lst ))<br />                                          )<br />         )<br />         <br />   

效果：




历史版本
2022-05-20更新附件,会有闪现


测试代码
;;例子简单的生成黑白色二维码，可以根据需求。
;;本质上调用就是 exe路径 空格 字符串
;;字符串参数换行可以使用\r\n 符合windows回车换行标准
;;字符串参数建议使用转义包裹 \" ，防止参数中有空格导致参数截断
;;路径建议使用转义包裹 \" ，防止路径中有空格导致参数截断


;;注 源码中原来的链接地址在论坛代码高亮中会被转义，去掉了链接地址

1. (defun c:tt(/ wscript stdout wsreturn outstr pt n k lst ptbase)
   
2.   (setq WScript (vlax-get-or-create-object "WScript.Shell"))
   
3.   (setq WSreturn (vlax-invoke WScript 'exec "\"D:\\QRencodeForLisp.exe\" \"明经通道\r\ncode by edata\r\n\""))
   
4.   (setq stdout (vlax-get WSreturn 'StdOut))
   
5.   (setq outstr (vlax-invoke stdout 'Readall))
   
6.   (setq lst(read outstr))
   
7.   (if lst
   
8.     (progn
   
9.       (setq ptbase '(0 0))
   
10.       (foreach n lst
    
11.         (setq pt ptbase)
    
12.         (foreach k n         
    
13.           (if (= k 1) (mkpline pt 0) (mkpline pt 16777215))
    
14.           (setq pt(polar pt 0 1))
    
15.           )        
    
16.         (setq ptbase(polar ptbase (* pi 1.5) 1))
    
17.         )
    
18.       )
    
19.     )
    
20.   (princ)
    
21.   )
    
22. (defun mkpline(pt col)
    
23.   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col) (cons 90 2) (cons 10 pt) (cons 10 (polar pt 0 1))(cons 43 1)))
    
24.   )
    

(defun c:tt(/ wscript stdout wsreturn outstr pt n k lst ptbase)<br />   (setq WScript (vlax-get-or-create-object "WScript.Shell"))<br />   (setq WSreturn (vlax-invoke WScript 'exec "\"D:\\QRencodeForLisp.exe\" \"明经通道\r\ncode by edata\r\n\""))<br />   (setq stdout (vlax-get WSreturn 'StdOut))<br />   (setq outstr (vlax-invoke stdout 'Readall))<br />   (setq lst(read outstr))<br />   (if lst<br />     (progn<br />       (setq ptbase '(0 0))<br />       (foreach n lst<br />         (setq pt ptbase)<br />         (foreach k n          <br />           (if (= k 1) (mkpline pt 0) (mkpline pt 16777215))<br />           (setq pt(polar pt 0 1))<br />           )        <br />         (setq ptbase(polar ptbase (* pi 1.5) 1))<br />         )<br />       )<br />     )<br />   (princ)<br />   )<br /> (defun mkpline(pt col)<br />   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 420 col) (cons 90 2) (cons 10 pt) (cons 10 (polar pt 0 1))(cons 43 1)))<br />   )<br />

生成结果：


识别结果





补充
命令行手工操作生成二维码列表值txt文件,

1. QRencodeForLisp.exe "建设单位：明经通道\r\n设计单位：edata" >test.txt

QRencodeForLisp.exe "建设单位：明经通道\r\n设计单位：edata" >test.txt

cq4920

自贡黄明儒 发表于 2022-5-20 11:03
等你发个应用示例，我等好照虎画猫。

2. (defun c:rrt (/ x  lien util str strlst )
   
3.         (vl-load-com)
   
4.         (setq str (cdr (assoc 1 (entget (car(entsel"点击文本"))))))
   
5.         (setq WScript (vlax-get-or-create-object "WScript.Shell"))
   
6.   (setq WSreturn (vlax-invoke WScript 'exec (strcat ""QRencodeForLisp.exe" "" str """)))
   
7.   (setq stdout (vlax-get WSreturn 'StdOut))
   
8.   (setq outstr (vlax-invoke stdout 'Readall))
   
9.     (setq strlst (read outstr))
   
10. (setq x (length strlst))
    
11. (setq  lw 1 ll lw pt (getpoint"指定插入点"))
    
12. (repeat x  
    
13.    (setq xlist (car strlst))
    
14.          (setq n x)
    
15.                 (repeat x  
    
16.                         (setq ptn (polar pt 0 (* lw n)))
    
17.                         (setq n (1- n))
    
18.                         (setq ptx (rtos (nth n xlist) 2 0 ))
    
19.                 (if (= ptx "1") (Mc:pl1-1fk ptn lw ll))
    
20.         )
    
21.         (setq pt (polar pt (* pi 1.5) lw))
    
22.         (setq strlst (vl-remove (car strlst) strlst))
    
23. )
    
24.   (redraw)
    
25. )
    
26. 
    
27. 
    
28. 
    
29. ;;(Mc:pl1-1fk pt1 lw ll) 多义线起点 宽度 长度
    
30. (defun Mc:pl1-1fk (pt lw ll / pta)
    
31. (setq pta (polar pt 0 ll))
    
32. (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 43  LW)(cons 90 2) (cons 10 pt) (cons 10 pta)))
    
33.         )
    

(defun c:rrt (/ x  lien util str strlst )<br />         (vl-load-com)<br />         (setq str (cdr (assoc 1 (entget (car(entsel"点击文本"))))))<br />         (setq WScript (vlax-get-or-create-object "WScript.Shell"))<br />   (setq WSreturn (vlax-invoke WScript 'exec (strcat ""QRencodeForLisp.exe" "" str """)))<br />   (setq stdout (vlax-get WSreturn 'StdOut))<br />   (setq outstr (vlax-invoke stdout 'Readall))<br />     (setq strlst (read outstr))<br /> (setq x (length strlst))<br /> (setq  lw 1 ll lw pt (getpoint"指定插入点"))<br /> (repeat x  <br />    (setq xlist (car strlst))<br />          (setq n x)<br />                 (repeat x  <br />                         (setq ptn (polar pt 0 (* lw n))) <br />                         (setq n (1- n))<br />                         (setq ptx (rtos (nth n xlist) 2 0 ))<br />                 (if (= ptx "1") (Mc:pl1-1fk ptn lw ll))<br />         )<br />         (setq pt (polar pt (* pi 1.5) lw))<br />         (setq strlst (vl-remove (car strlst) strlst)) <br /> )<br />   (redraw)<br /> )<br /> <br /> <br /> <br /> ;;(Mc:pl1-1fk pt1 lw ll) 多义线起点 宽度 长度<br /> (defun Mc:pl1-1fk (pt lw ll / pta)<br /> (setq pta (polar pt 0 ll))<br /> (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 43  LW)(cons 90 2) (cons 10 pt) (cons 10 pta)))<br />         )<br />

vitalgg

edata 发表于 2022-5-21 21:32
更新了附件，你试试。。
                                                                           ...

完美。

如果无法播放，请点击此处在新窗口打开

qrencode 源代码见：
https://gitee.com/atlisp/atlisp- ... encode/qrencode.lsp

edata

vitalgg 发表于 2022-5-20 22:14
https://atlisp.cn/package-info/qrencode-stable.html

屏幕会闪一下。

更新了附件，你试试。。
                                                                                    

guosheyang

感谢长老共享资料！

guosheyang

长老 请问这个具体要咋操作呢  QRencodeForLisp.exe 已放在D盘根目录下了。 这句好像运行出错   我用的是win11家庭版   CAD2017       (setq WSreturn (vlax-invoke WScript 'exec "\"D:\\QRencodeForLisp.exe\" \"明经通道\r\n<a href="http://bbs.mjtd.com" target="_blank">http://bbs.mjtd.com</a>\r\ncode by edata\r\n\""))   谢谢！

guosheyang

我运行  后   QQ 自动生成了一个智能备份文件夹 qqpcmgr_docpro  好像是防止勒索病毒加密的   

自贡黄明儒

E大，现在是二维码的天下，什么都要扫码。我有过问题，你这程序每次用“明经通道”生成的二维是否相同？假如我的图纸上，用自己的名字，而不是“明经通道”，那么这个二维码怎么同我自己联系起来？

vectra

自贡黄明儒 发表于 2022-5-20 09:23
E大，现在是二维码的天下，什么都要扫码。我有过问题，你这程序每次用“明经通道”生成的二维是否相同？假 ...

https://www.zhihu.com/question/65253283

这里有文章教大家用钛合金眼人工解码

自贡黄明儒

vectra 发表于 2022-5-20 09:33
https://www.zhihu.com/question/65253283

这里有文章教大家用钛合金眼人工解码

可否用于图纸签名？

edata

自贡黄明儒 发表于 2022-5-20 09:39
可否用于图纸签名？

一般图纸上用来存储各类信息的，具体运用还要看行业需求，比如有的人用来存储项目信息，电子图档链接。

自贡黄明儒

edata 发表于 2022-5-20 10:39
一般图纸上用来存储各类信息的，具体运用还要看行业需求，比如有的人用来存储项目信息，电子图档链接。

等你发个应用示例，我等好照虎画猫。

edata

guosheyang 发表于 2022-5-20 08:14
长老 请问这个具体要咋操作呢  QRencodeForLisp.exe 已放在D盘根目录下了。 这句好像运行出错   我用的是wi ...

lisp源代码中的链接在论坛的代码高亮中会出现了异常，刚刚更新了帖子中的lisp源码，去掉了链接地址。