源码图库管理小程序 2013年5月25日第3更

yxpxa · 发表于 2013-5-23 21:00:28

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 yxpxa 于 2013-5-25 05:20 编辑

;; 图库管理程序
;; 来自小东空间，转载请注明出处
;; by 小蜜蜂 QQ:9034598 2013-5-25
(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)) ;;如果没有 opendcl.arx ，后面的主程序将不加载。
)(Load:OdclRuntime)
)
)
(vl-load-com)
;;图库管理程序
;;全局变量:
;; dxss-ssrCtrol 为 dwgPreview 和 text 控件的名称列表
;; dxss-objCtrol 为 dwgPreview 和 text 控件的对象列表
;; dxss-sumPage 总页面数
;; dxss-curpage 当前页面数，起始数为 0
;; dxss-picture 当前所选图像框，起始数为 0
;;
(defun c:dxss( / n)
;;建立16个图像控件名称列表 dxss-ssrCtrol
(setq n 0 dxss-ssrCtrol '())
(repeat 16
(setq n (1+ n) dxss-ssrCtrol
(cons (list (strcat "dxss_mainWin_DwgPreview" (itoa n))
(strcat "dxss_mainWin_TextBox" (itoa n))) dxss-ssrCtrol))
)(setq dxss-ssrCtrol(reverse dxss-ssrCtrol))
;;控件属性字符定义
(setq dxss-KjvaLue '(("dxss_mainWin_ComboBox2" " \"Text\"")
("dxss_mainWin_TextBox17" " \"Text\"")
("dxss_mainWin_TextBox18" " \"Text\"")
("dxss_mainWin_TextBox19" " \"Text\"")
("dxss_mainWin_TextBox20" " \"Text\"")
("dxss_mainWin_CheckBox1" " \"Value\"")
("dxss_mainWin_CheckBox2" " \"Value\"")
("dxss_mainWin_CheckBox3" " \"Value\""))
dxss-Option "程*序#设%置")
;;建立搜索图库全路径
(or dxss-path (setq dxss-path (findfile "e:\\tk")))
(dxss_tkini)
(dcl_project_load "dxss.odcl" t)
(dcl_form_show dxss_mainWin)
(princ)
)
;;图库初始化
(defun dxss_tkini()
;;建立搜索图库全路径
(setq dxss-FullName (mapcar '(lambda(x)(findfile (strcat dxss-path "\\" x)))
(vl-directory-files dxss-path "*.dwg" 1)))
;;计算当前页面及总页面
(setq dxss-curpage 0 dxss-picture 0 n (length dxss-FullName)
dxss-sumpage (+ (fix (/ n 16))(if (> (rem n 16) 0) 1 0)))
(dxss_loadDescrib)
)
;;主窗口初始化
(defun c:dxss_mainWin_OnInitialize (/)
;;给名称列表赋予对象句柄
(setq dxss-objCtrol (mapcar '(lambda(x) (mapcar '(lambda(y)
(eval (read y))) x)) dxss-ssrCtrol))
;;填充列表盒
(mapcar '(lambda(x)(dcl_ListBox_AddList dxss_mainWin_ListBox1
(vl-filename-base x))) dxss-FullName)
(dxss_updataPic 0) ;;显示首页
(dcl_Control_SetText dxss_mainWin_ComboBox1 (getvar "CLAYER")) ;;层
(dcl_Control_SetText dxss_mainWin_TextBox21 (dxss-trim dxss-path 19))
(if dxss-txtc (c:dxss_mainWin_CheckBox1_OnClicked ;;XY输入框是否有效
(nth 5 (cadr (assoc dxss-Option dxss-txtc)))))
(dxss_objProfun) ;;装载图像单击事件
(dxss_setcurval) ;;控件赋值
(dxss_objSjfun) ;;图像双击事件
)
;;刷新当前页面的 dxss-objCtrol 控件列表
(defun dxss_updataPic( mm / n Wss Nss tem ssc m nn)
(setq n 0 Wss '() Nss '())
(setq m (if (< mm (1- dxss-sumpage)) 16 (rem (length dxss-FullName) 16))) ;;当前图像数
(while (< n m)
(setq nn (+ (* mm 16) n)
tem (nth nn dxss-FullName)
Wss (cons (list (car (nth n dxss-objCtrol)) tem) Wss)
Nss (cons (list (cadr (nth n dxss-objCtrol)) (vl-filename-base tem)) Nss)
n (+ n 1)))
;;清除所有图像及文本框
(mapcar '(lambda(x)(dcl_DWGPreview_Clear (car x))) dxss-objCtrol)
(mapcar '(lambda(x)(dcl_Control_SetBackColor (car x) -22)) dxss-objCtrol)
(mapcar '(lambda(x)(dcl_Control_SetText (cadr x) "")) dxss-objCtrol)
;;赋值
(mapcar '(lambda(x)(apply 'dcl_DWGPreview_LoadDwg x)) Wss)
(mapcar '(lambda(x)(apply 'dcl_Control_SetText x)) Nss)
(dcl_Control_SetCaption dxss_mainWin_Label3
(strcat "当前第 " (itoa (+ dxss-curpage 1)) " 页共 " (itoa dxss-sumpage) " 页"))
)
;;建立16个图像框的单击事件
(defun dxss_objProfun()
(foreach x (mapcar 'car dxss-ssrCtrol) (eval (read
(strcat "(defun c:" x "_OnClicked(/ m)"
"(setq m (+ (* dxss-curpage 16) (vl-position \"" x "\" (mapcar 'car dxss-ssrCtrol))))"
"(if (< m (length dxss-FullName))(progn "
"(setq dxss-picture m dxss-curpage (fix (/ m 16)))(dxss_updataPic dxss-curpage)"
"(dcl_Control_SetBackColor " x " 1)" ;;1 代表选中后的背景是红色
"(dcl_DWGPreview_LoadDwg " x " (nth dxss-picture dxss-FullName))"
"(dcl_ListBox_SetCurSel dxss_mainWin_ListBox1 dxss-picture)(dxss_loaditem))))")
)))
)
;;建立16个图像框的双击事件
(defun dxss_objSjfun()
(foreach x (mapcar 'car dxss-ssrCtrol) (eval (read
(strcat "(defun c:" x "_OnDblClicked(/)(dxss-savedata)"
"(setq s (car (cadr (assoc dxss-Option dxss-txtc))))"
"(cond ((= s \"插入\")(c:dxss_mainWin_TextButton6_OnClicked))"
"((= s \"预览\")(c:dxss_Form1_TextButton4_OnClicked))"
"((= s \"属性\")(dcl_Form_Show dxss_Attrib))(t nil)))")
)))
)
;;创建所有控件的取值函数
(defun dxss_getcurval( / ss)
(setq ss "dcl_Control_GetProperty")
(mapcar '(lambda(x) (eval (read (strcat "(" ss " " (car x) (cadr x) ")")))) dxss-KjvaLue)
)
;;创建所有控件的赋值函数
(defun dxss_setcurval( / x s ss sL)
(setq ss "dcl_Control_SetProperty" sL (cadr (assoc dxss-Option dxss-txtc)) n 0)
(repeat (length sL)
(setq x (nth n dxss-KjvaLue)
s (if (< n 5) (strcat "\"" (nth n sL) "\"")(itoa (nth n sL))))
(eval (read (strcat "(" ss " " (car x) (cadr x) " " s ")")))
(setq n (1+ n))
)
)
;;单击列表盒事件
(defun c:dxss_mainWin_ListBox1_OnSelChanged (ItemIndexOrCount Value / mm)
(setq dxss-picture ItemIndexOrCount)
(setq mm (fix (/ dxss-picture 16))) ;;计算当前页面
(if (/= mm dxss-curpage)(setq dxss-curpage mm))
(eval (read (strcat "(c:" (car (nth (- dxss-picture (* mm 16)) dxss-ssrCtrol)) "_OnClicked)")))
)
;;预览
(defun c:dxss_Form1_TextButton4_OnClicked (/)
(setq ss (nth dxss-picture dxss-FullName)
dd (strcat (vl-filename-directory ss) "\\" (vl-filename-base ss) ".sld"))
(setq dxss-xx (if (findfile dd) dd ss))
(if (findfile dd) (dcl_Form_Show dxss_PreViewSld)(dcl_Form_Show dxss_PreViewDwg))
)
(defun c:dxss_PreViewDwg_OnInitialize (/)
(dcl_DWGPreview_LoadDwg dxss_PreViewDwg_DwgPreview1 dxss-xx)
(setq dxss-xx nil)
)
(defun c:dxss_PreViewSld_OnInitialize (/)
(dcl_SlideView_Load dxss_PreViewSld_SlideView1 dxss-xx)
(setq dxss-xx nil)
)
;;上一页
(defun c:dxss_mainWin_TextButton1_OnClicked (/)
(if (> dxss-curpage 0)(setq dxss-curpage (1- dxss-curpage)))
(setq dxss-picture (* dxss-curpage 16))
(dxss_updataPic dxss-curpage)
)
;;下一页
(defun c:dxss_mainWin_TextButton2_OnClicked (/)
(if (< dxss-curpage (- dxss-sumpage 1))(setq dxss-curpage (1+ dxss-curpage)))
(setq dxss-picture (* dxss-curpage 16))
(dxss_updataPic dxss-curpage)
)
;;块插入需要优化
(defun c:dxss_mainWin_TextButton6_OnClicked (/ *error* a x1 x2 x3 x4 x5 x6 x7 s1 s2 s3)
; qname name xex mouse pt ent nK xxx
(defun *error* (msg)
(setvar "cmdecho" a)
(princ "ESC 退出")
(princ)
)
(setq a (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq xxx (dcl_Control_GetText dxss_mainWin_ComboBox1)) ;;图层
(dxss-savedata) ;;保存数据
(setq qname (nth dxss-picture dxss-FullName)
name (vl-filename-base qname)
xex (cadr (assoc dxss-Option dxss-txtc))
x1 (atof (nth 1 xex)) ;;X比例
x2 (atof (nth 2 xex)) ;;Y比例
x3 (/ (* (atof (nth 3 xex)) pi) 180) ;;旋转角度
x4 (atof (nth 4 xex)) ;;整体比例
x5 (nth 5 xex) ;;锁定比例
x6 (nth 6 xex) ;;多块插入
x7 (nth 7 xex)) ;;是否分解
(if (<= x1 0) (setq x1 1))
(if (<= x2 0) (setq x2 1))
(if (<= x4 0) (setq x4 1))
(if (= x5 1) (setq s1 x4 s2 x4 s3 x4)(setq s1 x1 s2 x2 s3 1))
(dcl_form_close dxss_mainWin)
;;第一步，导入块到文件后删除
(if (null (tblsearch "block" name))(progn
(command "-insert" qname "0,0" "" "" "")(entdel(entlast))))
;;生成第一个块的dxf
(setq firstB (list '(0 . "INSERT") (cons 8 xxx) (cons 2 name) (cons 10 '(0 0 0))
(cons 41 s1)(cons 42 s2)(cons 43 s3)(cons 50 x3)))
;;
(setq n 0)
(while (progn
(entmakex firstB) (setq CnTnNew t) ;;这个ent不保存
(princ "\n请指定插入点或按任意键取消: ")
(while (and (or (= (car (setq mouse (grread t 13 1))) 5)(= (car mouse) 12)(= (car mouse) 2)) CnTnNew)
(setq KK (car mouse))
(if (= KK 2)(setq CnTnNew nil))
(if (or (= KK 3)(= KK 5)) (progn ;;3为正常的鼠标左键，5为移动点
(setq pt (cadr mouse)
ent (entget(entlast))
Nk (subst (cons 10 pt)(assoc 10 ent) ent))
(entmod nk)
))
)
(if (= x7 1) (while (= (cdr (assoc 0 (entget (entlast)))) "INSERT")
(command ".explode" (entlast)))) ;;无论加了多少层图块，一次性分解！
(if (= x6 1) (princ (setq n (1+ n))))
(and CnTnNew (= x6 1)))
)
(if (= x6 1) (progn(entdel(entlast))
(princ (strcat "\r温馨提示: 您按下了键盘，程序退出 ")))
)
(setvar "cmdecho" a)
(princ)
)
;;保存数据
(defun dxss-savedata (/ data)
(setq data (list dxss-Option (dxss_getcurval)))
(if (assoc dxss-Option dxss-txtc)
(setq dxss-txtc (subst data (assoc dxss-Option dxss-txtc) dxss-txtc))
(setq dxss-txtc (cons data dxss-txtc)))
(write_read "w" (strcat dxss-path "\\description.txt") dxss-txtc)
)
;;显示图块属性
(defun c:dxss_mainWin_TextButton5_OnClicked (/)(dcl_Form_Show dxss_Attrib))
;;属性窗口初始化
(defun c:dxss_Attrib_OnInitialize (/ ss dd ssL ssr fn f ssc)
(setq ss (nth dxss-picture dxss-FullName)
dd (strcat (vl-filename-directory ss) "\\" (vl-filename-base ss) ".sld")
ssL (vl-file-systime ss))
(setq ssr (strcat "文件路径: " ss "\n\n创建日期: "
(itoa (car ssL)) " 年 " (itoa (cadr ssL)) " 月 " (itoa (nth 3 ssL)) " 日"
"\n\n文件大小: " (itoa (vl-file-size ss)) " 字节"
"\n\n幻灯片: " (if (setq hd (findfile dd)) dd "无")
(if hd (strcat "\n\n幻灯片大小: " (itoa (vl-file-size hd)) " 字节") "")
))
(dxss_loadDescrib)
(setq ssc (cadr (assoc (vl-filename-base ss) dxss-txtc)))
(setq ssc (if ssc (strsub "\r\n" "^$~" ssc) ""))
(dcl_Control_SetText dxss_Attrib_TextBox1 ssc)
(dcl_Control_SetCaption dxss_Attrib_Label1 ssr)
)
;;加载说明文件
(defun dxss_loadDescrib( / p)
(setq p (strcat dxss-path "\\description.txt")
dxss-txtc (write_read "r" p nil))
)
;;保存说明文件
(defun dxss_saveDescrib( / ss tem fn f)
(setq yy (dcl_Control_GetText dxss_Attrib_TextBox1))
(if (/= yy "")(progn
(setq ss (vl-filename-base (nth dxss-picture dxss-FullName))
xx (strsub "^$~" "\r\n" yy))
(if (assoc ss dxss-txtc)
(setq dxss-txtc (subst (list ss xx) (assoc ss dxss-txtc) dxss-txtc))
(setq dxss-txtc (cons (list ss xx) dxss-txtc)))
(write_read "w" (strcat dxss-path "\\description.txt") dxss-txtc)
))(dxss_loaditem)
)
;;选择文件路径
(defun c:dxss_mainWin_TextButton8_OnClicked (/)
(setq pss (dcl_SelectFolder "选择图库加载路径..." dxss-path))
(if pss (progn
(setq dxss-path pss) (dxss_tkini)
(dcl_ListBox_Clear dxss_mainWin_ListBox1)
(c:dxss_mainWin_OnInitialize)
))
)
;;关闭属性窗口
(defun c:dxss_Attrib_TextButton1_OnClicked (/)
(dxss_saveDescrib)(dcl_form_close dxss_Attrib)
)
;;读写文件
(defun write_read(Key Fpath Data / f k Lss ss ncn)
(setq k (strcase Key)) ;;将关键字统一转换为大写
(cond
((= k "W")(if (and Fpath Data (= (type Fpath) 'STR))
(progn
(setq Lss (vl-prin1-to-string Data))
(setq f (open Fpath "w"))
(princ Lss f)
(close f)
t)))
((= k "R")(if (and Fpath (= (type Fpath) 'STR) (findfile Fpath))
(progn
(setq f (open Fpath "r")
ss (read-line f)
Lss (read ss))
(close f)
Lss)
Data))
(t nil))
)
;;长路径截短以适应 text 显示，doslib有这个函数
(defun dxss-trim(ss n / k L)
(setq L (strlen ss))
(if (> L n)(progn
(setq k (fix (/ (- n 3) 2)))
(strcat (substr ss 1 (+ k 3)) "..." (substr ss (- L k -3))) ;;非偶数截取可能会乱码
) ss)
)
(princ)

;; 图库管理程序 
;; 来自小东空间，转载请注明出处 
;; by 小蜜蜂    QQ:9034598   2013-5-25 
(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))  ;;如果没有 opendcl.arx ，后面的主程序将不加载。 
   )(Load:OdclRuntime) 
) 
) 
(vl-load-com) 
;;图库管理程序 
;;全局变量: 
;;  dxss-ssrCtrol 为 dwgPreview 和 text 控件的名称列表 
;;  dxss-objCtrol 为 dwgPreview 和 text 控件的对象列表 
;;  dxss-sumPage 总页面数 
;;  dxss-curpage 当前页面数，起始数为 0 
;;  dxss-picture 当前所选图像框，起始数为 0 
;; 
(defun c:dxss( / n) 
;;建立16个图像控件名称列表  dxss-ssrCtrol 
(setq n 0 dxss-ssrCtrol '()) 
(repeat 16 
  (setq n (1+ n) dxss-ssrCtrol 
     (cons (list (strcat "dxss_mainWin_DwgPreview" (itoa n)) 
                 (strcat "dxss_mainWin_TextBox" (itoa n))) dxss-ssrCtrol)) 
)(setq dxss-ssrCtrol(reverse dxss-ssrCtrol)) 
;;控件属性字符定义 
(setq dxss-KjvaLue '(("dxss_mainWin_ComboBox2" " \"Text\"") 
                  ("dxss_mainWin_TextBox17" " \"Text\"") 
                  ("dxss_mainWin_TextBox18" " \"Text\"") 
                  ("dxss_mainWin_TextBox19" " \"Text\"") 
                  ("dxss_mainWin_TextBox20" " \"Text\"") 
                  ("dxss_mainWin_CheckBox1" " \"Value\"") 
                  ("dxss_mainWin_CheckBox2" " \"Value\"") 
                  ("dxss_mainWin_CheckBox3" " \"Value\"")) 
      dxss-Option "程*序#设%置") 
;;建立搜索图库全路径 
(or dxss-path (setq dxss-path (findfile "e:\\tk"))) 
(dxss_tkini) 
(dcl_project_load "dxss.odcl" t) 
(dcl_form_show dxss_mainWin) 
(princ) 
) 
;;图库初始化 
(defun dxss_tkini() 
;;建立搜索图库全路径 
(setq dxss-FullName (mapcar '(lambda(x)(findfile (strcat dxss-path "\\" x))) 
                 (vl-directory-files dxss-path "*.dwg" 1))) 
                  
;;计算当前页面及总页面 
(setq dxss-curpage 0 dxss-picture 0 n (length dxss-FullName) 
      dxss-sumpage (+ (fix (/ n 16))(if (> (rem n 16) 0) 1 0))) 
(dxss_loadDescrib) 
) 
 
;;主窗口初始化 
(defun c:dxss_mainWin_OnInitialize (/) 
;;给名称列表赋予对象句柄 
(setq dxss-objCtrol (mapcar '(lambda(x) (mapcar '(lambda(y) 
                     (eval (read y))) x)) dxss-ssrCtrol)) 
                      
