明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 46442|回复: 167

[讨论] DWG批量去教育版/版本转换/减肥瘦身/查找替换

    [复制链接]
发表于 2013-1-18 19:19:20 | 显示全部楼层 |阅读模式
本帖最后由 自贡黄明儒 于 2013-11-11 13:16 编辑

1         前言:我最喜欢批量处理东西了,比如给圆和封闭多边形加中心线、文字对齐。。。
2         说明:
2.1         本程序用vl编写
2.2         iceberg2509 的批量去教育版/版本转换一贴,可以学到许多实用的东西,可我一直没有将此派上用场,原因是要2010版本才能使用;已经打开的文件不能处理。
2.3         批量文字查找替换,有一个被雪山飞狐加精的帖子,可惜是VB版的。
2.4         我试图将上面功能弄成一个界面,想想也就算了,麻烦,能用就行了。
3         命令:out  MyFind
4         功能:
4.1         Out 批量去教育版、批量版本转换、批量减肥瘦身
4.2         MyFind 批量减肥瘦身、批量文字查找替换
5         后语:欢迎试用
6         【参考文献】
6.1         iceberg2509 的批量去教育版、批量版本转换
6.2         highflybir的块变色
6.3         Gu_xl 的文字查找替换
6.4         狂刀的文字查找替换
7    提示:处理打开的文件前须保存
=========================================================================

