tryhi 发表于 2016-3-22 11:42:54

拖进绘图区域自动加载至启动组

本帖最后由 tryhi 于 2016-3-22 12:34 编辑

在论坛一直搜索不到一个现成的加入启动组的函数，写了一个跟大家分享


(vl-Load-COM)
(defun try-tuo-path(/ path str)
(princ "\n")
(setq path (getvar "lastprompt"))
(if (wcmatch (strcase path) "*(LOAD \"*")
    (setq str (vl-string-search "(LOAD \"" path)
      path (substr path (+ str 8) (- (vl-string-search "\")" path) str 7))
    )
)
(vl-string-translate "/" "\\" path)
)
(defun try-appload-startup (path / i k n new-n strart-path)
(setq n
    (vl-registry-read
      (setq strart-path
      (strcat "HKEY_CURRENT_USER\\"
          (vlax-product-key)
          "\\Profiles\\"
          (getvar "CPROFILE")
          "\\Dialogs\\Appload\\Startup"
      ))
      "NumStartup"
    )
    i 0
    k T
)
(repeat (atoi n)
    (setq i(1+ i))
    (if(= path(vl-registry-read strart-path (strcat(itoa i)"Startup")))(setq k nil))
)
(if k
    (progn
      (vl-registry-write strart-path "NumStartup" (setq new-n(itoa (1+ (atoi n)))))
      (vl-registry-write strart-path (strcat new-n "Startup") path)
    )
)
)

;;;程序开始
(setq path(try-tuo-path))
(if (= ":"(substr path 2 1))(progn(try-appload-startup path)(prompt "\n成功加载至启动组"))(prompt "\n本程序只能通过拖动来加载"))
(prin1)注：附件的内容跟帖子里面的源码是一样的，不过多了几句无关紧要的注释，附件只是方便大家下载


自贡黄明儒 发表于 2016-3-22 11:48:18

;;;xshrimp 2011.7

qazxswk 发表于 2024-6-10 18:54:49

本帖最后由 qazxswk 于 2024-6-10 21:40 编辑


楼主的代码，我，加载不成功。我用下面的代码，加载成功

(vl-load-com)
(defun try-tuo-path(/ path str)
      (princ "\n")
      (setq path (getvar "lastprompt"));读取拖进黑框的路径
      (if (wcmatch (strcase path) "*(LOAD \"*")
                (setq str (vl-string-search "(LOAD \"" path)
                        path (substr path (+ str 8) (- (vl-string-search "\")" path) str 7))
                )
      )
      (vl-string-translate "/" "\\" path)
)
;(gps->appload-addfile "d:\\12.lsp")
(defun gps->appload-addfile (AppName /$skey numstartup)
(if (= (type appname) 'STR)
(progn
(setq$skey (strcat "HKEY_CURRENT_USER\\"
                         (vlax-product-key)
                         "\\Profiles\\"
                         (getvar "CPROFILE")
                         "\\Dialogs\\Appload\\Startup")
)
(setq NumStartup (vl-registry-read $skey "NumStartup"))
(if NumStartup
    (progn
    (vl-registry-write $skey (strcat (itoa (+ 1 (atoi NumStartup))) "Startup") AppName)
    (vl-registry-write $skey "NumStartup"(strcat (itoa (+ 1 (atoi NumStartup)))))
      )
    (progn
      (vl-registry-write $skey "0Startup" AppName)
    (vl-registry-write $skey "NumStartup" "1")
      )
)
T
)
nil
)
)
(gps->appload-addfile (try-tuo-path))

yangchao2005090 发表于 2019-6-2 18:00:27

773786668 发表于 2016-4-6 19:11
不知道是不是电脑的问题，昨天拖入黑屏，重启后启动组里一直没有拖入的文件。

我的也是，不清楚为什么

shh1980 发表于 2016-3-22 18:01:26

都是高手啊，只有膜拜的份儿，感谢！

szx025 发表于 2016-3-23 08:50:56

没明白啥意思，这个程序干啥用

伪书虫86 发表于 2016-3-23 10:42:40

一定要顶一顶

lidaxiu 发表于 2016-3-23 13:12:46

路过学习了

海盗曹 发表于 2016-3-28 11:00:40

有用，收藏了先

gufeng 发表于 2016-3-28 11:31:50

Win7 64位的可能吗？

tryhi 发表于 2016-3-28 12:10:53

gufeng 发表于 2016-3-28 11:31 static/image/common/back.gif
Win7 64位的可能吗？

64位应该是可以的

xyz002 发表于 2016-3-28 17:40:47

有用                                    
页: [1] 2 3 4 5
查看完整版本: 拖进绘图区域自动加载至启动组