;;填充列表盒 
(mapcar '(lambda(x)(dcl_ListBox_AddList dxss_mainWin_ListBox1 
          (vl-filename-base x))) dxss-FullName) 
(dxss_updataPic 0) ;;显示首页 
(dcl_Control_SetText dxss_mainWin_ComboBox1 (getvar "CLAYER")) ;;层 
(dcl_Control_SetText dxss_mainWin_TextBox21 (dxss-trim dxss-path 19)) 
(if dxss-txtc (c:dxss_mainWin_CheckBox1_OnClicked  ;;XY输入框是否有效 
               (nth 5 (cadr (assoc dxss-Option dxss-txtc))))) 
(dxss_objProfun) ;;装载图像单击事件 
(dxss_setcurval) ;;控件赋值 
(dxss_objSjfun)  ;;图像双击事件 
) 
 
;;刷新当前页面的 dxss-objCtrol 控件列表 
(defun dxss_updataPic( mm / n Wss Nss tem ssc m nn) 
(setq n 0 Wss '() Nss '()) 
(setq m (if (< mm (1- dxss-sumpage)) 16 (rem (length dxss-FullName) 16))) ;;当前图像数 
(while (< n m) 
    (setq nn (+ (* mm 16) n) 
          tem (nth nn dxss-FullName) 
          Wss (cons (list (car (nth n dxss-objCtrol)) tem) Wss) 
          Nss (cons (list (cadr (nth n dxss-objCtrol)) (vl-filename-base tem)) Nss) 
          n (+ n 1))) 
  ;;清除所有图像及文本框 
  (mapcar '(lambda(x)(dcl_DWGPreview_Clear (car x))) dxss-objCtrol) 
  (mapcar '(lambda(x)(dcl_Control_SetBackColor (car x) -22)) dxss-objCtrol) 
  (mapcar '(lambda(x)(dcl_Control_SetText (cadr x) "")) dxss-objCtrol) 
  ;;赋值 
  (mapcar '(lambda(x)(apply 'dcl_DWGPreview_LoadDwg x)) Wss) 
  (mapcar '(lambda(x)(apply 'dcl_Control_SetText x)) Nss) 
   
  (dcl_Control_SetCaption dxss_mainWin_Label3 
     (strcat "当前第  " (itoa (+ dxss-curpage 1))  "  页   共  " (itoa dxss-sumpage) "  页")) 
) 
 
