CAD最小巧的多文档管理标签[源码]

yxpxa

用法，将以下代码复制到文本文件，另存为 *.lsp ，再将此文件设置为自动加载。

[pcode=lisp,true]
;;AutoCad多文档标签管理工具
;;用法将本程序添加到CAD启动组即可
(or dcl_getversionex
(progn
   (defun Load:OdclRuntime ( / acadversion arxname dclarxfile *error*)
     (defun *error* (msg)
       (princ (strcat "\n 多文档管理程序 加载失败，文件 " arxname " 缺失")))
      (setq acadversion (substr (getvar "acadver") 1 2))
      (setq arxname (strcat "OpenDCL." acadversion ".arx"))
      (if (setq dclarxfile (findfile arxname))
        (if (null (member arxname (arx)))(arxload dclarxfile))
        (exit))
   )(Load:OdclRuntime)
)
)
(vl-load-com)
(defun c:mdwglabel( / )
(mlabel-getalldocs)
;(dcl_project_load "mlabel.odcl" t)
(Dcl_Project_Import (mdwg_crect) nil nil)
(dcl_form_show mlabel_DocLabel)
(princ)
)

(defun c:MLabel_DocLabel_TabStrip_OnChanged (ItemIndex /)
(vla-Activate (car (nth ItemIndex (vl-bb-ref '*mDocObj*))))
(princ)
)
;;主界面初始化
(defun c:MLabel_DocLabel_OnInitialize( / Tabname)
  (mlabel_setwith)
  (setq Tabname (mapcar 'cadr (vl-bb-ref '*mDocObj*)))
  (dcl_Control_SetTabCaptionList MLabel_DocLabel_TabStrip Tabname)
  (dcl_TabStrip_SetCurSel MLabel_DocLabel_TabStrip (get-Tabindex))
  (princ)
)
;;返回文档名称
(defun mlabel-getalldocs (/ d)
(vlax-map-collection (vla-get-Documents (vlax-get-acad-object))
(function (lambda (x) (setq d (cons (list x (vl-filename-base (vla-get-name x))) d)))))
(vl-bb-set '*mDocObj* d)
)
(defun get-Tabindex()
(vl-position (vl-filename-base (vla-get-name (vla-get-ActiveDocument (vlax-get-acad-object))))
(mapcar 'cadr (vl-bb-ref '*mDocObj*)))
)
(defun c:MLabel_DocLabel_OnSize (NewWidth NewHeight /)(mlabel_setwith))
(defun mlabel_setwith( / w)
(setq w (vla-get-Width (vla-get-ActiveDocument (vlax-get-acad-object))))
(dcl_Control_SetWidth MLabel_DocLabel (+ w 80))
(dcl_Control_SetHeight MLabel_DocLabel 24)
(dcl_Control_SetPos MLabel_DocLabel_TabStrip 4 0 (+ w 70) 24)
)
(defun c:MLabel_DocLabel_OnEnteringNoDocState (/)(dcl_Form_Close MLabel_DocLabel)(princ))
(defun c:MLabel_DocLabel_OnDocActivated (/)(mlabel-getalldocs)(c:MLabel_DocLabel_OnInitialize)(princ))
(defun mdwg_crect()
'("YWt6A6InAADJgTWzBuKjJDXxaztqQAkY5pcfOD5gRM6+9/A2HKSKxYXEL3xYQAZGnLjz2uFy/B5y"
"3L866FBKH5fhjufeWFgQIpe4nqD7NW07I8eaBLApCxGhQGZnbErYkTOh1y3ZlCqLKZknzgMKDTqI"
"50E4OVfZ/BREOYX2loR8r5xySebHqP5rLzh3yRQMt930PDTHa6/uhXUQc8cjjtG1wuZ8YOcst00C"
"kDPWH3BoZfe6+luqBnSY9bri29pSrTaK55kMMb7C+CV/JEtaOKJgHHlXs6zsdmOOOMmMPVWacjbI"
"83HN4l0K/5nKUZki3Ae1YLYqmQz5IFOXD+R4nWoXd9mWeuPJw/mGxzYZlmwNUUzJXBmq7wkezYzg"
"nDlawrCssK0XRLDdsrbtohHaRUHUw8Gn34kRCNMZhkf9A5miCfhQ9ZJx6pKJa0NBlqwRC4ZV5SOF"
"mgbDEReZhuKS/0dRrmIzA+JVRiYCABjDD8DYUx0EKIahyspyCgjInUn64GOyC4YhyIJr30ERF9KJ"
"+5whLYL5RNTLG6E1kaibuLy4RRFFoQtGmmISGcw8ZFujuLrMimLGOzchejYMrgyC0YNTRk2aMjrg"
"FrsFPBHbkPUUHrAJ6CVAuDXTjM3/DUe5k12CBcR9Xn4GLLen3YaxyYphPGEQl+9ipiAL3pVTAfmu"
"hRcXMpHL3mRWKKd9Mi0/+XRFKqrfnHDrCtbKPRtjdKAXwCOjLcrRlj6v39xdO7n0MGrjVEQtCgkB"
"/6Qh3ohp1oN7FAH/pCG+hQ1w160EvtaVmgqA/fGN+qzGqyVKmiEB4uW05GAQywgrlp1Tg8qusVdJ"
"DyqvuWqD0twXrrsjRe05qgDY4rUxPCljMcLIZzHSY/CPs/mnXZr2QPYamViVHEOZ0twh45Idjtni"
"o3u7ATuvxRYPzLHvLQiddSKamsNhrVAMwKPDASWJ1p24ItUqnjHHsUM8sQnopIOep5HRIEcPjvOb"
"r6yb1VGt12EwUPGoF+Mf68pdGq3374pGJSo2IihfjS0bLuHX/YI684Emr2FXhD07gf2luQTlC4WE"
"3oo/lP2o9N5rm9VooWVMAFTSEmmA3RThyXVVkdeJICl4p2SSfkaC2IgNHfz954H1TM6hpYm9hiEX"
"3z3R14ctcJ92C2O8ZKN7+Q55cJ5EQfUNCqmNisVYtZJSvyKfWELQmo9LybKydq9UOHNeAi19+qKt"
"jla3iQ26ofo5cyrAQU1zuJ6kMll3YpKGwf1N/koHq+6FTLaMT635zQ3P+HG+DIB4Vvg0mHlW4lQA"
"ZBC7glOEeLBy2htCsB0A9Odz2qt+O9rbBgtpQvGZd0Zgyfmu5WR+G6KQY0bN7hgwQJnAalfj5uva"
"BOBL3364Wm60FNhRnIdvCtk+X+MM1RmesicXnB0U8tQfPHvaK+4ojFINkW4+xSKVBXrofP73N5iD"
"fRn1C7Y9ljtzc47eR2dytPv49hD2mCqOTVAEerR6oeYlbyiRZ0aN7liQJpDjLMIYcBdzFEBp2J29"
"qjosfZHtJolTL1L/p6vmoU0OaF4zfo++tW/ZInqMerBJzC+3+yjrjkBzgEhOVWHu2IKzhXjwfRdL"
"il06oveOhEea+W0OFFVTPNW4ZFsBVeYr/EYoiHPiOza1f/R5rbYfKJz6dXoLj0dzSjlytyKE9InX"
"b6595WRoJsUZnhL7St1td9zsfzncKXpn3Dc9tlbubfme6I40XE84MJOP0alJDugS4J29QvLl64/s"
"p4bIAma8XcdO2m7/QLw0nLodhmVxgcauxS7AEr9X74B5freaR3sgp4bidrgqvoo0Rpp+cKLNX0M7"
"vKbFLgDx8yhgAflWf2SyUn/2V2FsFRRnBmvGjMk/ZmG8tjwWLbG+p3gXf8pY/R8brvNy77X+7V9k"
"x7b8Q2Ym+2RCO4eXvdqMQOSrCEyp1nz1umJ3sH/aN8ObJYFMsA08qp6d0qc6z3jELb09i3LiY0jq"
"2Xa151NdojcEmVzNT2srf533ng1ksjZe0frZNAcYsb7HaaxUqppffAt4bWQ85MexN1nfAhajCxdb"
"edbXVC7M4eD/zQ0M4R0cMRz9C/Dlv6IUMBtNGsen957vFMpVIigq1rY1kJVnRsUSyjSfOXzyje+Y"
"+369+oymKJtP7EBpweyGhw6uZ/JUlyGHzmWs8rmPj7zLM4ZcGkStKwf4EjjyUPrIcrf+FNBM+ION"
"RwWSAzByfhx6mY+zD39T9x4qd+eBLi1+4mbDZ3JP/OF0fhKxvsexmEfs1+YBETZPzczvtf4dTOB8"
"KWSsdN47S7JX+Ml3L+mLcuKFE1ZJezpz41YT5CmuhsDG+qJiB/NXNX16iHRkHdROwQEYyxxLWXpK"
"XxpaBoNifsZ2rE+aGHaUe/O1LGEg1H/aS4gMmZ62mVHf+f0f"))
(if (<= (length (vl-bb-ref '*mDocObj*)) 25) (c:mdwglabel)(princ "\n文件打开数量过多."))
(dcl_SetCmdBarFocus)
(princ)[/pcode]



不想复制的在这里下载

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:Mdwglabel.lsp 
下载次数:124  文件大小:4.68 KB 
下载权限: 不限 以上  [免费赚D豆]

yxpxa

用法： 添加到启动组即可。
如果加入文档反应器，使 dwg 在新建、打开、更名、窗口切换时，刷新一下 listbox 就更好了。
哪位老大教教文档反应器的用法。

三楼手快呀，我正在粘帖，国外网速慢地很。
bug就是缩略图的生成有问题，无法调用 command 函数
不过这就影响缩略图无法查看，文档切换是没问题的。
lisp里有记录
;;*********************************************************
;;这里试图生成当前CAD文件的缩略图，但是代码调试通不过
;;event invoke 设置为1仍然出现以下错误，估计还是异步处理的问题
;;错误: invalid AutoCAD command: nil
;(command "mslide" ss1)
;;*********************************************************

缩略图用幻灯片奢侈了点，因为生成的 *.sld 文件好大，需要点点时间，估计是后面的代码等不及，干脆报错。
还有什么办法能生成当前视口的快照？

XDSoft

代码有什么BUG尼，和大家说下，让大家能有的放矢。

Lispboy

yxpxa 发表于 2013-5-7 18:26

                               
登录/注册后可看大图

用法： 添加到启动组即可。
如果加入文档反应器，使 dwg 在新建、打开、更名、窗口切换时，刷新一下 listb ...

切换多文档窗口时，提示错误？

Lispboy

yxpxa 发表于 2013-5-7 18:26

                               
登录/注册后可看大图

用法： 添加到启动组即可。
如果加入文档反应器，使 dwg 在新建、打开、更名、窗口切换时，刷新一下 listb ...

哦，要加到启动组，测试下贴图。

yxpxa

Lispboy 发表于 2013-5-7 19:43

                               
登录/注册后可看大图

切换多文档窗口时，提示错误？

没加载 arx 文件吧
在前面加入以下代码，可自动加载 opendDCL.arx
(or dcl_getversionex
  (progn
      (defun Load:Runtime ( / acadversion arxname dclarxfile)
           (defun *error* (msg)
                (princ (strcat "\n 加载失败，找不到" arxname "文件,请确认该文件是否在搜索路径"))
           )
           (setq acadversion (substr (getvar "acadver") 1 2))
           (setq arxname (strcat "OpenDCL." acadversion ".arx"))
           (setq dclarxfile (findfile arxname))
            
           (if (and (= (member arxname (arx) ) nil) (/= dclarxfile nil))
           (arxload dclarxfile) (exit))
      )            
      (Load:Runtime)
   ) ;;end progn
)

Lispboy

加到启动组好了，但是也没见到命令行上有错误提示啊，当然预览图也没有。

Lispboy

yxpxa 发表于 2013-5-7 19:47

                               
登录/注册后可看大图

没加载 arx 文件吧
在前面加入以下代码，可自动加载 opendDCL.arx
(or dcl_getversionex

找到你问题在哪了。

在ControlBar和Modeless框是不能执行command的，但是你可以通过发送字符串命令去执行命令。代码给你修改下，你试试做下，幻灯片是生成了，但好像还有其他的问题，你在看看，有事要出去，先发帖上来，回来期望看到好结果哈。



[pcode=lisp,true]
;;*********************************************************
;;这里试图生成当前CAD文件的缩略图，但是代码调试通不过
;;event invoke 设置为1仍然出现以下错误，估计还是异步处理的问题
;;错误: invalid AutoCAD command: nil
(setq strcmd "(command \"mslide\" ss1)")
(dcl_SendString strcmd)   ;;在 ContrlBar 和 Medeless 要发送字符串命令去命令行执行ACAD命令。
[/pcode]

Lispboy

yxpxa 发表于 2013-5-7 19:47

                               
登录/注册后可看大图

没加载 arx 文件吧
在前面加入以下代码，可自动加载 opendDCL.arx
(or dcl_getversionex

走前再贴下

你的 (command "mslide" ss1) 这个地方应该不对，缺参数。

yxpxa

Lispboy 发表于 2013-5-7 20:08

                               
登录/注册后可看大图

走前再贴下

你的 (command "mslide" ss1) 这个地方应该不对，缺参数。

(command "mslide" ss1)  在命令行里运行是没问题的。
ss1 就是一个跟时间相关的文件名，避免重复的作用。

你试着在命令行里输入 (command "mslide" ss1) 就可以正确无误的生成幻灯片。
说明 dcl_SendString 函数还是有点问题啊。

XDSoft

yxpxa 发表于 2013-5-8 01:57

                               
登录/注册后可看大图

(command "mslide" ss1)  在命令行里运行是没问题的。
ss1 就是一个跟时间相关的文件名，避免重复的作 ...

弹出啥对话框？截图贴上来下吧。Lispboy朋友分析的对，必须用dcl_sendstring 在停靠窗口，非模式框下执行acad命令。

XDSoft

yxpxa 发表于 2013-5-8 01:57

                               
登录/注册后可看大图

(command "mslide" ss1)  在命令行里运行是没问题的。
ss1 就是一个跟时间相关的文件名，避免重复的作 ...

我觉得吧，你多窗口转换的时候，应该响应下

[pcode=lisp,true]
(defun c:muldwg_Form1_OnDocActivated (/)
  (dcl_MessageBox "To Do: code must be added to event handler\r\nc:muldwg_Form1_OnDocActivated" "To do")
)
[/pcode]

因为你转换窗口后，虽然你的代码里面响应了OnInitalize 事件，但程序并没有重新运行，执行不了初始化代码，你的停靠窗口并没有接受到信息去处理你的代码，必须响应OnDocActivated。
试试修改下。

1. 
   
2. OnDocActivated
   
3. 
   
4. This event is triggered when the user switches to a different open AutoCAD drawing. Note that opening a new drawing will not trigger any event. An application that uses modeless dialogs must be installed so that its code is loaded into each newly created drawing document, and the application's initialization code must check for already active dialogs that it must manage.
   

复制代码

Lispboy

yxpxa 发表于 2013-5-7 18:26

                               
登录/注册后可看大图

用法： 添加到启动组即可。
如果加入文档反应器，使 dwg 在新建、打开、更名、窗口切换时，刷新一下 listb ...

为什么不试试 DWG Preview 控件直接显示图形的缩略图。

yxpxa

Lispboy 发表于 2013-5-8 08:23

                               
登录/注册后可看大图

为什么不试试 DWG Preview 控件直接显示图形的缩略图。

感谢！听君一席话胜读十年书啊，我ODCL刚学，控件都不熟
修正 bug 的源码 新版在上面

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:Mdwg.rar 
下载次数:74  文件大小:1.85 KB 
下载权限: 不限 以上  [免费赚D豆]

小小毛毛虫

支持一下楼主的东西，见你发过在别处