1 Hellow写的DWG|DXF通用转换器,速度确实很快,但有时处理不了。
2 Caoyin发的EduPlotStamp.exe(69楼)放在支持目录下,则可以处理激活文档。
3 今天这个改进版似乎好些,但速度慢了
4 修正了上一版的一个错误(列表中只添加打开的文件时,“确定”按钮不起作用)

  1. ;;=================DWG文件版本批量处理程序=====================
  2. ;;改编自iceberg2509的程序 自贡黄明儒 2013.1.6
  3. (defun C:out (/     DCL_ID DWGFILELST   DWGTYPE
  4.        EDIT_FIN1    EDIT_INS1 EDUPLOTST    HASOPENFILES
  5.        HOLDLSP    INDEX INITDIR      LST_DWGFILE
  6.        MYERROR    OLDERROR POP_VER      RETURN#
  7.        TMPFILE    TOG_CON1 TOG_DEL1     TOG_FIN1
  8.        TOG_SUBFOLDER  TOG_WBL1     X
  9.       )
  10.   ;;1.1=============查找替代状态函数=======================
  11.   (defun tog_FinDo (tog_Fin1)
  12.     (if (= tog_Fin1 "1")
  13.       (progn (mode_tile "edit_Fin" 0) (mode_tile "edit_Ins" 0))
  14.       (progn (mode_tile "edit_Fin" 1) (mode_tile "edit_Ins" 1))
  15.     )
  16.   )
  17.   ;;1.2=============移除按钮状态函数=======================
  18.   (defun DelBtnIsEnabled ()
  19.     (if lst_DwgFile
  20.       (mode_tile "but_del" 0)
  21.       (mode_tile "but_del" 1)
  22.     )
  23.   )
  24.   ;;1.3=============确认按钮是否激活函数=======================
  25.   (defun OkBtnIsEnabled ()
  26.     (if (null dwgfileLst)
  27.       (mode_tile "but_OK" 1)
  28.       (mode_tile "but_OK" 0)
  29.     )
  30.   )
  31.   ;;1.4=============转换版本状态函数=======================
  32.   (defun tog_conDo (tog_con1)
  33.     (if (= tog_con1 "1")
  34.       (mode_tile "pop_ver" 0)
  35.       (mode_tile "pop_ver" 1)
  36.     )
  37.   )
  38.   ;;2============获取指定文件夹下的所有dwg文件=================
  39.   ;;对本程序,Initdir是全局变量,故使用此函数前须赋值
  40.   (defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles)
  41.     (setq filter  "*.dwg"
  42.    dwgPath (GetFolderNew Initdir "选择DWG文件夹")
  43.     )
  44.     (if dwgPath
  45.       (progn
  46. (setq Initdir dwgPath)
  47. (if (= "0" tog_subfolder)
  48.    (setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter))
  49.    (setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter))
  50. )
  51. (LoadDwgFileLst dwgfiles)
  52.       )
  53.     )
  54.   )[/align][align=left]  ;;3============加载dwg文件到列表==============
  55.   ;;DWGFILELST HASOPENFILES对于本程序是全局
  56.   (defun LoadDwgFileLst
  57.   (fileslst / DWGFILELST1 HASOPENFILES1 TMPFILE N)
  58.     (if fileslst
  59.       (progn
  60. (setq fileslst (SuccessOpenFiles fileslst))
  61.      ;对其中非打开文件进行检查,看是否能打开
  62. (setq HasOpenFiles1 (vl-remove-if 'VL-FILE-SYSTIME fileslst)
  63.        dwgfileLst1   (vl-remove-if-not 'VL-FILE-SYSTIME fileslst)
  64. )
  65. (if dwgfileLst
  66.    (repeat (setq n (length dwgfileLst1))
  67.      (setq tmpfile (nth (setq n (1- n)) dwgfileLst1))
  68.      (if (member tmpfile dwgfileLst)
  69.        nil
  70.        (setq dwgfileLst
  71.        (append dwgfileLst
  72.         (list (strcase tmpfile T))
  73.        )
  74.        )
  75.      )
  76.    )
  77.    (setq dwgfileLst dwgfileLst1)
  78. )
  79. (if HasOpenFiles
  80.    (repeat (setq n (length HasOpenFiles1))
  81.      (setq tmpfile (nth (setq n (1- n)) HasOpenFiles1))
  82.      (if (member tmpfile HasOpenFiles)
  83.        nil
  84.        (setq HasOpenFiles
  85.        (append HasOpenFiles
  86.         (list (strcase tmpfile T))
  87.        )
  88.        )
  89.      )
  90.    )
  91.    (setq HasOpenFiles HasOpenFiles1)
  92. )[/align][align=left] (start_list "lst_DwgFile")
  93. (if HasOpenFiles
  94.    (progn (setq HasOpenFiles (vl-sort HasOpenFiles '<))
  95.    (mapcar 'add_list HasOpenFiles)
  96.    )
  97. )
  98. (if dwgfileLst
  99.    (progn (setq dwgfileLst (vl-sort dwgfileLst '<))
  100.    (mapcar 'add_list dwgfileLst)
  101.    )
  102. )
  103. (end_list)
  104.       )
  105.     )
  106.     (OkBtnIsEnabled)
  107.   )
  108.   ;;3.1 检查非打开文件,返回能成功能打开的文件列表
  109.   (defun SuccessOpenFiles
  110.      (fileslst  /        DWGFILELST
  111.       HASOPENFILES  N        NOTOPENFILELST
  112.       TMPFILE
  113.      )
  114.     (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME fileslst)
  115.    dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME fileslst)
  116.     )
  117.     (if dwgfileLst
  118.       (repeat (setq n (length dwgfileLst))
  119. (setq tmpfile (nth (setq n (1- n)) dwgfileLst))
  120. (if (CanSuccessOpen tmpfile)
  121.    (setq NotOpenFileLst (cons tmpfile NotOpenFileLst))
  122. )
  123.       )
  124.     )
  125.     (if NotOpenFileLst
  126.       (progn
  127. (repeat (setq n (length NotOpenFileLst))
  128.    (setq tmpfile (nth (setq n (1- n)) NotOpenFileLst))
  129.    (setq dwgfileLst (vl-remove tmpfile dwgfileLst))
  130. )
  131. (alert
  132.    (strcat
  133.      "以下文件可能已经损坏,或者需要高版本才能打开,无法添加到列表:\n"
  134.      (AddSeprate NotOpenFileLst "\n")
  135.    )
  136. )
  137.       )
  138.     )
  139.     (append HasOpenFiles dwgfileLst)
  140.   )
  141.   ;;3.2 对于非打开文件进行检查,看是否能打开
  142.   (defun CanSuccessOpen (DwgName / ACADAPP CATCHIT DBXDOC)
  143.     (setq AcadApp (vlax-get-acad-object)
  144.    dbxDoc  (vla-GetInterfaceObject
  145.       AcadApp
  146.       (GetObjectDBXVer)
  147.     )
  148.     )
  149.     (setq catchit (vl-catch-all-apply 'vla-open (list dbxDoc DwgName)))
  150.     (if dbxDoc
  151.       (vlax-release-object dbxDoc)
  152.     )     ;关闭文档
  153.     (if AcadApp
  154.       (vlax-release-object AcadApp)
  155.     )
  156.     (vl-catch-all-error-p catchit)
  157.   )[/align][align=left]  ;;4===============获取选中的dwg文件=====================
  158.   (defun AddDwgFiles (/ flags diatl filter dwgfiles)
  159.     (setq flags  (+ 4 512 4096 32768 524288 1048576)
  160.    diatl  "选择文件"
  161.    filter "图形(*.dwg)|*.dwg"
  162.     )
  163.     (setq dwgfiles (GetMultiFiles flags diatl filter Initdir))
  164.     (if dwgfiles
  165.       (progn
  166. (setq Initdir (vl-filename-directory (car dwgfiles)))
  167. (LoadDwgFileLst dwgfiles)
  168.       )
  169.     )
  170.   )
  171.   ;;4.1=========vlisp如何打开多重选择文件对话框函数================
  172.   ;;来自于明经
  173.   ;;调用示例
  174.   ;|(defun C:msfile  (/ flags diatl filter initdir)
  175.   (setq  flags  (+ 4 512 4096 32768 524288 1048576)
  176.   diatl  "选择文件"
  177.   filter  "图形文件(*.dwg)|*.dwg|所有文件(*.*)|*.*"
  178.   initdir  (getvar "dwgprefix")
  179.   )
  180.   (GetMultiFiles flags diatl filter initdir)
  181. )          ;end defun
  182. |;
  183.   (defun GetMultiFiles (flags   diatl     filter    initdir
  184.    /   index     wincomdlg filem
  185.    mfile   catchit
  186.          )
  187.     ;;首先判断是否已经注册,如果未注册,先注册,此操作需要重新启动CAD
  188.     (if (setq wincomdlg (vlax-create-object "MSComDlg.CommonDialog"))
  189.       (progn
  190. (vlax-put-property wincomdlg 'CancelError :vlax-true)
  191. (vlax-put-property wincomdlg 'MaxFileSize 32767)
  192. (vlax-put-property
  193.    wincomdlg
  194.    'Flags
  195.    flags
  196. )
  197. (vlax-put-property wincomdlg 'DialogTitle diatl)
  198. (vlax-put-property wincomdlg 'Filter filter)
  199. (vlax-put-property wincomdlg 'InitDir initdir)
  200. (setq
  201.    catchit (vl-catch-all-apply ;捕获错误
  202.       '(lambda ()
  203.          (vlax-invoke-method wincomdlg 'ShowOpen)
  204.          (setq filem (vlax-get wincomdlg 'filename))
  205.        )
  206.     )
  207. )
  208. (vlax-release-object wincomdlg)
  209. (if (vl-catch-all-error-p catchit)
  210.    nil    ;此时选择的是取消
  211.    (progn
  212.      (setq Index 1
  213.     filem (FSTR->LST filem)
  214.      )
  215.      (if filem
  216.        (if (= 2 (length filem))
  217.   (setq
  218.     mfile
  219.      (list (strcase (strcat (car filem) (cadr filem)) T)
  220.      )
  221.   )
  222.   (repeat (1- (length filem))
  223.     (setq mfile (append
  224.     mfile
  225.     (list (strcase
  226.      (strcat (car filem)
  227.       "\"
  228.       (nth index filem)
  229.      )
  230.      T
  231.           )
  232.     )
  233.          )
  234.    index (1+ index)
  235.     )
  236.   )
  237.        )
  238.      )
  239.    )
  240. )
  241.       )
  242.       (progn
  243. (alert "当前系统无MSComDlg.CommonDialog对象!")
  244. (Regdlg)
  245.       )
  246.     )
  247.     mfile
  248.   )[/align][align=left]  ;;5==============移除选定文件函数=======================
  249.   ;;DWGFILELST HASOPENFILES LST_DWGFILE对于本程序是全局
  250.   (defun RemoveDwgFiles (/ IndexLst RemoveDwgLst INDEX TMPFILE)
  251.     (if lst_DwgFile
  252.       (progn
  253. (setq IndexLst    (makelist lst_DwgFile " ")
  254.        RemoveDwgLst (mapcar '(lambda (index)
  255.           (nth (atoi index)
  256.         (append HasOpenFiles dwgfileLst)
  257.           )
  258.         )
  259.        IndexLst
  260.       )
  261. )
  262. ;;移除选定文件
  263. (mapcar '(lambda (tmpfile)
  264.      (setq HasOpenFiles
  265.      (vl-remove (strcase tmpfile T) HasOpenFiles)
  266.      )
  267.    )
  268.   RemoveDwgLst
  269. )
  270. (mapcar '(lambda (tmpfile)
  271.      (setq dwgfileLst
  272.      (vl-remove (strcase tmpfile T) dwgfileLst)
  273.      )
  274.    )
  275.   RemoveDwgLst
  276. )
  277. (start_list "lst_DwgFile")
  278. (if HasOpenFiles
  279.    (mapcar 'add_list HasOpenFiles)
  280. )
  281. (if dwgfileLst
  282.    (mapcar 'add_list dwgfileLst)
  283. )
  284. (end_list)
  285. (setq lst_DwgFile nil)
  286.       )
  287.     )
  288.     (DelBtnIsEnabled)
  289.     (OkBtnIsEnabled)
  290.   )[/align][align=left]  ;;6.1=============初始化对话框函数=======================
  291.   (defun setdata-1 ()
  292.     (cond
  293.       ((= (fix (atof (getvar "acadver"))) 16)
  294.        (setq
  295.   DwgType (list (list 0 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  296.          (list 1 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  297.          (list 2 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  298.          (list 3 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  299.    )
  300.        )
  301.       )
  302.       ((= (fix (atof (getvar "acadver"))) 17)
  303.        (setq
  304.   DwgType (list (list 0 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  305.          (list 1 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  306.          (list 2 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  307.          (list 3 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  308.          (list 4 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  309.          (list 5 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  310.          (list 6 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  311.    )
  312.        )
  313.       )
  314.       (T
  315.        (setq
  316.   DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
  317.          (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
  318.          (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  319.          (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  320.          (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  321.          (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  322.          (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  323.          (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  324.          (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  325.    )   ;这里为什么用list而不用 ',是因为用'后,ac2012_dwg等就不会求值了,导致后续程序取值错误
  326.        )
  327.       )
  328.     )
  329.     (start_list "pop_ver")
  330.     (mapcar 'add_list (mapcar '(lambda (x) (cadr x)) DwgType))
  331.     (end_list)
  332.     (if (not pop_ver)
  333.       (setq pop_ver "0")
  334.     )
  335.     (set_tile "pop_ver" pop_ver)
  336.     ;;子文件夹
  337.     (if (not tog_subfolder)
  338.       (setq tog_subfolder "0")
  339.     )
  340.   )
  341.   ;;6.2=============取得用户对话框选择=============
  342.   (defun getdata-1 ()
  343.     (setq tog_del1 (get_tile "tog_del"))
  344.     (setq tog_con1 (get_tile "tog_con"))
  345.     (setq tog_Wbl1 (get_tile "tog_Wbl"))
  346.     (setq tog_Fin1 (get_tile "tog_Fin"))
  347.     (setq edit_Fin1 (get_tile "edit_Fin"))
  348.     (setq edit_Ins1 (get_tile "edit_Ins"))
  349.     (setq pop_ver (get_tile "pop_ver"))
  350.   )
  351.   ;;6.3=============对话框驱动函数==================
  352.   (defun ConvDwgLst (/ DCLID FN FNAME LIN TOG_FIN1 X)
  353.     (setq fname (vl-filename-mktemp nil nil ".dcl"))
  354.     (setq fn (open fname "w"))
  355.     (write-line
  356.       "dcl_settings : default_dcl_settings { audit_level = 3; }"
  357.       fn
  358.     )
  359.     (write-line "BatConVer : dialog {" fn)
  360.     (write-line "    label = "DWG批量处理工具";" fn)
  361.     (write-line "    : row {" fn)
  362.     (write-line "        : column {" fn)
  363.     (write-line "           : boxed_row {" fn)
  364.     (write-line "               label = "转换版本";" fn)
  365.     (write-line "               : popup_list {" fn)
  366.     (write-line "                  key = "pop_ver";" fn)
  367.     (write-line "                  //width=36;" fn)
  368.     (write-line "               }" fn)
  369.     (write-line "           }" fn)
  370.     (write-line "           : boxed_row {" fn)
  371.     (write-line "              label="DWG文件列表";" fn)
  372.     (write-line
  373.       "              : list_box {                 "
  374.       fn
  375.     )
  376.     (write-line "                 key="lst_DwgFile";" fn)
  377.     (write-line "                 width=70;" fn)
  378.     (write-line "                 height=35;" fn)
  379.     (write-line "                 allow_accept=true;" fn)
  380.     (write-line "                multiple_select=true;" fn)
  381.     (write-line "              }" fn)
  382.     (write-line "          }" fn)
  383.     (write-line "        }" fn)
  384.     (write-line "        : column {" fn)
  385.     (write-line
  386.       "            : boxed_column{label = "文件选择";"
  387.       fn
  388.     )
  389.     (write-line "              : button {" fn)
  390.     (write-line "                label = "添加文件夹...";" fn)
  391.     (write-line "                key = "but_addfolder";" fn)
  392.     (write-line "                fixed_width = true;" fn)
  393.     (write-line "              }" fn)
  394.     (write-line "              : toggle {" fn)
  395.     (write-line "                label = "包括子文件夹";" fn)
  396.     (write-line "                key = "tog_subfolder";" fn)
  397.     (write-line "              }" fn)
  398.     (write-line "              : button {" fn)
  399.     (write-line "                label = "添加文件...";" fn)
  400.     (write-line "                key = "but_addfile";" fn)
  401.     (write-line "              }" fn)
  402.     (write-line "              : button {" fn)
  403.     (write-line "                label = "删除...";" fn)
  404.     (write-line "                key = "but_del";" fn)
  405.     (write-line "                is_enabled = false;" fn)
  406.     (write-line "              }" fn)
  407.     (write-line "            }" fn)
  408.     (write-line "            spacer;" fn)
  409.     (write-line
  410.       "            : boxed_column{label = "操作选择";"
  411.       fn
  412.     )
  413.     (write-line "              : toggle {" fn)
  414.     (write-line "                label = "去教育版";" fn)
  415.     (write-line
  416.       "                key = "tog_del";                "
  417.       fn
  418.     )
  419.     (write-line "              }" fn)
  420.     (write-line "              : toggle {" fn)
  421.     (write-line "                label = "版本转换";" fn)
  422.     (write-line "                value = "1";" fn)
  423.     (write-line "                key = "tog_con";" fn)
  424.     (write-line "              }" fn)
  425.     (write-line "              : toggle {" fn)
  426.     (write-line "                label = "减肥瘦身";" fn)
  427.     (write-line "                key = "tog_Wbl";" fn)
  428.     (write-line "              }" fn)
  429.     (write-line "            }" fn)
  430.     (write-line "            spacer;" fn)
  431.     (write-line
  432.       "            : boxed_column{label = "执行选择";"
  433.       fn
  434.     )
  435.     (write-line "              : button {" fn)
  436.     (write-line "                label = "确定(&A)";" fn)
  437.     (write-line "                key = "but_OK";" fn)
  438.     (write-line "                is_enabled = false;" fn)
  439.     (write-line "                //is_default = true;" fn)
  440.     (write-line "              }" fn)
  441.     (write-line "              : button {" fn)
  442.     (write-line "                label = "取消(&C)";" fn)
  443.     (write-line "                key = "but_Cancel";" fn)
  444.     (write-line "                is_cancel = true;" fn)
  445.     (write-line "              }" fn)
  446.     (write-line "            }            " fn)
  447.     (write-line "       }" fn)
  448.     (write-line "    }" fn)
  449.     (write-line "}" fn)
  450.     (close fn)
  451.     (setq fn (open fname "r"))
  452.     (setq dclid (load_dialog fname))
  453.     (while (or (eq (substr (setq lin (vl-string-right-trim
  454.            "" fn)"
  455.            (vl-string-left-trim
  456.       "(write-line ""
  457.       (read-line fn)
  458.            )
  459.          )
  460.       )
  461.       1
  462.       2
  463.      )
  464.      "//"
  465.         )
  466.         (eq (substr lin 1 (vl-string-search " " lin)) "")
  467.         (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
  468.    " : dialog"
  469.       )
  470.         )
  471.     )
  472.     )
  473.     (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)[/align][align=left]    (setdata-1)    ;初始化对话框
  474.     (set_tile "tog_subfolder" tog_subfolder)
  475.     (action_tile "but_addfolder" "(AddDwgFilesInFolder)")
  476.     (action_tile "but_addfile" "(AddDwgFiles)")
  477.     (action_tile "but_del" "(RemoveDwgFiles)")
  478.     (action_tile "tog_subfolder" "(setq tog_subfolder $$value)")
  479.     (action_tile
  480.       "lst_DwgFile"
  481.       "(setq lst_DwgFile $$value)(DelBtnIsEnabled)"
  482.     )
  483.     (action_tile
  484.       "tog_Fin"
  485.       "(setq tog_Fin1 $$value)(tog_FinDo tog_Fin1)"
  486.     )
  487.     (action_tile
  488.       "tog_con"
  489.       "(setq tog_con1 $$value)(tog_conDo tog_con1)"
  490.     )
  491.     (action_tile "but_OK" "(getdata-1)(done_dialog 1)")
  492.     (action_tile "but_Cancel" "(done_dialog 0)")
  493.     (setq return# (start_dialog))
  494.     (unload_dialog dclid)
  495.     (close fn)
  496.     (vl-file-delete fname)
  497.     (if (and (= return# 1) (or(not (null dwgfileLst))(not (null HasOpenFiles))))
  498.       (progn
  499. (if (= TOG_WBL1 "1")
  500.    (progn (DwgWblock dwgfileLst)
  501.    (DwgWblock1 HasOpenFiles)
  502.    )
  503. )
  504. (if (= tog_del1 "1")
  505.    (progn (if dwgfileLst
  506.      (DelEduLog dwgfileLst)
  507.    )
  508.    (if HasOpenFiles
  509.      (DelEduLog1 HasOpenFiles)
  510.    )
  511.    )
  512. )
  513. (if (= tog_con1 "1")
  514.    (progn (DwgConverter POP_VER dwgfileLst)
  515.    (DwgConverter1 POP_VER HasOpenFiles)
  516.    )
  517. ) [/align][align=left]      )
  518.     )
  519.   )[/align][align=left]  ;;7===========定义容错函数===============
  520.   (defun MyError (msg)
  521.     (if (or (= msg "Function cancelled")
  522.      (= msg "quit / exit abort")
  523.      (= msg "函数被取消")
  524.      (= msg "函数已取消")
  525. )
  526.       (princ)
  527.       (princ (strcat "\n 错误:" msg "\n"))
  528.     )
  529.     (setvar "acadlspasdoc" HOLDLSP)
  530.     (princ)
  531.   )[/align][align=left]  ;;8=================dwg转dxf文件函数================
  532.   (defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc)
  533.     (setq AcadApp (vlax-get-acad-object)
  534.    dbxDoc  (vla-GetInterfaceObject
  535.       AcadApp
  536.       (GetObjectDBXVer)
  537.     )
  538.     )
  539.     (vla-open dbxDoc DwgName)
  540.     ;;(vla-saveas dbxDoc DwgName ac2000_dxf)
  541.     ;;(vla-close dbxDoc :vlax-false)
  542.     (vlax-invoke dbxDoc "dxfout" dxfName)
  543.      ;原来这句好好的,现在怎么不行了?
  544.     (if dbxDoc
  545.       (vlax-release-object dbxDoc)
  546.     )     ;关闭文档
  547.     (if AcadApp
  548.       (vlax-release-object AcadApp)
  549.     )
  550.   )[/align][align=left]  ;;9.1==============非打开的文件版本转换================
  551.   ;;DWGTYPE 对于本函数是全局
  552.   (defun DwgConverter (POP_VER   dwgfileLst /  ACADAPP
  553.          BASENAME   DOCOBJ     DWGNAME DWGVER
  554.          DXFFILE   FILEEXT    FILEPATH INDEX
  555.          NEWFILE
  556.         )
  557.     ;;===从图元表中提取dxf组码值函数组码值函数
  558.     (defun dxf (Item dxfList) (cdr (assoc Item dxfList)))[/align][align=left]    (setq AcadApp (vlax-get-acad-object))
  559.     (setq pop_ver (atoi pop_ver))
  560.     (setq DwgVer (last (dxf pop_ver DwgType)))
  561.     (if (= (/ pop_ver 2) pop_ver) ;偶数
  562.       (setq FileExt ".dwg")
  563.       (setq FileExt ".dxf")
  564.     )
  565.     (repeat (setq Index (length dwgfileLst))
  566.       (setq DwgName  (nth (setq Index (1- Index)) dwgfileLst)
  567.      BaseName (vl-filename-base DwgName)
  568.      filepath (vl-filename-directory DwgName)
  569.      DxfFile  (strcat (getfullpath filepath)
  570.         BaseName
  571.         ".dxf"
  572.        )
  573.      NewFile  (vl-filename-mktemp BaseName filepath FileExt)
  574.       )
  575.       (setq DocObj (vla-open (vla-get-documents AcadApp) DwgName))
  576.       (vla-saveas DocObj NewFile DwgVer) ;将原dwg文件存为指定版本的
  577.       (vla-close DocObj :vlax-false)
  578.       (if (= FileExt ".dxf")
  579. (progn
  580.    ;;改为dwg同名文件
  581.    (if (findfile DxfFile)
  582.      (deletefile DxfFile)
  583.    )
  584.    (vl-file-rename NewFile DxfFile)
  585. )
  586. (progn
  587.    (deletefile DwgName)
  588.    ;;新保存的文件名改为原dwg文件名
  589.    (vl-file-rename NewFile DwgName)
  590. )
  591.       )
  592.     )[/align][align=left]    (if DocObj
  593.       (vlax-release-object DocObj)
  594.     )
  595.     (if AcadApp
  596.       (vlax-release-object AcadApp)
  597.     )
  598.   )
  599.   ;;9.2============已经打开的文件版本转换================
  600.   (defun DwgConverter1 (POP_VER HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
  601.     (setq *ACAD* (vlax-get-acad-object))
  602.     ;;关闭
  603.     (repeat (setq n (length HasOpenFiles))
  604.       (setq DwgName (nth (setq n (1- n)) HasOpenFiles))
  605.       (vlax-for item (vla-get-Documents *ACAD*)
  606. (if (= (strcase (vlax-get-property item 'FullName))
  607.         (strcase DwgName)
  608.      )
  609.    (vla-close item :vlax-false)
  610. )
  611.       )
  612.     )
  613.     ;;版本转换
  614.     (DwgConverter POP_VER HasOpenFiles)
  615.     ;;再打开
  616.     (setq *DOCS* (vla-get-documents *ACAD*))
  617.     (repeat (setq n (length HasOpenFiles))
  618.       (setq DwgName (nth (setq n (1- n)) HasOpenFiles))
  619.       (vla-open *DOCS* DwgName)
  620.     )
  621.   )[/align][align=left]  ;;10.1============非打开的文件去除教育版标记================
  622.   (defun DelEduLog (dwgfileLst /   BACKUP     BACKUPFILE
  623.       BASENAME   AcadApp   DOCOBJ     DWGNAME
  624.       DXFEXT     DXFFILE   FILEPATH   INDEX
  625.      )
  626.     (setq DxfExt ".dxf"
  627.    BackUp "_Backup"
  628.     )
  629.     (setq AcadApp (vlax-get-acad-object))
  630.     (repeat (setq Index (length dwgfileLst))
  631.       (setq DwgName    (nth (setq Index (1- Index)) dwgfileLst)
  632.      BaseName   (vl-filename-base DwgName)
  633.      filepath   (vl-filename-directory DwgName)
  634.      dxfFile    (vl-filename-mktemp BaseName filepath DxfExt)
  635.      BackupFile (strcat (getfullpath filepath)
  636.           BaseName
  637.           BackUp
  638.           (vl-filename-extension DwgName)
  639.          )
  640.       )
  641.       ;;利用objectdbx转存.dxf文件
  642.       (Dwg2Dxf DwgName dxfFile)
  643.       ;;备份文件存在,则删除
  644.       (if (findfile BackupFile)
  645. (deletefile BackupFile)
  646.       )
  647.       ;;修改原dwg文件为备份文件
  648.       (vl-file-rename DwgName BackupFile)
  649.       ;;打开dxf文件
  650.       (if (setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile))
  651. (progn (deletefile BackupFile)
  652.         ;;再存为2000版dwg文件
  653.         (vla-saveas DocObj DwgName ac2000_dwg)
  654.         (vla-close DocObj :vlax-false)
  655.         ;;删除dxf文件
  656.         (deletefile dxfFile)
  657. )
  658.       )
  659.     )
  660.     (if DocObj
  661.       (vlax-release-object DocObj)
  662.     )
  663.     (if AcadApp
  664.       (vlax-release-object AcadApp)
  665.     )
  666.   )
  667.   ;;10.2============已经打开的文件去除教育版标记================
  668.   (defun DelEduLog1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
  669.     (setq *ACAD* (vlax-get-acad-object))
  670.     ;;关闭
  671.     (repeat (setq n (length HasOpenFiles))
  672.       (setq DwgName (nth (setq n (1- n)) HasOpenFiles))
  673.       (vlax-for item (vla-get-Documents *ACAD*)
  674. (if (= (strcase (vlax-get-property item 'FullName))
  675.         (strcase DwgName)
  676.      )
  677.    (vla-close item :vlax-false)
  678. )
  679.       )
  680.     )
  681.     ;;去除教育
  682.     (DelEduLog HasOpenFiles)
  683.     ;;再打开
  684.     (setq *DOCS* (vla-get-documents *ACAD*))
  685.     (repeat (setq n (length HasOpenFiles))
  686.       (setq DwgName (nth (setq n (1- n)) HasOpenFiles))
  687.       (vla-open *DOCS* DwgName)
  688.     )
  689.   )
  690.   ;;11.1============非打开的文件减肥瘦身================
  691.   (defun DwgWblock (dwgfileLst /   ACADAPP    BACKUPFILE
  692.       BASENAME   DOCOBJ   DWGNAME    FILEPATH
  693.       INDEX      NEWSET   SSETS
  694.      )
  695.     (setq AcadApp (vlax-get-acad-object))
  696.     (repeat (setq Index (length dwgfileLst))
  697.       (setq DwgName (nth (setq Index (1- Index)) dwgfileLst))
  698.       (setq BaseName   (vl-filename-base DwgName)
  699.      filepath   (vl-filename-directory DwgName)
  700.      ;;dxfFile    (vl-string-subst ".dxf" ".dwg" DwgName)
  701.      BackupFile (strcat (getfullpath filepath)
  702.           BaseName
  703.           "_Backup"
  704.           (vl-filename-extension DwgName)
  705.          )
  706.       )
  707.       (if (findfile BackupFile)
  708. (deletefile BackupFile)
  709.       )     ;检查原dwg文件的备份文件名是否存在,如果存在,则删除
  710.       (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
  711. (progn
  712.    (setq
  713.      DocObj (vla-open (vla-get-documents AcadApp) BackupFile)
  714.    )
  715.    (setq ssets (vla-get-selectionsets DocObj))
  716.    (if (vl-catch-all-error-p
  717.   (vl-catch-all-apply 'vla-item (list ssets "$$Set"))
  718.        )
  719.      (setq newSet (vla-add ssets "$$Set"))
  720.      (progn
  721.        (vla-delete (vla-item ssets "$$Set"))
  722.        (setq newSet (vla-add ssets "$$Set"))
  723.      )
  724.    )
  725.    ;;select all objects in the drawing
  726.    (vla-Select newSet acSelectionSetAll)
  727.    (vla-WBlock DocObj DwgName newSet)
  728.    (vla-close DocObj :vlax-false)
  729.    (deletefile BackupFile)
  730. )
  731.       )
  732.     )
  733.     (if DocObj
  734.       (vlax-release-object DocObj)
  735.     )
  736.     (if AcadApp
  737.       (vlax-release-object AcadApp)
  738.     )
  739.   )
  740.   ;;11.2============已经打开的文件减肥瘦身================
  741.   (defun DwgWblock1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
  742.     (setq *ACAD* (vlax-get-acad-object))
  743.     ;;关闭
  744.     (setq HasOpenFiles (mapcar 'strcase HasOpenFiles))
  745.     (vlax-for item (vla-get-Documents *ACAD*)
  746.       (if (member (strcase (vlax-get-property item 'FullName))
  747.     HasOpenFiles
  748.    )
  749. (vla-close item :vlax-false)
  750.       )
  751.     )
  752.     ;;减肥瘦身
  753.     (DwgWblock HasOpenFiles)
  754.     ;;再打开
  755.     (setq *DOCS* (vla-get-documents *ACAD*))
  756.     (repeat (setq n (length HasOpenFiles)) ;使用foreach失败,原因待查
  757.       (setq DwgName (nth (setq n (1- n)) HasOpenFiles))
  758.       (vla-open *DOCS* DwgName)
  759.     )
  760.   )
  761.   ;;15=================主函数===========
  762.   (setq OldError *error*
  763. *error*  MyError
  764. HOLDLSP  (getvar "ACADLSPASDOC")
  765.   )
  766.   (setvar "acadlspasdoc" 0)
  767.   (setvar "cmdecho" 0)
  768.   ;;(if (not MsgBox)(load "MsgBox"))[/align][align=left]  (cond
  769.     ((< (atof (getvar "acadver")) 16) ;检查版本
  770.      ;|(MsgBox "版本检查"
  771.       64
  772.       "此程序只能运行在AutoCAD 2004或更高版本!"
  773.      )|;
  774.      (alert "此程序只能运行在AutoCAD 2004或更高版本!")
  775.      (exit)
  776.     )
  777.     ((/= 1 (getvar "dwgtitled")) ;未保存过的文件
  778.      ;;(setq dcl_id (load_dialog "dwgconverter"))
  779.      (setq Initdir (getvar "dwgprefix"))
  780.      (ConvDwgLst)
  781.     )
  782.     ((= 1 (getvar "dwgtitled"))  ;文件环境(保存过)
  783.      ;|(MsgBox
  784.        "使用环境检查"
  785.        64
  786.        "批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!"
  787.      )|;
  788.      (alert
  789.        "批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!"
  790.      )
  791.      (if (setq EduPlotSt (findfile "EduPlotStamp.exe"))
  792.        (startapp EduPlotSt)
  793.      )
  794.     )
  795.   )
  796.   ;;(setvar "acadlspasdoc" HOLDLSP)
  797.   (setq *error* OldError)
  798.   (gc)
  799.   (princ)
  800. )[/align][align=left]
  801. ;;==============================公用函数==========================[/align][align=left];;1 =============获取全路径,即路径后有\=================================
  802. (defun GetFullPath (path)
  803.   (if (wcmatch path "*\")
  804.     path
  805.     (strcat path "\")
  806.   )
  807. )[/align][align=left];;2 ============================获取文件夹程序=================================
  808. ;;根据Express tools是否安装决定使用哪一个函数
  809. (defun GetFolderNew (InitDir msg / ArxFile Apptitle)
  810.   (setq Apptitle "浏览文件夹"
  811. ArxFile  "acetutil.arx"
  812.   )
  813.   (if (findfile ArxFile)
  814.     (GetFolder3 Apptitle Msg InitDir)
  815.     (getFolder1 msg)
  816.   )
  817. )
  818. ;;2.1 没有安装ET时选择的文件夹
  819. ;;来自于明经秋枫
  820. ;; 用法:(getFolder1 msg)
  821. ;; 例子:(getFolder1 "选择文件夹:")
  822. ;; 返回值:字符串,文件夹路径,如果点了cancel, 返回nil
  823. (defun GetFolder1 (msg / WinShell shFolder path catchit)
  824.     ;|===============================
  825. 3. 关于Shell.Application的使用
  826. 3.1、创建 Shell 对象
  827. var Shell = new ActiveXObject("Shell.Application");
  828. 3.2、使用 Shell 属性及方法
  829. Shell.Application
  830. Shell.Parent
  831. Shell.CascadeWindows()
  832. Shell.TileHorizontally()
  833. Shell.TileVertically()
  834. Shell.ControlPanelItem(sDir) /* 比如:sysdm.cpl */
  835. Shell.EjectPC()
  836. Shell.Explore(vDir)
  837. Shell.Open(vDir)
  838. Shell.FileRun()
  839. Shell.FindComputer()
  840. Shell.FindFiles()
  841. Shell.Help()
  842. Shell.MinimizeAll()
  843. Shell.UndoMinimizeALL()
  844. Shell.RefreshMenu()
  845. Shell.SetTime()
  846. Shell.TrayProperties()
  847. Shell.ShutdownWindows()
  848. Shell.Suspend()
  849. oWindows = Shell.Windows() /* 返回ShellWindows对象 */
  850. fFolder = Shell.NameSpace(vDir) /* 返回所打开的vDir的Folder对象 */
  851. oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder]) /* 选择文件夹对话框 */
  852. /*示例:
  853. function BrowseFolder()
  854. {
  855. var Message = "清选择文件夹";
  856. var Shell = new ActiveXObject( "Shell.Application" );
  857. var Folder = Shell.BrowseForFolder(0,Message,0x0040,0x11);
  858. if(Folder != null)
  859. {
  860. Folder = Folder.items(); // 返回 FolderItems 对象
  861. Folder = Folder.item(); // 返回 Folderitem 对象
  862. Folder = Folder.Path; // 返回路径
  863. if(Folder.charAt(varFolder.length-1) != "\"){
  864. Folder = varFolder + "\";
  865. }
  866. return Folder;
  867. }
  868. }
  869. */
  870. /*示例:
  871. var Folder = Shell.NameSpace("C:\"); // 返回 Folder对象
  872. */
  873. |;
  874.   (setq winshell (vlax-create-object "Shell.Application"))
  875.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
  876.   (setq
  877.     catchit (vl-catch-all-apply
  878.        '(lambda ()
  879.    (setq shFolder (vlax-get-property shFolder 'self))
  880.    (setq path (vlax-get-property shFolder 'path))
  881.         )
  882.      )
  883.   )
  884.   (if (vl-catch-all-error-p catchit)
  885.     nil
  886.     (GetFullPath path)
  887.   )
  888. )
  889. ;;2.2 安装ET后选择的文件夹
  890. (defun GetFolder3 (Apptitle Msg InitDir / ArxFile New_Path catchit)
  891.   (setq ArxFile "acetutil.arx")
  892.   (if (findfile ArxFile)
  893.     (arxload "acetutil.arx" NIL)
  894.     (exit)
  895.   )
  896.   (setq catchit (vl-catch-all-apply
  897.     '(lambda ()
  898.        (setq New_Path
  899.        (strcat
  900.          (strcase
  901.     (acet-ui-pickdir
  902.       Msg
  903.       (vl-string-right-trim "\" InitDir)
  904.       Apptitle
  905.     )
  906.          )
  907.        )
  908.        )
  909.      )
  910.   )
  911.   )
  912.   (if (vl-catch-all-error-p catchit)
  913.     nil
  914.     (GetFullPath New_Path)
  915.   )
  916. )[/align][align=left];;3 ============;;注册"MSComDlg.CommonDialog"=============================
  917. (defun Regdlg ()
  918.   (vl-registry-write
  919.     "HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
  920.     ""
  921.     "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
  922.   )
  923. )[/align][align=left];;4 ============将输入的数据转换为字符串列表===================
  924. (defun FSTR->LST (FM / N ff)
  925.   (setq FF NIL)
  926.   (IF (VL-STRING-POSITION (ASCII "\000") FM)
  927.     (PROGN
  928.       (WHILE (VL-STRING-POSITION (ASCII "\000") FM)
  929. (SETQ N (VL-STRING-POSITION (ASCII "\000") FM))
  930. (SETQ FF (APPEND FF (LIST (SUBSTR FM 1 N))))
  931. (SETQ FM (SUBSTR FM (+ N 2) (- (STRLEN FM) N 1)))
  932.       )
  933.       (SETQ FF (APPEND FF (LIST FM)))
  934.     )
  935.     (PROGN
  936.       (SETQ FF (VL-FILENAME-DIRECTORY FM))
  937.       (SETQ FF (LIST FF (VL-STRING-SUBST "" FF FM)))
  938.     )
  939.   )
  940. )[/align][align=left];;5.1 =============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件===========
  941. ;;返回列表文件表元素全为小写
  942. (defun GetAllSpecFilesInFolder (dir filter)
  943.   (mapcar
  944.     (function
  945.       (lambda (file)
  946. (strcase (strcat (getfullpath dir) file) T)
  947.       )
  948.     )
  949.     (vl-directory-files dir filter 1)
  950.   )
  951. )
  952. ;;5.2 =============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件===========
  953. (defun GetAllSpecFilesInFolders (dir filter / filenames)
  954.   (setq filenames (mapcar
  955.       (function
  956.         (lambda (file)
  957.    (strcase (strcat (getfullpath dir) file) T)
  958.    ;;递归出口
  959.         )
  960.       )
  961.       (vl-directory-files dir filter 1)
  962.     )
  963.   )
  964.   (mapcar
  965.     (function
  966.       (lambda (subdir)
  967. ;; 此处递归
  968. (setq filenames (append filenames
  969.     (GetAllSpecFilesInFolders
  970.       (strcat (getfullpath dir) subdir)
  971.       filter
  972.     )
  973.    )
  974. )
  975.       )
  976.     )
  977.     (vl-remove-if
  978.       (function (lambda (subdir)
  979.     (member subdir '("." ".."))
  980.   )
  981.       )
  982.       (vl-directory-files dir nil -1)
  983.     )
  984.   )
  985.   filenames
  986. )[/align][align=left] ;|;定义VB中对话框msgbox几个输入常数:全局变量
  987. ;; MsgBox(prompt[, buttons][, title][, helpfile, context])
  988. ;; Buttons:
  989. ;; vbOKOnly          0 Display OK button only.
  990. ;; vbOKCancel        1 Display OK and Cancel buttons.
  991. ;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons.
  992. ;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons.
  993. ;; vbYesNo          4 Display Yes and No buttons.
  994. ;; vbRetryCancel        5 Display Retry and Cancel buttons.
  995. ;; vbCritical       16 Display Critical Message icon.
  996. ;; vbQuestion       32 Display Warning Query icon.
  997. ;; vbExclamation       48 Display Warning Message icon.
  998. ;; vbInformation       64 Display Information Message icon.
  999. ;; vbDefaultButton1        0 First button is default.
  1000. ;; vbDefaultButton2      256 Second button is default.
  1001. ;; vbDefaultButton3      512 Third button is default.
  1002. ;; vbDefaultButton4      768 Fourth button is default.
  1003. ;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application.
  1004. ;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box.
  1005. (setq vbOKOnly 0)
  1006. (setq vbOKCancel 1)
  1007. (setq vbAbortRetryIgnore 2)
  1008. (setq vbYesNoCancel 3)
  1009. (setq vbYesNo 4)
  1010. (setq vbRetryCancel 5)
  1011. (setq vbCritical 16
  1012.       vbQuestion 32
  1013. )
  1014. (setq vbExclamation  48
  1015.       vbInformation  64
  1016.       vbDefaultButton1  0
  1017.       vbDefaultButton2  256
  1018.       vbDefaultButton3  512
  1019.       vbDefaultButton4  768
  1020.       vbApplicationModal 0
  1021.       vbSystemModal  4096
  1022. )
  1023. ;;返回值
  1024. ;;1  OK button
  1025. ;;2  Cancel button
  1026. ;;3  Abort button
  1027. ;;4  Retry button
  1028. ;;5  Ignore button
  1029. ;;6  Yes button
  1030. ;;7  No button
  1031. (setq rs_OK 1
  1032.       rs_Cancel 2
  1033.       rs_Abort 3
  1034.       rs_Retry 4
  1035.       rs_Ignore 5
  1036.       rs_Yes 6
  1037.       rs_No 7
  1038. )
  1039. ;; A cute little utility to invoke a VBA message box and return a value to AutoLisp.
  1040. ;; Requires AutoCAD 2000 (R15) or higher.
  1041. ;; The buttons are a Boolean value representing a logical sum of
  1042. ;; the following values:
  1043. ;;--------------------------------------------------------
  1044. ;; MsgBox(prompt[, buttons][, title][, helpfile, context])
  1045. ;; Buttons:
  1046. ;; vbOKOnly          0 Display OK button only.
  1047. ;; vbOKCancel        1 Display OK and Cancel buttons.
  1048. ;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons.
  1049. ;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons.
  1050. ;; vbYesNo          4 Display Yes and No buttons.
  1051. ;; vbRetryCancel        5 Display Retry and Cancel buttons.
  1052. ;; vbCritical       16 Display Critical Message icon.
  1053. ;; vbQuestion       32 Display Warning Query icon.
  1054. ;; vbExclamation       48 Display Warning Message icon.
  1055. ;; vbInformation       64 Display Information Message icon.
  1056. ;; vbDefaultButton1        0 First button is default.
  1057. ;; vbDefaultButton2      256 Second button is default.
  1058. ;; vbDefaultButton3      512 Third button is default.
  1059. ;; vbDefaultButton4      768 Fourth button is default.
  1060. ;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application.
  1061. ;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box.
  1062. ;;test:(MsgBox "This is a test!" vbOKCancel "Iceberg CAD Tools")|;
  1063. (defun MsgBox (Title Buttons Message / useri1 value)
  1064.   (vl-load-com)
  1065.   (or *acad* (setq *acad* (vlax-get-acad-object)))
  1066.   (setq useri1 (getvar "useri1"))
  1067.   (acad-push-dbmod)
  1068.   (vla-eval
  1069.     *acad*
  1070.     (strcat
  1071.       "ThisDrawing.SetVariable "USERI1","
  1072.       "MsgBox (""
  1073.       Message
  1074.       "","
  1075.       (itoa Buttons)
  1076.       ",""
  1077.       Title
  1078.       "")"
  1079.     )
  1080.   )
  1081.   (setq value (getvar "useri1"))
  1082.   (setvar "useri1" useri1)
  1083.   (acad-pop-dbmod)
  1084.   value
  1085. )     ;end defun[/align][align=left];;7 =========获取ObjectDBX版本字符串============
  1086. (defun GetObjectDBXVer (/ VERSION)
  1087.   (if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
  1088.     (strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
  1089.   )
  1090. )[/align][align=left];;8 =================删除文件函数===================
  1091. ;; 能删除所有文件,不管只读、隐藏与否,都能删除
  1092. ;; vl-file-delete不能删除只读文件
  1093. ;;Scripting.FileSystemObject格式
  1094. ;;fso.DeleteFile ( filespec[, force] )
  1095. ;;参数
  1096. ;; fso  必选项, 应为 FileSystemObject 的名称。
  1097. ;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
  1098. ;; force   可选项, Boolean 值,如果要删除设置了只读属性的文件,则为 true ;如果不删除则为 false (默认)。
  1099. ;; Arguments [Typ]:
  1100. ;;   Fil = FileName, "C:\\test\\Autoexec.bat" [STR]
  1101. ;; Notes:
  1102. ;;   - Requires ScrRun.dll.
  1103. ;; USAGE: (DelFile "C:\\test\\*.*")
  1104. ;; USAGE: (DelFile "C:\\test\\Autoexec.bat")
  1105. (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
  1106.   (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
  1107.   (setq FILDIR (vl-filename-directory FIL))
  1108.   (setq
  1109.     SS (vl-directory-files
  1110.   FILDIR
  1111.   (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
  1112.   1
  1113.        )
  1114.   )
  1115.   (foreach ENT SS
  1116.     (vlax-invoke
  1117.       FILSYS
  1118.       "deletefile"
  1119.       (strcat FILDIR "\" ENT)
  1120.       :vlax-false
  1121.     )
  1122.   )
  1123.   (vlax-release-object FILSYS)
  1124.   (princ)
  1125. )[/align][align=left];;9 生成表记录函数:把字符串变为表
  1126. (defun makelist (str pat / i j n lst)
  1127.   (cond
  1128.     ((/= (type str) (type pat) 'STR))
  1129.     ((= str pat) '(""))
  1130.     (T
  1131.      (setq i 0
  1132.     n (strlen pat)
  1133.      )
  1134.      (while (setq j (vl-string-search pat str i))
  1135.        (setq lst (cons (substr str (1+ i) (- j i)) lst)
  1136.       i  (+ j n)
  1137.        )
  1138.      )
  1139.      (reverse (cons (substr str (1+ i)) lst))
  1140.     )
  1141.   )
  1142. )[/align][align=left];;10 添加分隔符函数
  1143. (defun AddSeprate (DataList delimiter / i len dealdata TempData)
  1144.   (setq i   1
  1145. len (length DataList)
  1146.   )
  1147.   (if len
  1148.     (progn
  1149.       (setq dealdata (nth 0 DataList))
  1150.       (if (numberp dealdata)
  1151. (setq dealdata (rtos dealdata 2))
  1152.       )
  1153.       (repeat (1- len)
  1154. (setq TempData (nth i DataList))
  1155. (if (numberp TempData)
  1156.    (setq TempData (rtos TempData 2))
  1157. )
  1158. (setq dealdata (strcat dealdata delimiter TempData))
  1159. (setq i (1+ i))
  1160.       )
  1161.     )
  1162.   )
  1163.   (setq DataList dealdata)
  1164. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

Lisp版的去教育戳记基本原理就是转为DXF文件后再转回DWG!前面有不少人已经发过源码!  发表于 2013-1-18 22:55

评分

参与人数 5明经币 +6 收起 理由
bzhjl + 1 赞一个!
qqask + 1 还是有点不好用,要是多处替换的话,还得重.
jh1005 + 1 赞一个!
1993063 + 1 赞一个!
Gu_xl + 2 赞一个!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2013-1-18 20:27:36 | 显示全部楼层
谢谢楼主,最关注去教育版功能,希望好用。
回复 支持 0 反对 1

使用道具 举报

发表于 2021-12-8 15:58:04 | 显示全部楼层
这个源码复制后,格式有变化,您是否可以把LSP以附件的形式再发一下?
发表于 2022-4-25 17:53:18 | 显示全部楼层
查找替换以后,原文件名称包含大小写的最后全部变成了小写
 楼主| 发表于 2013-1-18 19:20:45 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2013-1-18 19:29 编辑

界面如下:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2013-1-18 19:47:13 | 显示全部楼层
顶个先,试用看OK不
发表于 2013-1-18 20:02:10 | 显示全部楼层
本帖最后由 bdboy 于 2013-1-18 20:02 编辑

谢谢了.....试试
发表于 2013-1-18 20:14:05 | 显示全部楼层
支持,谢谢楼主.
发表于 2013-1-18 20:18:02 | 显示全部楼层
我最喜欢去教育版了,论坛这么多,我一个都用不了,看看黄兄大作
发表于 2013-1-18 20:23:32 | 显示全部楼层
用不了~~~~~~~~~~~

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2013-1-18 20:24:23 | 显示全部楼层
顶,支持一下,现在很少有教育版吧.
发表于 2013-1-18 20:31:38 | 显示全部楼层
向楼主学习学习。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-14 14:40 , Processed in 0.249907 second(s), 38 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表