;;建立16个图像框的单击事件 
(defun dxss_objProfun() 
(foreach x (mapcar 'car dxss-ssrCtrol) (eval (read 
   (strcat "(defun c:" x "_OnClicked(/ m)" 
        "(setq m (+ (* dxss-curpage 16) (vl-position \"" x "\" (mapcar 'car dxss-ssrCtrol))))" 
        "(if (< m (length dxss-FullName))(progn " 
        "(setq dxss-picture m dxss-curpage (fix (/ m 16)))(dxss_updataPic dxss-curpage)" 
        "(dcl_Control_SetBackColor " x " 1)"    ;;1 代表选中后的背景是红色 
        "(dcl_DWGPreview_LoadDwg " x " (nth dxss-picture dxss-FullName))" 
        "(dcl_ListBox_SetCurSel dxss_mainWin_ListBox1 dxss-picture)(dxss_loaditem))))") 
))) 
) 
;;建立16个图像框的双击事件 
(defun dxss_objSjfun() 
(foreach x (mapcar 'car dxss-ssrCtrol) (eval (read 
   (strcat "(defun c:" x "_OnDblClicked(/)(dxss-savedata)" 
           "(setq s (car (cadr (assoc dxss-Option dxss-txtc))))" 
           "(cond ((= s \"插入\")(c:dxss_mainWin_TextButton6_OnClicked))" 
           "((= s \"预览\")(c:dxss_Form1_TextButton4_OnClicked))" 
           "((= s \"属性\")(dcl_Form_Show dxss_Attrib))(t nil)))") 
))) 
) 
;;创建所有控件的取值函数 
(defun dxss_getcurval( / ss) 
(setq ss "dcl_Control_GetProperty") 
(mapcar '(lambda(x) (eval (read (strcat "(" ss " " (car x) (cadr x) ")")))) dxss-KjvaLue) 
) 
;;创建所有控件的赋值函数 
(defun dxss_setcurval( / x s ss sL) 
(setq ss "dcl_Control_SetProperty" sL (cadr (assoc dxss-Option dxss-txtc)) n 0) 
(repeat (length sL) 
   (setq x (nth n dxss-KjvaLue) 
         s (if (< n 5) (strcat "\"" (nth n sL) "\"")(itoa (nth n sL)))) 
   (eval (read (strcat "(" ss " " (car x) (cadr x) " " s ")"))) 
   (setq n (1+ n)) 
) 
) 
;;单击列表盒事件 
(defun c:dxss_mainWin_ListBox1_OnSelChanged (ItemIndexOrCount Value / mm) 
(setq dxss-picture ItemIndexOrCount) 
(setq mm (fix (/ dxss-picture 16))) ;;计算当前页面 
(if (/= mm dxss-curpage)(setq dxss-curpage mm)) 
(eval (read (strcat "(c:" (car (nth (- dxss-picture (* mm 16)) dxss-ssrCtrol)) "_OnClicked)"))) 
) 
;;预览 
(defun c:dxss_Form1_TextButton4_OnClicked (/) 
(setq ss (nth dxss-picture dxss-FullName) 
       dd (strcat (vl-filename-directory ss) "\\" (vl-filename-base ss) ".sld")) 
(setq dxss-xx  (if (findfile dd) dd ss)) 
(if (findfile dd) (dcl_Form_Show dxss_PreViewSld)(dcl_Form_Show dxss_PreViewDwg)) 
) 
(defun c:dxss_PreViewDwg_OnInitialize (/) 
(dcl_DWGPreview_LoadDwg dxss_PreViewDwg_DwgPreview1 dxss-xx) 
(setq dxss-xx nil) 
) 
(defun c:dxss_PreViewSld_OnInitialize (/) 
(dcl_SlideView_Load dxss_PreViewSld_SlideView1 dxss-xx) 
(setq dxss-xx nil) 
) 
 
;;上一页 
(defun c:dxss_mainWin_TextButton1_OnClicked (/) 
  (if (> dxss-curpage 0)(setq dxss-curpage (1- dxss-curpage))) 
  (setq dxss-picture (* dxss-curpage 16)) 
  (dxss_updataPic dxss-curpage) 
) 
;;下一页 
(defun c:dxss_mainWin_TextButton2_OnClicked (/) 
  (if (< dxss-curpage (- dxss-sumpage 1))(setq dxss-curpage (1+ dxss-curpage))) 
  (setq dxss-picture (* dxss-curpage 16)) 
  (dxss_updataPic dxss-curpage) 
) 
;;块插入 需要优化 
(defun c:dxss_mainWin_TextButton6_OnClicked (/ *error* a x1 x2 x3 x4 x5 x6 x7 s1 s2 s3) 
                              ;  qname name xex mouse pt ent nK xxx 
(defun *error* (msg) 
  (setvar "cmdecho" a) 
  (princ "ESC 退出") 
  (princ) 
  ) 
(setq a (getvar "cmdecho")) 
(setvar "cmdecho" 0) 
(setq xxx (dcl_Control_GetText dxss_mainWin_ComboBox1))  ;;图层 
(dxss-savedata) ;;保存数据 
(setq qname (nth dxss-picture dxss-FullName) 
      name (vl-filename-base qname) 
     xex (cadr (assoc dxss-Option dxss-txtc)) 
      x1 (atof (nth 1 xex))  ;;X比例 
      x2 (atof (nth 2 xex))  ;;Y比例 
      x3 (/ (* (atof (nth 3 xex)) pi) 180)  ;;旋转角度 
      x4 (atof (nth 4 xex))  ;;整体比例 
      x5 (nth 5 xex)  ;;锁定比例 
      x6 (nth 6 xex)  ;;多块插入 
      x7 (nth 7 xex))  ;;是否分解 
(if (<= x1 0) (setq x1 1)) 
(if (<= x2 0) (setq x2 1)) 
(if (<= x4 0) (setq x4 1)) 
(if (= x5 1) (setq s1 x4 s2 x4 s3 x4)(setq s1 x1 s2 x2 s3 1)) 
(dcl_form_close dxss_mainWin) 
;;第一步，导入块到文件后删除 
(if (null (tblsearch "block" name))(progn 
     (command "-insert" qname "0,0" "" "" "")(entdel(entlast)))) 
;;生成第一个块的dxf 
(setq firstB (list '(0 . "INSERT") (cons 8 xxx) (cons 2 name) (cons 10 '(0 0 0)) 
                    (cons 41 s1)(cons 42 s2)(cons 43 s3)(cons 50 x3))) 
;; 
(setq n 0) 
(while (progn 
(entmakex firstB) (setq CnTnNew t)   ;;这个ent不保存 
(princ "\n请指定插入点 或 按任意键取消: ") 
(while (and (or (= (car (setq mouse (grread t 13 1))) 5)(= (car mouse) 12)(= (car mouse) 2)) CnTnNew) 
  (setq KK (car mouse)) 
  (if (= KK 2)(setq CnTnNew nil)) 
  (if (or (= KK 3)(= KK 5)) (progn  ;;3为正常的鼠标左键，5为移动点 
    (setq pt (cadr mouse) 
         ent (entget(entlast)) 
          Nk (subst (cons 10 pt)(assoc 10 ent) ent)) 
    (entmod nk) 
   )) 
) 
(if (= x7 1) (while (= (cdr (assoc 0 (entget (entlast)))) "INSERT") 
                           (command ".explode" (entlast))))  ;;无论加了多少层图块，一次性分解！ 
 
  (if (= x6 1) (princ (setq n (1+ n)))) 
  (and CnTnNew (= x6 1))) 
) 
(if (= x6 1) (progn(entdel(entlast)) 
    (princ (strcat "\r温馨提示: 您按下了键盘，程序退出  "))) 
) 
(setvar "cmdecho" a) 
(princ) 
) 
 
;;保存数据 
(defun dxss-savedata (/ data) 
  (setq data (list dxss-Option (dxss_getcurval))) 
  (if (assoc dxss-Option dxss-txtc) 
     (setq dxss-txtc (subst data (assoc dxss-Option dxss-txtc) dxss-txtc)) 
     (setq dxss-txtc (cons data  dxss-txtc))) 
  (write_read "w" (strcat dxss-path "<a href=\"http://bbs.xdcad.net/file://description.txt/\" target=\"_blank\">\\description.txt</a>") dxss-txtc) 
) 
 
;;显示图块属性 
(defun c:dxss_mainWin_TextButton5_OnClicked (/)(dcl_Form_Show dxss_Attrib)) 
 
;;属性窗口初始化 
(defun c:dxss_Attrib_OnInitialize (/ ss dd ssL ssr fn f ssc) 
(setq ss  (nth dxss-picture dxss-FullName) 
      dd (strcat (vl-filename-directory ss) "\\" (vl-filename-base ss) ".sld") 
      ssL (vl-file-systime ss)) 
(setq ssr (strcat "文件路径:  " ss "\n\n创建日期:  " 
           (itoa (car ssL)) " 年 " (itoa (cadr ssL)) " 月 " (itoa (nth 3 ssL)) " 日" 
           "\n\n文件大小:  " (itoa (vl-file-size ss)) " 字节" 
           "\n\n幻 灯 片: " (if (setq hd (findfile dd)) dd "无") 
    (if hd (strcat "\n\n幻灯片大小: " (itoa (vl-file-size hd)) " 字节") "") 
           )) 
(dxss_loadDescrib) 
(setq ssc (cadr (assoc (vl-filename-base ss) dxss-txtc))) 
(setq ssc (if ssc (strsub "\r\n" "^$~" ssc) "")) 
(dcl_Control_SetText dxss_Attrib_TextBox1 ssc) 
(dcl_Control_SetCaption dxss_Attrib_Label1 ssr) 
) 
;;加载说明文件 
(defun dxss_loadDescrib( / p) 
(setq p (strcat dxss-path "<a href=\"http://bbs.xdcad.net/file://description.txt/\" target=\"_blank\">\\description.txt</a>") 
      dxss-txtc (write_read "r" p nil)) 
) 
;;保存说明文件 
(defun dxss_saveDescrib( / ss tem fn f) 
(setq yy (dcl_Control_GetText dxss_Attrib_TextBox1)) 
(if (/= yy "")(progn 
   (setq ss (vl-filename-base (nth dxss-picture dxss-FullName)) 
         xx (strsub "^$~" "\r\n" yy)) 
   (if (assoc ss dxss-txtc) 
     (setq dxss-txtc (subst (list ss xx) (assoc ss dxss-txtc) dxss-txtc)) 
     (setq dxss-txtc (cons (list ss xx)  dxss-txtc))) 
  (write_read "w" (strcat dxss-path "<a href=\"http://bbs.xdcad.net/file://description.txt/\" target=\"_blank\">\\description.txt</a>") dxss-txtc) 
))(dxss_loaditem) 
) 
;;选择文件路径 
(defun c:dxss_mainWin_TextButton8_OnClicked (/) 
(setq pss (dcl_SelectFolder "选择图库加载路径..." dxss-path)) 
(if pss (progn 
  (setq dxss-path pss) (dxss_tkini) 
  (dcl_ListBox_Clear dxss_mainWin_ListBox1) 
  (c:dxss_mainWin_OnInitialize) 
)) 
) 
;;关闭属性窗口 
(defun c:dxss_Attrib_TextButton1_OnClicked (/) 
(dxss_saveDescrib)(dcl_form_close dxss_Attrib) 
) 
;;读写文件 
(defun write_read(Key Fpath Data / f k Lss ss ncn) 
  (setq k (strcase Key)) ;;将关键字统一转换为大写 
  (cond 
    ((= k "W")(if (and Fpath Data (= (type Fpath) 'STR)) 
       (progn 
           (setq Lss (vl-prin1-to-string Data)) 
           (setq f (open Fpath "w")) 
           (princ Lss f) 
           (close f) 
           t))) 
    ((= k "R")(if (and Fpath (= (type Fpath) 'STR) (findfile Fpath)) 
       (progn 
           (setq f (open Fpath "r") 
                ss (read-line f) 
                Lss (read ss)) 
           (close f) 
           Lss) 
           Data)) 
    (t nil)) 
) 
;;长路径截短以适应 text 显示，doslib有这个函数 
(defun dxss-trim(ss n / k L) 
(setq L (strlen ss)) 
(if (> L n)(progn 
    (setq k (fix (/ (- n 3) 2))) 
    (strcat (substr ss 1 (+ k 3)) "..." (substr ss (- L k -3))) ;;非偶数截取可能会乱码 
) ss) 
) 
(princ)

Lisp代码、odcl 对话框以及测试图库下载。用法：全部释放到 E:\tk 下，路径可修改

改了半天，收点币^_^

429014673 · 发表于 2013-6-12 00:08:32

增加文件夹有分类情况，不可能所有的块都在一个文件夹下的，如主库有A1 A2 A3文件夹，各个主库下面有子库B1 B2 B3 B4等文件夹，每个子库文件下都有DWG的图块列表文件

yxpxa · 发表于 2013-5-23 21:07:17

本帖最后由 yxpxa 于 2013-6-27 16:54 编辑

感谢大家的支持，原计划第4更未完成就停止，时隔一个月后发现回复不少，说明这个代码还有用。
先将3.5代码发布如下。
时间长忘了更新了那块，大致如下

面板参数保存到注册表
图库可按文件夹分类
缩略图优先显示同名 sld 幻灯
...

3.5版源码下载

请点击此处下载

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

您的用户组是：游客

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

XDSoft · 发表于 2013-5-23 22:52:45

yxpxa 发表于 2013-5-23 21:07
代码和界面，力求简洁，在实现主要功能和消除bug的前提下，用最少的控件和最短的代码。
为保持和 Odcl 的 ...

我看你的代码，就想给你简化下，你说的当然可以了，用READ，EVAL来实现。

XDSoft · 发表于 2013-5-23 22:54:27

XDSoft 发表于 2013-5-23 22:52
我看你的代码，就想给你简化下，你说的当然可以了，用READ，EVAL来实现。

给你贴段代码，你参照下

[pcode=lisp,true]
(defun defunfunc ()
  (foreach x (list "SunCone" "zzEmluator" "Lmdsx" "ZZ3DNK")
(eval (read (strcat "(defun c:" x "_OnClicked(/)(dcl_sendstring \"" x
                     "\n\"))"
            )
      )
)
  )
  (setq tabfunc_cg (list "SUNLAYER" "SUNJZPICKSET" "setmark" "SUNCHGroup"
                     "SUNBHPickSet" "SUN_GROUPCHK" "SUNBHGROUP"
                     "SUNBHPREFIX" "SUNBHSORT" "SUNPickYC" "SUNPickRes"
                     "SUNYCRES" "SUNINVERSE" "SUNBATINVERSE"
                     "SUNDelAtLine"
               )
      tabfunc_jm (list "SUN_ArchH" "SUN_ArchElev" "MODPOLYLEN")
      tabfunc_zk (list "SUNELEVZK" "SUNSelReP" "SUNSelSwap" "SUNDSXZKOFF"
                     "SUNDSXZKON" "SUNDSXZKMROW" "SUNDSXZKSort"
                     "SUNDSXZKMove" "SUNDSXZKAlign" "SUNDSXZKMI"
                     "SUNDSXTxtMi"
               )
      tabfunc_tool (list "SUNMKFTDWG" "SUNCGMX" "SUNGJWK" "MODPOLYLEN"
                        "SUNGJTOP" "SUNTLCR" "SUNDrawOrderTop"
                        "SUNScaleFit" "SUN_ZK_MKGROUP"
                  )
      FuncList (list tabfunc_cg tabfunc_jm tabfunc_zk tabfunc_tool)
  )
  (foreach n FuncList
(foreach x n
   (eval (read (strcat "(defun c:" x
                        "_OnClicked(/)(dcl_sendstring \"XDTB_" x "\n\"))"
               )
         )
   )
)
  )
)

[/pcode]

上面这些代码，就是我的ODCL里面的按钮点击的时候，回调函数调用的代码，执行往命令行发字符串运行命令。

yxpxa · 发表于 2013-5-24 09:33:55

感谢！
非常强大的代码
我怎么把 eval 忘了。
程序已更新，版主有功夫测试一下。

zyhandw · 发表于 2013-5-24 10:28:31

考虑还不是很全面吧，建议把牢固版主的自动加载支持opendcl的库文件加进去

yxpxa · 发表于 2013-5-25 04:46:48

本帖最后由 yxpxa 于 2013-5-25 04:49 编辑

第3次小更新了一下:
可以制作同名的幻灯，也可以不要幻灯，就是显示预览的时候模糊了点。
采用 grread 函数来显示多块插入功能
每个图块可自定义说明、程序设置均保存在当前图块路径的 txt 文本
图库路径可自定义修改

后面待修改实现的功能:
1 读取属性块数据并插入
2 多文件夹图块支持
3 插入的时候右键结束

长风（龙少） · 发表于 2013-5-25 08:56:47

图库管理程序加载失败，文件 OpenDCL.16.arx 缺失怎么回事？

userzhl · 发表于 2013-5-25 12:31:33

yxpxa 发表于 2013-5-25 04:46
第3次小更新了一下:
可以制作同名的幻灯，也可以不要幻灯，就是显示预览的时候模糊了点。
采用 grread 函 ...

建议这里列表换成文件夹目录——便于分类，点取即可读取文件夹内的图块。

yxpxa · 发表于 2013-5-25 16:52:50

本帖最后由 yxpxa 于 2013-5-25 16:58 编辑

汗，在 OpenDCL 版块，还有人没有支持文件的。
以下给出 7.0.0.12 版的 OpenDCL.*.arx 支持文件 (配套的CAD版本均为32位)

AutoCAD R16 版本系列： 2004 2005 2006 下载

请点击此处下载

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

您的用户组是：游客

文件名称:OpenDCL.16.arx.rar
下载次数:96 文件大小:440.54 KB
下载权限: 不限以上 [免费赚D豆]

AutoCAD R17 版本系列： 2007 2008 2009 下载

请点击此处下载

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

您的用户组是：游客

文件名称:OpenDCL.17.arx.rar
下载次数:199 文件大小:472.84 KB
下载权限: 不限以上 [免费赚D豆]

用法：解压缩到相应 CAD 版本的支持路径下即可，程序将自动搜素并加载之。

楼上的要求就是多文件模式，加了几行代码，现在已经调好了。将在第4更发布，敬请期待。
现在有个问题2
如何判断一个 *.dwg 是块文件还是图纸文件？
图像控件都无差别的显示了，但是块插入的时候就会没反应。
另外读取块属性也不会，需要用到 vla 对象函数，谁能帮忙写个函数。

XDSoft · 发表于 2013-5-25 17:00:12

yxpxa 发表于 2013-5-25 16:52
汗，在 OpenDCL 版块，还有人没有支持文件的。
以下给出 7.0.0.12 版的 OpenDCL.*.arx 支持文件 (配套的CA ...

准备到第几更呢:P

GTJ116600 · 发表于 2013-6-1 22:29:37

留个印，留着往后学习

sachindkini · 发表于 2013-6-3 15:42:09

DEAR SIR, GREAT

yangist · 发表于 2013-6-8 17:15:24

安装后提示 OpenDCL.18.arx 缺失怎么办

Lispboy · 发表于 2013-6-8 19:49:20

yangist 发表于 2013-6-8 17:15
安装后提示 OpenDCL.18.arx 缺失怎么办

你安装OPENDCL实时运行库了吗？

账号		自动登录	找回密码
密码			立即注册

[研讨] 源码图库管理小程序 2013年5月25日第3更

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

评分

点评

点评

[研讨] 源码 图库管理小程序 2013年5月25日 第3更

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

评分

点评

点评

[研讨] 源码图库管理小程序 2013年5月25日第3更