本帖最后由 zhanghuohuo 于 2025-11-30 21:20 编辑
  2. (defun c:BPLOT (/ *error* dcl-file dcl-id result
  3.                        get-plotters get-styles get-media-names
  4.                        update-media-list update-file-list write-dcl browse-folder
  5.                        valid-folder-p save-settings load-settings
  6.                        generate-worker-lsp generate-scr-file
  7.                        smart-sort path-slash prepare-temp-env
  8.                        remove-selected-file browse-multi-files
  9.                        plotters styles media-list pick-block
  10.                        sel-block sel-plotter sel-style sel-media sel-scale sel-factor
  11.                        sel-folder file-list selected-file-idx
  12.                        acad-obj doc clayout reg-path factor-num
  13.                        worker-path scr-path temp loop temp-dir input-path)

  15.   (vl-load-com)
  16.   
  17.   (setq acad-obj (vlax-get-acad-object))
  18.   (setq doc (vla-get-ActiveDocument acad-obj))
  19.   (setq clayout (vla-get-ActiveLayout doc))
  20.   (setq reg-path "HKEY_CURRENT_USER\\Software\\BatchPlotTool_SCR")
  21.   (setq file-list nil)
  22.   (setq selected-file-idx nil)
  23.   (setq input-path "")

  25.   (defun *error* (msg)
  26.     (if dcl-id (unload_dialog dcl-id))
  27.     (if (and dcl-file (findfile dcl-file)) (vl-file-delete dcl-file))
  28.     (if (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*")))
  29.       (princ (strcat "\n错误: " msg))
  30.     )
  31.     (princ)
  32.   )

  34.   ;; ========== 基础工具 ==========
  35.   
  36.   (defun path-slash (path)
  37.     (while (vl-string-search "\" path)
  38.       (setq path (vl-string-subst "/" "\" path))
  39.     )
  40.     path
  41.   )

  43.   (defun smart-sort (lst / extract-number)
  44.     (defun extract-number (s / i len c num found)
  45.       (setq i 1 len (strlen s) num "" found nil)
  46.       (while (and (<= i len) (not (wcmatch (substr s i 1) "#")))
  47.         (setq i (1+ i))
  48.       )
  49.       (while (and (<= i len) (wcmatch (setq c (substr s i 1)) "#"))
  50.         (setq num (strcat num c) i (1+ i) found T)
  51.       )
  52.       (if found (atoi num) 999999)
  53.     )
  54.     (vl-sort lst
  55.       '(lambda (a b / na nb)
  56.          (setq na (extract-number a) nb (extract-number b))
  57.          (if (= na nb)
  58.            (< a b)
  59.            (< na nb)
  60.          )
  61.        )
  62.     )
  63.   )

  65.   (defun smart-sort-paths (lst)
  66.     (vl-sort lst
  67.       '(lambda (a b / na nb)
  68.          (setq na (extract-number (vl-filename-base a)))
  69.          (setq nb (extract-number (vl-filename-base b)))
  70.          (if (= na nb)
  71.            (< (strcase (vl-filename-base a)) (strcase (vl-filename-base b)))
  72.            (< na nb)
  73.          )
  74.        )
  75.     )
  76.   )

  78.   (defun extract-number (s / i len c num found)
  79.     (setq i 1 len (strlen s) num "" found nil)
  80.     (while (and (<= i len) (not (wcmatch (substr s i 1) "#")))
  81.       (setq i (1+ i))
  82.     )
  83.     (while (and (<= i len) (wcmatch (setq c (substr s i 1)) "#"))
  84.       (setq num (strcat num c) i (1+ i) found T)
  85.     )
  86.     (if found (atoi num) 999999)
  87.   )

  89.   (defun prepare-temp-env (file-list temp-dir / fso src-path temp-path file-obj attrs copied-count fname)
  90.     (setq fso (vlax-create-object "Scripting.FileSystemObject"))
  91.     (if (vlax-invoke fso 'FolderExists temp-dir)
  92.       (vl-catch-all-apply 'vlax-invoke (list fso 'DeleteFolder temp-dir :vlax-true))
  93.     )
  94.     (vl-mkdir temp-dir)
  95.     (setq copied-count 0)
  96.     (if file-list
  97.       (progn
  98.         (princ "\n[系统] 正在初始化临时环境...")
  99.         (foreach src-path file-list
  100.           (setq fname (vl-filename-base src-path))
  101.           (setq temp-path (strcat temp-dir "\" fname ".dwg"))
  102.           (if (vl-file-copy src-path temp-path)
  103.             (progn
  104.               (if (setq file-obj (vl-catch-all-apply 'vlax-invoke (list fso 'GetFile temp-path)))
  105.                 (if (not (vl-catch-all-error-p file-obj))
  106.                   (progn
  107.                     (setq attrs (vlax-get file-obj 'Attributes))
  108.                     (if (= (logand attrs 1) 1)
  109.                       (vlax-put file-obj 'Attributes (logand attrs 65534))
  110.                     )
  111.                     (vlax-release-object file-obj)
  112.                   )
  113.                 )
  114.               )
  115.               (setq copied-count (1+ copied-count))
  116.               (princ (strcat "\n  -> 副本就绪: " fname ".dwg"))
  117.             )
  118.           )
  119.         )
  120.       )
  121.     )
  122.     (if fso (vlax-release-object fso))
  123.     (if (> copied-count 0) T nil)
  124.   )

  126.   ;; ========== 界面配置函数 ==========
  127.   (defun get-plotters ()
  128.     (vla-RefreshPlotDeviceInfo clayout)
  129.     (vlax-safearray->list (vlax-variant-value (vla-GetPlotDeviceNames clayout)))
  130.   )
  131.   
  132.   (defun get-styles ()
  133.     (vla-RefreshPlotDeviceInfo clayout)
  134.     (vlax-safearray->list (vlax-variant-value (vla-GetPlotStyleTableNames clayout)))
  135.   )
  136.   
  137.   (defun get-media-names (plotter / media err)
  138.     (setq media nil)
  139.     (if (and plotter (/= plotter ""))
  140.       (progn
  141.         (setq err (vl-catch-all-apply 'vla-put-ConfigName (list clayout plotter)))
  142.         (if (not (vl-catch-all-error-p err))
  143.           (progn
  144.             (vla-RefreshPlotDeviceInfo clayout)
  145.             (setq media (vl-catch-all-apply
  146.               '(lambda () (vlax-safearray->list (vlax-variant-value (vla-GetCanonicalMediaNames clayout))))
  147.               nil))
  148.             (if (vl-catch-all-error-p media) (setq media nil))
  149.           )
  150.         )
  151.       )
  152.     )
  153.     media
  154.   )
  155.   
  156.   (defun browse-folder (msg / sh folder folderobj path)
  157.     (setq path nil)
  158.     (setq sh (vla-getInterfaceObject acad-obj "Shell.Application"))
  159.     (if sh
  160.       (progn
  161.         (setq folder (vl-catch-all-apply 'vlax-invoke-method (list sh 'BrowseForFolder 0 msg 0)))
  162.         (if (and folder (not (vl-catch-all-error-p folder)))
  163.           (progn
  164.             (setq folderobj (vlax-get-property folder 'Self))
  165.             (setq path (vlax-get-property folderobj 'Path))
  166.             (vlax-release-object folderobj)
  167.             (vlax-release-object folder)
  168.           )
  169.         )
  170.         (vlax-release-object sh)
  171.       )
  172.     )
  173.     (if (and path (> (strlen path) 0))
  174.       (if (/= (substr path (strlen path) 1) "\")
  175.         (setq path (strcat path "\"))
  176.       )
  177.     )
  178.     path
  179.   )

  181.   (defun browse-single-file (/ result)
  182.     (setq result (getfiled "选择DWG文件 (可多次添加)" "" "dwg" 4))
  183.     result
  184.   )
  185.   
  186.   (defun valid-folder-p (folder)
  187.     (and folder (= (type folder) 'STR) (> (strlen folder) 0))
  188.   )
  189.   
  190.   (defun pick-block (/ ent obj name)
  191.     (setq name nil)
  192.     (princ "\n选择图框块...")
  193.     (while (null name)
  194.       (setq ent (car (entsel "\n点击选择图框块: ")))
  195.       (if ent
  196.         (progn
  197.           (setq obj (vlax-ename->vla-object ent))
  198.           (if (= (vla-get-ObjectName obj) "AcDbBlockReference")
  199.             (if (vlax-property-available-p obj 'EffectiveName)
  200.               (setq name (vla-get-EffectiveName obj))
  201.               (setq name (vla-get-Name obj))
  202.             )
  203.             (princ "\n不是块引用")
  204.           )
  205.         )
  206.         (setq name "")
  207.       )
  208.     )
  209.     name
  210.   )
  211.   
  212.   (defun save-settings ()
  213.     (vl-registry-write reg-path "Block" (if sel-block sel-block ""))
  214.     (vl-registry-write reg-path "Printer" (if sel-plotter sel-plotter ""))
  215.     (vl-registry-write reg-path "Style" (if sel-style sel-style ""))
  216.     (vl-registry-write reg-path "Media" (if sel-media sel-media ""))
  217.     (vl-registry-write reg-path "Scale" (if sel-scale sel-scale "ScaleToFit"))
  218.     (vl-registry-write reg-path "Factor" (if sel-factor sel-factor "1.0"))
  219.     (vl-registry-write reg-path "Folder" (if sel-folder sel-folder ""))
  220.   )
  221.   
  222.   (defun load-settings ()
  223.     (setq sel-block (vl-registry-read reg-path "Block"))
  224.     (setq sel-plotter (vl-registry-read reg-path "Printer"))
  225.     (setq sel-style (vl-registry-read reg-path "Style"))
  226.     (setq sel-media (vl-registry-read reg-path "Media"))
  227.     (setq sel-scale (vl-registry-read reg-path "Scale"))
  228.     (setq sel-factor (vl-registry-read reg-path "Factor"))
  229.     (setq sel-folder (vl-registry-read reg-path "Folder"))
  230.     (if (or (not sel-scale) (= sel-scale "")) (setq sel-scale "ScaleToFit"))
  231.     (if (or (not sel-factor) (= sel-factor "")) (setq sel-factor "1.0"))
  232.   )

  234.   ;; ========== 文件列表管理 ==========
  235.   
  236.   (defun load-folder-files (folder / files full-path)
  237.     (if (valid-folder-p folder)
  238.       (progn
  239.         (if (= (substr folder (strlen folder) 1) "\")
  240.           (setq folder (substr folder 1 (1- (strlen folder))))
  241.         )
  242.         (setq files (vl-directory-files folder "*.dwg" 1))
  243.         (setq files (smart-sort files))
  244.         (setq file-list nil)
  245.         (foreach f files
  246.           (setq full-path (strcat folder "\" f))
  247.           (setq file-list (append file-list (list full-path)))
  248.         )
  249.       )
  250.     )
  251.     file-list
  252.   )

  254.   (defun update-file-list-display ()
  255.     (start_list "lst_files")
  256.     (if file-list
  257.       (foreach f file-list
  258.         (add_list (strcat (vl-filename-base f) ".dwg"))
  259.       )
  260.       (add_list "(空)")
  261.     )
  262.     (end_list)
  263.     (set_tile "txt_count" (strcat "共 " (itoa (length file-list)) " 个文件"))
  264.   )

  266.   (defun update-path-display (idx)
  267.     (if (and file-list idx (>= idx 0) (< idx (length file-list)))
  268.       (progn
  269.         (setq input-path (nth idx file-list))
  270.         (set_tile "txt_path" input-path)
  271.       )
  272.     )
  273.   )

  275.   (defun remove-selected-file (idx / i new-list)
  276.     (if (and idx (>= idx 0) (< idx (length file-list)))
  277.       (progn
  278.         (setq i 0 new-list nil)
  279.         (foreach f file-list
  280.           (if (/= i idx)
  281.             (setq new-list (append new-list (list f)))
  282.           )
  283.           (setq i (1+ i))
  284.         )
  285.         (setq file-list new-list)
  286.       )
  287.     )
  288.   )

  290.   (defun add-file-to-list (filepath)
  291.     (if (and filepath
  292.              (findfile filepath)
  293.              (wcmatch (strcase filepath) "*.DWG")
  294.              (not (member filepath file-list)))
  295.       (progn
  296.         (setq file-list (append file-list (list filepath)))
  297.         (setq file-list (smart-sort-paths file-list))
  298.         T
  299.       )
  300.       nil
  301.     )
  302.   )

  304.   (defun load-from-input-path (path / clean-path)
  305.     (if (and path (/= path ""))
  306.       (progn
  307.         (setq clean-path (vl-string-trim " \t" path))
  308.         (if (= (substr clean-path (strlen clean-path) 1) "\")
  309.           (setq clean-path (substr clean-path 1 (1- (strlen clean-path))))
  310.         )
  311.         (cond
  312.           ((and (wcmatch (strcase clean-path) "*.DWG")
  313.                 (findfile clean-path))
  314.            (if (add-file-to-list clean-path)
  315.              (progn
  316.                (princ (strcat "\n已添加文件: " (vl-filename-base clean-path)))
  317.                T
  318.              )
  319.              (progn
  320.                (princ "\n文件已存在或无效")
  321.                nil
  322.              )
  323.            )
  324.           )
  325.           ((vl-file-directory-p clean-path)
  326.            (setq sel-folder (strcat clean-path "\"))
  327.            (load-folder-files sel-folder)
  328.            (if file-list
  329.              (progn
  330.                (princ (strcat "\n已从文件夹加载 " (itoa (length file-list)) " 个文件"))
  331.                T
  332.              )
  333.              (progn
  334.                (princ "\n文件夹中没有DWG文件")
  335.                nil
  336.              )
  337.            )
  338.           )
  339.           (T
  340.            (alert (strcat "无效路径:\n" clean-path "\n\n请输入有效的文件夹路径或DWG文件路径"))
  341.            nil
  342.           )
  343.         )
  344.       )
  345.       nil
  346.     )
  347.   )

  349.   (defun update-factor-state (scale-mode)
  350.     (if (= scale-mode "ScaleToFit")
  351.       (mode_tile "txt_factor" 0)
  352.       (mode_tile "txt_factor" 1)
  353.     )
  354.   )

  356.   ;; ========== 生成 Worker.lsp ==========
  357.   (defun generate-worker-lsp (filepath block printer style media scale-mode factor / f)
  358.     (setq f (open filepath "w"))
  359.     (if f
  360.       (progn
  361.         (write-line ";; BatchPlot Worker V1.0" f)
  362.         (write-line "(princ "\\n[Worker] 加载中...")" f)
  363.         
  364.         (write-line "(defun ss->list (ss / n lst)" f)
  365.         (write-line "  (if ss (repeat (setq n (sslength ss)) (setq lst (cons (ssname ss (setq n (1- n))) lst)))) lst)" f)
  366.         
  367.         (write-line "(defun ax:2dpoint (pt)" f)
  368.         (write-line "  (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) (list (float (car pt)) (float (cadr pt))))))" f)
  369.         
  370.         (write-line "(defun shrink-bounding (bd factor / ll ur cx cy hw hh)" f)
  371.         (write-line "  (setq ll (car bd) ur (cadr bd))" f)
  372.         (write-line "  (setq cx (/ (+ (car ll) (car ur)) 2.0) cy (/ (+ (cadr ll) (cadr ur)) 2.0))" f)
  373.         (write-line "  (setq hw (/ (- (car ur) (car ll)) 2.0 factor) hh (/ (- (cadr ur) (cadr ll)) 2.0 factor))" f)
  374.         (write-line "  (list (list (- cx hw) (- cy hh)) (list (+ cx hw) (+ cy hh))))" f)
  375.         
  376.         (write-line "(defun islandscape (bd) (> (abs (- (caadr bd) (caar bd))) (abs (- (cadadr bd) (cadar bd)))))" f)
  377.         (write-line "(defun getwidth (bd) (max (abs (- (caadr bd) (caar bd))) (abs (- (cadadr bd) (cadar bd)))))" f)
  378.         
  379.         (write-line "(defun fixscale (n / i large)" f)
  380.         (write-line "  (setq i 0 large (> n 100))" f)
  381.         (write-line "  (while (or (> n 100) (< n 10)) (if large (setq n (/ n 10.0)) (setq n (* n 10.0))) (setq i (1+ i)))" f)
  382.         (write-line "  (setq n (fix (+ 0.5 n)))" f)
  383.         (write-line "  (repeat i (if large (setq n (* n 10.0)) (setq n (/ n 10.0)))) n)" f)
  384.         
  385.         (write-line "(defun sort-frames (bdlist / fuzz)" f)
  386.         (write-line "  (setq fuzz 10.0)" f)
  387.         (write-line "  (vl-sort bdlist '(lambda (a b)" f)
  388.         (write-line "    (if (equal (caar a) (caar b) fuzz) (> (cadar a) (cadar b)) (< (caar a) (caar b))))))" f)
  389.         
  390.         (write-line "(defun str-split (str delim / lst pos)" f)
  391.         (write-line "  (while (setq pos (vl-string-search delim str))" f)
  392.         (write-line "    (if (> pos 0) (setq lst (cons (substr str 1 pos) lst)))" f)
  393.         (write-line "    (setq str (substr str (+ 2 pos))))" f)
  394.         (write-line "  (if (/= str "") (setq lst (cons str lst))) (reverse lst))" f)
  395.         
  396.         (write-line "(defun process-layout (doc lay lay-name cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor /" f)
  397.         (write-line "         ss elist obj name minpt maxpt bdlist pW pH paperW i plot-bd scale frame-w target-list)" f)
  398.         (write-line "  (princ (strcat "\\n[" lay-name "]"))" f)
  399.         (write-line "  (if (vl-string-search ";" cfg-block)" f)
  400.         (write-line "    (setq target-list (mapcar 'strcase (str-split cfg-block ";")))" f)
  401.         (write-line "    (setq target-list (mapcar 'strcase (str-split cfg-block " "))))" f)
  402.         (write-line "  (if (null target-list) (setq target-list (list (strcase cfg-block))))" f)
  403.         (write-line "  (vla-ZoomExtents (vlax-get-acad-object))" f)
  404.         (write-line "  (setq ss (ssget "X" (list '(0 . "INSERT") (cons 410 lay-name))))" f)
  405.         (write-line "  (if ss (progn" f)
  406.         (write-line "    (setq elist (ss->list ss) bdlist '())" f)
  407.         (write-line "    (foreach ent elist" f)
  408.         (write-line "      (setq obj (vlax-ename->vla-object ent))" f)
  409.         (write-line "      (setq name (if (vlax-property-available-p obj 'EffectiveName) (vla-get-EffectiveName obj) (vla-get-Name obj)))" f)
  410.         (write-line "      (if (member (strcase name) target-list)" f)
  411.         (write-line "        (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'minpt 'maxpt))))" f)
  412.         (write-line "          (setq minpt (vlax-safearray->list minpt) maxpt (vlax-safearray->list maxpt)" f)
  413.         (write-line "                bdlist (cons (list (list (car minpt) (cadr minpt)) (list (car maxpt) (cadr maxpt))) bdlist)))))))" f)
  414.         (write-line "  (if bdlist (progn" f)
  415.         (write-line "    (setq bdlist (sort-frames bdlist))" f)
  416.         (write-line "    (princ (strcat " 找到" (itoa (length bdlist)) "个图框"))" f)
  417.         (write-line "    (vl-catch-all-apply 'vla-put-ActiveLayout (list doc lay))" f)
  418.         (write-line "    (vla-RefreshPlotDeviceInfo lay)" f)
  419.         (write-line "    (vl-catch-all-apply 'vla-put-ConfigName (list lay cfg-printer))" f)
  420.         (write-line "    (vla-RefreshPlotDeviceInfo lay)" f)
  421.         (write-line "    (vl-catch-all-apply 'vla-put-CanonicalMediaName (list lay cfg-media))" f)
  422.         (write-line "    (if (/= cfg-style "") (vl-catch-all-apply 'vla-put-StyleSheet (list lay cfg-style)))" f)
  423.         (write-line "    (vla-put-PaperUnits lay 1)" f)
  424.         (write-line "    (vla-GetPaperSize lay 'pW 'pH)" f)
  425.         (write-line "    (setq paperW (max pW pH) i 0)" f)
  426.         (write-line "    (foreach bd bdlist" f)
  427.         (write-line "      (setq i (1+ i))" f)
  428.         (write-line "      (princ (strcat "\\n  打印[" (itoa i) "/" (itoa (length bdlist)) "]"))" f)
  429.         (write-line "      (if (and (= cfg-scale-mode "ScaleToFit") (/= cfg-factor 1.0))" f)
  430.         (write-line "        (setq plot-bd (shrink-bounding bd cfg-factor)) (setq plot-bd bd))" f)
  431.         (write-line "      (if (= (islandscape bd) (> pW pH)) (vla-put-PlotRotation lay 0) (vla-put-PlotRotation lay 1))" f)
  432.         (write-line "      (vla-SetWindowToPlot lay (ax:2dpoint (car plot-bd)) (ax:2dpoint (cadr plot-bd)))" f)
  433.         (write-line "      (vla-put-PlotType lay 4) (vla-put-CenterPlot lay :vlax-true)" f)
  434.         (write-line "      (cond" f)
  435.         (write-line "        ((= cfg-scale-mode "ScaleToFit") (vla-put-UseStandardScale lay :vlax-true) (vla-put-StandardScale lay 0))" f)
  436.         (write-line "        ((= cfg-scale-mode "1:1") (vla-put-UseStandardScale lay :vlax-false) (vla-SetCustomScale lay 1.0 1.0))" f)
  437.         (write-line "        ((= cfg-scale-mode "Auto") (setq frame-w (getwidth bd) scale (fixscale (/ frame-w paperW)))" f)
  438.         (write-line "          (vla-put-UseStandardScale lay :vlax-false) (vla-SetCustomScale lay 1.0 scale)))" f)
  439.         (write-line "      (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-PlotToDevice (list (vla-get-Plot doc))))" f)
  440.         (write-line "        (princ " X") (princ " OK"))))" f)
  441.         (write-line "    (princ " 无匹配图框")))" f)
  442.         
  443.         (write-line "(defun c:AutoRunBatchPlot (/ acad doc layouts lay layout-list)" f)
  444.         (write-line "  (vl-load-com)" f)
  445.         (write-line "  (setq acad (vlax-get-acad-object) doc (vla-get-ActiveDocument acad) layouts (vla-get-Layouts doc))" f)
  446.         (write-line "  (setvar "BACKGROUNDPLOT" 0)" f)
  447.         (write-line (strcat "  (setq cfg-block "" block "" cfg-printer "" printer "" cfg-style "" style "")") f)
  448.         (write-line (strcat "  (setq cfg-media "" media "" cfg-scale-mode "" scale-mode "" cfg-factor " (rtos factor 2 6) ")") f)
  449.         (write-line "  (process-layout doc (vla-Item layouts "Model") "Model" cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor)" f)
  450.         (write-line "  (setq layout-list '())" f)
  451.         (write-line "  (vlax-for lay layouts (if (/= (vla-get-Name lay) "Model") (setq layout-list (cons lay layout-list))))" f)
  452.         (write-line "  (setq layout-list (vl-sort layout-list '(lambda (a b) (< (vla-get-TabOrder a) (vla-get-TabOrder b)))))" f)
  453.         (write-line "  (foreach lay layout-list (process-layout doc lay (vla-get-Name lay) cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor))" f)
  454.         (write-line "  (princ "\\n--- 当前文件完成 ---") (princ))" f)
  455.         (write-line "(c:AutoRunBatchPlot)" f)
  456.         (close f)
  457.         filepath
  458.       )
  459.       nil
  460.     )
  461.   )

  463.   ;; ========== 生成 SCR ==========
  464.   (defun generate-scr-file (scr-path worker-path temp-dir file-list / f file full-path fname)
  465.     (setq worker-path (path-slash worker-path))
  466.     (if file-list
  467.       (progn
  468.         (setq f (open scr-path "w"))
  469.         (if f
  470.           (progn
  471.             (write-line "SDI 0" f)
  472.             (write-line "SECURELOAD 0" f)
  473.             (write-line "FILEDIA 0" f)
  474.             (write-line "CMDECHO 0" f)
  475.             (write-line "XREFNOTIFY 0" f)
  476.             (write-line "PROXYNOTICE 0" f)
  477.             (foreach file file-list
  478.               (setq fname (vl-filename-base file))
  479.               (setq full-path (strcat temp-dir "\" fname ".dwg"))
  480.               (setq full-path (path-slash full-path))
  481.               (write-line (strcat "_.OPEN "" full-path """) f)
  482.               (write-line "DELAY 100" f)
  483.               (write-line (strcat "(if (findfile "" worker-path "") (load "" worker-path ""))") f)
  484.               (write-line "DELAY 50" f)
  485.               (write-line "_.CLOSE _N" f)
  486.             )
  487.             (write-line "FILEDIA 1" f)
  488.             (write-line "CMDECHO 1" f)
  489.             (write-line "SECURELOAD 1" f)
  490.             (write-line "(princ "\\n==============================")" f)
  491.             (write-line "(princ "\\n  批量打印全部完成!")" f)
  492.             (write-line "(princ "\\n==============================")" f)
  493.             (write-line "(princ)" f)
  494.             (close f)
  495.             T
  496.           )
  497.           nil
  498.         )
  499.       )
  500.       nil
  501.     )
  502.   )

  504.   ;; ========== DCL 界面 ==========
  505.   (defun write-dcl (filename / f)
  506.     (setq f (open filename "w"))
  507.     (if f
  508.       (progn
  509.         (write-line "batchplot : dialog {" f)
  510.         (write-line "  label = "批量打印 V1.0";" f)
  511.         (write-line "  : row {" f)
  512.         
  513.         ;; 左侧 - 文件列表
  514.         (write-line "    : boxed_column {" f)
  515.         (write-line "      label = "待打印文件";" f)
  516.         (write-line "      : row {" f)
  517.         (write-line "        : edit_box {" f)
  518.         (write-line "          key = "txt_path";" f)
  519.         (write-line "          width = 30;" f)
  520.         (write-line "          edit_limit = 512;" f)
  521.         (write-line "        }" f)
  522.         (write-line "        : button { label = "..."; key = "btn_browse"; width = 3; fixed_width = true; }" f)
  523.         (write-line "      }" f)
  524.         (write-line "      : row {" f)
  525.         (write-line "        : button { label = "加载路径"; key = "btn_load"; width = 10; }" f)
  526.         (write-line "        : button { label = "添加文件"; key = "btn_add"; width = 10; }" f)
  527.         (write-line "        : button { label = "清空"; key = "btn_clear"; width = 6; }" f)
  528.         (write-line "      }" f)
  529.         (write-line "      : list_box {" f)
  530.         (write-line "        key = "lst_files";" f)
  531.         (write-line "        width = 36;" f)
  532.         (write-line "        height = 15;" f)
  533.         (write-line "        multiple_select = false;" f)
  534.         (write-line "      }" f)
  535.         (write-line "      : row {" f)
  536.         (write-line "        : text { key = "txt_count"; label = "共 0 个文件"; width = 16; }" f)
  537.         (write-line "        : button { label = "删除选中"; key = "btn_remove"; width = 10; }" f)
  538.         (write-line "      }" f)
  539.         (write-line "    }" f)
  540.         
  541.         ;; 右侧 - 打印设置
  542.         (write-line "    : column {" f)
  543.         (write-line "      : boxed_column {" f)
  544.         (write-line "        label = "图框设置";" f)
  545.         (write-line "        : row {" f)
  546.         (write-line "          : edit_box { label = "块名:"; key = "txt_block"; width = 22; }" f)
  547.         (write-line "          : button { label = "拾取"; key = "btn_pick"; width = 6; }" f)
  548.         (write-line "        }" f)
  549.         (write-line "        : text { label = "多个块名用分号;分隔"; }" f)
  550.         (write-line "      }" f)
  551.         
  552.         (write-line "      : boxed_column {" f)
  553.         (write-line "        label = "打印机设置";" f)
  554.         (write-line "        : popup_list { label = "打印机:"; key = "pop_printer"; width = 32; }" f)
  555.         (write-line "        : popup_list { label = "样式表:"; key = "pop_style"; width = 32; }" f)
  556.         (write-line "        : popup_list { label = "纸张:  "; key = "pop_media"; width = 32; }" f)
  557.         (write-line "      }" f)
  558.         
  559.         (write-line "      : boxed_column {" f)
  560.         (write-line "        label = "比例设置";" f)
  561.         (write-line "        : popup_list { label = "比例:"; key = "pop_scale"; width = 18; }" f)
  562.         (write-line "        : edit_box { label = "放大系数:"; key = "txt_factor"; width = 12; }" f)
  563.         (write-line "        : text { label = "(放大系数仅布满图纸时有效)"; }" f)
  564.         (write-line "      }" f)
  565.         
  566.         (write-line "      : boxed_column {" f)
  567.         (write-line "        label = "使用说明";" f)
  568.         (write-line "        : text { label = "1. 路径栏可粘贴文件夹或DWG路径"; }" f)
  569.         (write-line "        : text { label = "2. 点击[加载路径]导入文件"; }" f)
  570.         (write-line "        : text { label = "3. 选中列表项可查看完整路径"; }" f)
  571.         (write-line "      }" f)
  572.         (write-line "    }" f)
  573.         
  574.         (write-line "  }" f)
  575.         (write-line "  spacer_1;" f)
  576.         (write-line "  ok_cancel;" f)
  577.         (write-line "}" f)
  578.         (close f)
  579.         T
  580.       )
  581.       nil
  582.     )
  583.   )

  585.   ;; ========== 主逻辑 ==========
  586.   (load-settings)
  587.   (setq plotters (get-plotters))
  588.   (setq styles (get-styles))
  589.   (setq dcl-file (vl-filename-mktemp "bp_scr" nil ".dcl"))
  590.   (write-dcl dcl-file)
  591.   (setq dcl-id (load_dialog dcl-file))
  592.   (setq loop T)
  593.   
  594.   (if (valid-folder-p sel-folder)
  595.     (progn
  596.       (load-folder-files sel-folder)
  597.       (setq input-path sel-folder)
  598.     )
  599.   )
  600.   
  601.   (while loop
  602.     (if (not (new_dialog "batchplot" dcl-id))
  603.       (setq loop nil)
  604.       (progn
  605.         (start_list "pop_printer") (mapcar 'add_list plotters) (end_list)
  606.         (start_list "pop_style") (mapcar 'add_list styles) (end_list)
  607.         (start_list "pop_scale")
  608.         (add_list "布满图纸")
  609.         (add_list "自动比例")
  610.         (add_list "1:1")
  611.         (end_list)
  612.         
  613.         (update-file-list-display)
  614.         
  615.         (if (and input-path (/= input-path ""))
  616.           (set_tile "txt_path" input-path)
  617.           (if sel-folder (set_tile "txt_path" sel-folder))
  618.         )
  619.         
  620.         (cond
  621.           ((= sel-scale "ScaleToFit") (set_tile "pop_scale" "0"))
  622.           ((= sel-scale "Auto") (set_tile "pop_scale" "1"))
  623.           ((= sel-scale "1:1") (set_tile "pop_scale" "2"))
  624.           (T (set_tile "pop_scale" "0") (setq sel-scale "ScaleToFit"))
  625.         )
  626.         
  627.         (update-factor-state sel-scale)
  628.         
  629.         (if sel-block (set_tile "txt_block" sel-block))
  630.         (set_tile "txt_factor" (if sel-factor sel-factor "1.0"))
  631.         
  632.         (if (and sel-plotter (member sel-plotter plotters))
  633.           (set_tile "pop_printer" (itoa (vl-position sel-plotter plotters)))
  634.         )
  635.         
  636.         (if (and sel-style (member sel-style styles))
  637.           (set_tile "pop_style" (itoa (vl-position sel-style styles)))
  638.         )
  639.         
  640.         (defun update-media-list (idx)
  641.           (if (and plotters (< (atoi idx) (length plotters)))
  642.             (progn
  643.               (setq sel-plotter (nth (atoi idx) plotters))
  644.               (setq media-list (get-media-names sel-plotter))
  645.               (start_list "pop_media")
  646.               (if media-list
  647.                 (mapcar 'add_list media-list)
  648.                 (add_list "无可用纸张")
  649.               )
  650.               (end_list)
  651.               (if (and media-list sel-media (member sel-media media-list))
  652.                 (set_tile "pop_media" (itoa (vl-position sel-media media-list)))
  653.                 (if media-list (setq sel-media (car media-list)))
  654.               )
  655.             )
  656.           )
  657.         )
  658.         
  659.         (update-media-list
  660.           (if (and sel-plotter (member sel-plotter plotters))
  661.             (itoa (vl-position sel-plotter plotters))
  662.             "0"
  663.           )
  664.         )
  665.         
  666.         (action_tile "btn_pick" "(done_dialog 2)")
  667.         (action_tile "btn_browse" "(done_dialog 3)")
  668.         (action_tile "btn_load" "(done_dialog 7)")
  669.         (action_tile "btn_add" "(done_dialog 4)")
  670.         (action_tile "btn_remove" "(done_dialog 5)")
  671.         (action_tile "btn_clear" "(done_dialog 6)")
  672.         
  673.         (action_tile "lst_files"
  674.           "(progn (setq selected-file-idx (atoi $value)) (update-path-display selected-file-idx))"
  675.         )
  676.         
  677.         (action_tile "txt_path" "(setq input-path $value)")
  678.         
  679.         (action_tile "pop_printer" "(update-media-list $value)")
  680.         (action_tile "pop_style" "(setq sel-style (nth (atoi $value) styles))")
  681.         (action_tile "pop_media" "(if media-list (setq sel-media (nth (atoi $value) media-list)))")
  682.         (action_tile "txt_block" "(setq sel-block $value)")
  683.         (action_tile "txt_factor" "(setq sel-factor $value)")
  684.         
  685.         (action_tile "pop_scale"
  686.           (strcat
  687.             "(cond ((= $value "0") (setq sel-scale "ScaleToFit"))"
  688.             "      ((= $value "1") (setq sel-scale "Auto"))"
  689.             "      ((= $value "2") (setq sel-scale "1:1")))"
  690.             "(update-factor-state sel-scale)"
  691.           )
  692.         )
  693.         
  694.         (action_tile "accept" "(setq input-path (get_tile "txt_path"))(done_dialog 1)")
  695.         (action_tile "cancel" "(done_dialog 0)")
  696.         
  697.         (setq result (start_dialog))
  698.         
  699.         (cond
  700.           ((= result 1)
  701.            (setq loop nil)
  702.            (if (null sel-scale) (setq sel-scale "ScaleToFit"))
  703.            (save-settings)
  704.            
  705.            (if (and file-list
  706.                     (> (length file-list) 0)
  707.                     sel-block (/= sel-block "")
  708.                     sel-media)
  709.              (progn
  710.                (setq temp-dir "C:\\BatchPlotTemp")
  711.                
  712.                (princ "\n======================================")
  713.                (princ "\n[批量打印 V1.0] 准备中...")
  714.                (princ (strcat "\n文件数: " (itoa (length file-list))))
  715.                (princ (strcat "\n图框: " sel-block))
  716.                (princ (strcat "\n比例: " sel-scale))
  717.                (princ "\n======================================")
  718.                
  719.                (if (prepare-temp-env file-list temp-dir)
  720.                  (progn
  721.                    (setq worker-path (strcat temp-dir "\\BP_Worker.lsp"))
  722.                    (setq scr-path (strcat temp-dir "\\BP_Job.scr"))
  723.                    (setq factor-num (atof sel-factor))
  724.                    (if (or (= factor-num 0.0) (< factor-num 0.1))
  725.                      (setq factor-num 1.0)
  726.                    )
  727.                   
  728.                    (princ "\n生成Worker...")
  729.                    (if (generate-worker-lsp worker-path sel-block sel-plotter sel-style sel-media sel-scale factor-num)
  730.                      (progn
  731.                        (princ " OK")
  732.                        (princ "\n生成脚本...")
  733.                        
  734.                        (if (generate-scr-file scr-path worker-path temp-dir file-list)
  735.                          (progn
  736.                            (princ " OK")
  737.                            (unload_dialog dcl-id)
  738.                            (setq dcl-id nil)
  739.                            (princ "\n启动打印...")
  740.                            (command "_.SCRIPT" scr-path)
  741.                          )
  742.                          (alert "脚本生成失败!")
  743.                        )
  744.                      )
  745.                      (alert "Worker生成失败!")
  746.                    )
  747.                  )
  748.                  (alert "准备临时环境失败!\n请检查磁盘空间和权限。")
  749.                )
  750.              )
  751.              (alert "请检查:\n- 文件列表不能为空\n- 必须填写图框块名\n- 必须选择纸张")
  752.            )
  753.           )
  754.          
  755.           ((= result 2)
  756.            (setq temp (pick-block))
  757.            (if (and temp (/= temp ""))
  758.              (if (and sel-block (/= sel-block ""))
  759.                (setq sel-block (strcat sel-block ";" temp))
  760.                (setq sel-block temp)
  761.              )
  762.            )
  763.           )
  764.          
  765.           ((= result 3)
  766.            (setq temp (browse-folder "选择DWG文件夹"))
  767.            (if temp
  768.              (setq input-path temp)
  769.            )
  770.           )
  771.          
  772.           ((= result 4)
  773.            (setq temp (browse-single-file))
  774.            (if temp
  775.              (progn
  776.                (if (add-file-to-list temp)
  777.                  (progn
  778.                    (setq input-path temp)
  779.                    (princ (strcat "\n已添加: " (vl-filename-base temp)))
  780.                  )
  781.                  (princ "\n文件已存在或无效")
  782.                )
  783.              )
  784.            )
  785.           )
  786.          
  787.           ((= result 5)
  788.            (if (and selected-file-idx (>= selected-file-idx 0) (< selected-file-idx (length file-list)))
  789.              (progn
  790.                (princ (strcat "\n已删除: " (vl-filename-base (nth selected-file-idx file-list))))
  791.                (remove-selected-file selected-file-idx)
  792.                (setq selected-file-idx nil)
  793.              )
  794.              (alert "请先选择要删除的文件")
  795.            )
  796.           )
  797.          
  798.           ((= result 6)
  799.            (setq file-list nil)
  800.            (setq selected-file-idx nil)
  801.            (setq input-path "")
  802.            (princ "\n文件列表已清空")
  803.           )
  804.          
  805.           ((= result 7)
  806.            (load-from-input-path input-path)
  807.           )
  808.          
  809.           ((= result 0) (setq loop nil))
  810.         )
  811.       )
  812.     )
  813.   )
  814.   
  815.   (if dcl-id (unload_dialog dcl-id))
  816.   (if (and dcl-file (findfile dcl-file)) (vl-file-delete dcl-file))
  817.   (princ)
  818. )


用到了SCR 函数。会在c盘创建临时的文件夹，打印的cad文档会复制到临时文件。每次启动会检查若存在临时文件则删除重新创建，避免错误！



网友答: 建议再加个设置透明度打印，第二个纸图幅大小根据文件自动判断

网友答: 2016版本提示错误: 输入中的点位置不正确  ai越来越火了

网友答: 目前多文档批量打印的还真不多见，赞

网友答: 厉害了兄得

网友答: 厉害。兄弟厉害，AI也厉害。试试

网友答: 看起来很厉害的样子

网友答: 厉害了兄得


网友答: acad加载后提示命令: (LOAD "F:/资源/bplot.lsp") ; 错误: 输入中的点位置不正确。中望cad加载后提示：Error: 输入的列表有缺陷

网友答:
xsmabbs 发表于 2025-11-30 21:25
2016版本提示错误: 输入中的点位置不正确  ai越来越火了

我用的是cad2024没有问题。
代码修复了，测试的cad2008和cad2024.其他版本cad没有，没有测试。
注意：cad2008，保存为.lsp时，要保存为 ANSI 格式

ai分析的：
主要修改点
位置        修改内容        目的
generate-scr-file        使用 (setvar ...) 替代命令行方式        更可靠的变量设置
generate-scr-file        添加 (if (getvar "SECURELOAD") ...)        CAD 2008无此变量
generate-scr-file        添加 DEMANDLOAD 条件设置        防止按需加载干扰
generate-scr-file        DELAY 增加到 300/100        CAD 2008 响应较慢
generate-worker-lsp        BACKGROUNDPLOT 条件检测        兼容旧版本
版本号        V1.0 → V1.1        标识修复版本
  2. (defun c:BPLOT (/ *error* dcl-file dcl-id result
  3.                   get-plotters get-styles get-media-names
  4.                   update-media-list update-file-list write-dcl browse-folder
  5.                   valid-folder-p save-settings load-settings
  6.                   generate-worker-lsp generate-scr-file
  7.                   smart-sort path-slash prepare-temp-env
  8.                   remove-selected-file browse-single-file
  9.                   plotters styles media-list pick-block
  10.                   sel-block sel-plotter sel-style sel-media sel-scale sel-factor
  11.                   sel-folder file-list selected-file-idx
  12.                   acad-obj doc clayout reg-path factor-num
  13.                   worker-path scr-path temp loop temp-dir input-path)

  15.   (vl-load-com)
  16.   
  17.   (setq acad-obj (vlax-get-acad-object))
  18.   (setq doc (vla-get-ActiveDocument acad-obj))
  19.   (setq clayout (vla-get-ActiveLayout doc))
  20.   (setq reg-path "HKEY_CURRENT_USER\\Software\\BatchPlotTool_SCR")
  21.   (setq file-list nil)
  22.   (setq selected-file-idx nil)
  23.   (setq input-path "")

  25.   (defun *error* (msg)
  26.     (if dcl-id (unload_dialog dcl-id))
  27.     (if (and dcl-file (findfile dcl-file)) (vl-file-delete dcl-file))
  28.     (if (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*")))
  29.       (princ (strcat "\n错误: " msg))
  30.     )
  31.     (princ)
  32.   )

  34.   (defun path-slash (path)
  35.     (while (vl-string-search "\" path)
  36.       (setq path (vl-string-subst "/" "\" path))
  37.     )
  38.     path
  39.   )

  41.   (defun extract-number (s / i len c num found)
  42.     (setq i 1 len (strlen s) num "" found nil)
  43.     (while (and (<= i len) (not (wcmatch (substr s i 1) "#")))
  44.       (setq i (1+ i))
  45.     )
  46.     (while (and (<= i len) (wcmatch (setq c (substr s i 1)) "#"))
  47.       (setq num (strcat num c) i (1+ i) found T)
  48.     )
  49.     (if found (atoi num) 999999)
  50.   )

  52.   (defun smart-sort (lst)
  53.     (vl-sort lst
  54.       (function (lambda (a b / na nb)
  55.         (setq na (extract-number a) nb (extract-number b))
  56.         (if (= na nb) (< a b) (< na nb))
  57.       ))
  58.     )
  59.   )

  61.   (defun smart-sort-paths (lst)
  62.     (vl-sort lst
  63.       (function (lambda (a b / na nb)
  64.         (setq na (extract-number (vl-filename-base a)))
  65.         (setq nb (extract-number (vl-filename-base b)))
  66.         (if (= na nb)
  67.           (< (strcase (vl-filename-base a)) (strcase (vl-filename-base b)))
  68.           (< na nb)
  69.         )
  70.       ))
  71.     )
  72.   )

  74.   (defun prepare-temp-env (file-list temp-dir / fso src-path temp-path file-obj attrs copied-count fname)
  75.     (setq fso (vlax-create-object "Scripting.FileSystemObject"))
  76.     (if (vlax-invoke fso 'FolderExists temp-dir)
  77.       (vl-catch-all-apply 'vlax-invoke (list fso 'DeleteFolder temp-dir :vlax-true))
  78.     )
  79.     (vl-mkdir temp-dir)
  80.     (setq copied-count 0)
  81.     (if file-list
  82.       (progn
  83.         (princ "\n[系统] 正在初始化临时环境...")
  84.         (foreach src-path file-list
  85.           (setq fname (vl-filename-base src-path))
  86.           (setq temp-path (strcat temp-dir "\" fname ".dwg"))
  87.           (if (vl-file-copy src-path temp-path)
  88.             (progn
  89.               (setq file-obj (vl-catch-all-apply 'vlax-invoke (list fso 'GetFile temp-path)))
  90.               (if (and file-obj (not (vl-catch-all-error-p file-obj)))
  91.                 (progn
  92.                   (setq attrs (vlax-get file-obj 'Attributes))
  93.                   (if (= (logand attrs 1) 1)
  94.                     (vlax-put file-obj 'Attributes (logand attrs 65534))
  95.                   )
  96.                   (vlax-release-object file-obj)
  97.                 )
  98.               )
  99.               (setq copied-count (1+ copied-count))
  100.               (princ (strcat "\n  -> 副本就绪: " fname ".dwg"))
  101.             )
  102.           )
  103.         )
  104.       )
  105.     )
  106.     (if fso (vlax-release-object fso))
  107.     (> copied-count 0)
  108.   )

  110.   (defun get-plotters ()
  111.     (vla-RefreshPlotDeviceInfo clayout)
  112.     (vlax-safearray->list (vlax-variant-value (vla-GetPlotDeviceNames clayout)))
  113.   )
  114.   
  115.   (defun get-styles ()
  116.     (vla-RefreshPlotDeviceInfo clayout)
  117.     (vlax-safearray->list (vlax-variant-value (vla-GetPlotStyleTableNames clayout)))
  118.   )
  119.   
  120.   (defun get-media-names (plotter / media err)
  121.     (setq media nil)
  122.     (if (and plotter (/= plotter ""))
  123.       (progn
  124.         (setq err (vl-catch-all-apply 'vla-put-ConfigName (list clayout plotter)))
  125.         (if (not (vl-catch-all-error-p err))
  126.           (progn
  127.             (vla-RefreshPlotDeviceInfo clayout)
  128.             (setq media (vl-catch-all-apply
  129.               (function (lambda ()
  130.                 (vlax-safearray->list (vlax-variant-value (vla-GetCanonicalMediaNames clayout)))
  131.               ))
  132.               nil
  133.             ))
  134.             (if (vl-catch-all-error-p media) (setq media nil))
  135.           )
  136.         )
  137.       )
  138.     )
  139.     media
  140.   )
  141.   
  142.   (defun browse-folder (msg / sh folder folderobj path)
  143.     (setq path nil)
  144.     (setq sh (vla-getInterfaceObject acad-obj "Shell.Application"))
  145.     (if sh
  146.       (progn
  147.         (setq folder (vl-catch-all-apply 'vlax-invoke-method (list sh 'BrowseForFolder 0 msg 0)))
  148.         (if (and folder (not (vl-catch-all-error-p folder)))
  149.           (progn
  150.             (setq folderobj (vlax-get-property folder 'Self))
  151.             (setq path (vlax-get-property folderobj 'Path))
  152.             (vlax-release-object folderobj)
  153.             (vlax-release-object folder)
  154.           )
  155.         )
  156.         (vlax-release-object sh)
  157.       )
  158.     )
  159.     (if (and path (> (strlen path) 0))
  160.       (if (/= (substr path (strlen path) 1) "\")
  161.         (setq path (strcat path "\"))
  162.       )
  163.     )
  164.     path
  165.   )

  167.   (defun browse-single-file ()
  168.     (getfiled "选择DWG文件" "" "dwg" 4)
  169.   )
  170.   
  171.   (defun valid-folder-p (folder)
  172.     (and folder (= (type folder) 'STR) (> (strlen folder) 0))
  173.   )
  174.   
  175.   (defun pick-block (/ ent obj name)
  176.     (setq name nil)
  177.     (princ "\n选择图框块...")
  178.     (while (null name)
  179.       (setq ent (car (entsel "\n点击选择图框块: ")))
  180.       (if ent
  181.         (progn
  182.           (setq obj (vlax-ename->vla-object ent))
  183.           (if (= (vla-get-ObjectName obj) "AcDbBlockReference")
  184.             (if (vlax-property-available-p obj 'EffectiveName)
  185.               (setq name (vla-get-EffectiveName obj))
  186.               (setq name (vla-get-Name obj))
  187.             )
  188.             (princ "\n不是块引用")
  189.           )
  190.         )
  191.         (setq name "")
  192.       )
  193.     )
  194.     name
  195.   )
  196.   
  197.   (defun save-settings ()
  198.     (vl-registry-write reg-path "Block" (if sel-block sel-block ""))
  199.     (vl-registry-write reg-path "Printer" (if sel-plotter sel-plotter ""))
  200.     (vl-registry-write reg-path "Style" (if sel-style sel-style ""))
  201.     (vl-registry-write reg-path "Media" (if sel-media sel-media ""))
  202.     (vl-registry-write reg-path "Scale" (if sel-scale sel-scale "ScaleToFit"))
  203.     (vl-registry-write reg-path "Factor" (if sel-factor sel-factor "1.0"))
  204.     (vl-registry-write reg-path "Folder" (if sel-folder sel-folder ""))
  205.   )
  206.   
  207.   (defun load-settings ()
  208.     (setq sel-block (vl-registry-read reg-path "Block"))
  209.     (setq sel-plotter (vl-registry-read reg-path "Printer"))
  210.     (setq sel-style (vl-registry-read reg-path "Style"))
  211.     (setq sel-media (vl-registry-read reg-path "Media"))
  212.     (setq sel-scale (vl-registry-read reg-path "Scale"))
  213.     (setq sel-factor (vl-registry-read reg-path "Factor"))
  214.     (setq sel-folder (vl-registry-read reg-path "Folder"))
  215.     (if (or (not sel-scale) (= sel-scale "")) (setq sel-scale "ScaleToFit"))
  216.     (if (or (not sel-factor) (= sel-factor "")) (setq sel-factor "1.0"))
  217.   )

  219.   (defun load-folder-files (folder / files full-path)
  220.     (if (valid-folder-p folder)
  221.       (progn
  222.         (if (= (substr folder (strlen folder) 1) "\")
  223.           (setq folder (substr folder 1 (1- (strlen folder))))
  224.         )
  225.         (setq files (vl-directory-files folder "*.dwg" 1))
  226.         (setq files (smart-sort files))
  227.         (setq file-list nil)
  228.         (foreach f files
  229.           (setq full-path (strcat folder "\" f))
  230.           (setq file-list (append file-list (list full-path)))
  231.         )
  232.       )
  233.     )
  234.     file-list
  235.   )

  237.   (defun update-file-list-display ()
  238.     (start_list "lst_files")
  239.     (if file-list
  240.       (foreach f file-list
  241.         (add_list (strcat (vl-filename-base f) ".dwg"))
  242.       )
  243.       (add_list "(空)")
  244.     )
  245.     (end_list)
  246.     (set_tile "txt_count" (strcat "共 " (itoa (length file-list)) " 个文件"))
  247.   )

  249.   (defun update-path-display (idx)
  250.     (if (and file-list idx (>= idx 0) (< idx (length file-list)))
  251.       (progn
  252.         (setq input-path (nth idx file-list))
  253.         (set_tile "txt_path" input-path)
  254.       )
  255.     )
  256.   )

  258.   (defun remove-selected-file (idx / i new-list)
  259.     (if (and idx (>= idx 0) (< idx (length file-list)))
  260.       (progn
  261.         (setq i 0 new-list nil)
  262.         (foreach f file-list
  263.           (if (/= i idx)
  264.             (setq new-list (append new-list (list f)))
  265.           )
  266.           (setq i (1+ i))
  267.         )
  268.         (setq file-list new-list)
  269.       )
  270.     )
  271.   )

  273.   (defun add-file-to-list (filepath)
  274.     (if (and filepath
  275.              (findfile filepath)
  276.              (wcmatch (strcase filepath) "*.DWG")
  277.              (not (member filepath file-list)))
  278.       (progn
  279.         (setq file-list (append file-list (list filepath)))
  280.         (setq file-list (smart-sort-paths file-list))
  281.         T
  282.       )
  283.       nil
  284.     )
  285.   )

  287.   (defun load-from-input-path (path / clean-path)
  288.     (if (and path (/= path ""))
  289.       (progn
  290.         (setq clean-path (vl-string-trim " \t" path))
  291.         (if (= (substr clean-path (strlen clean-path) 1) "\")
  292.           (setq clean-path (substr clean-path 1 (1- (strlen clean-path))))
  293.         )
  294.         (cond
  295.           ((and (wcmatch (strcase clean-path) "*.DWG") (findfile clean-path))
  296.            (if (add-file-to-list clean-path)
  297.              (progn (princ (strcat "\n已添加文件: " (vl-filename-base clean-path))) T)
  298.              (progn (princ "\n文件已存在或无效") nil)
  299.            )
  300.           )
  301.           ((vl-file-directory-p clean-path)
  302.            (setq sel-folder (strcat clean-path "\"))
  303.            (load-folder-files sel-folder)
  304.            (if file-list
  305.              (progn (princ (strcat "\n已从文件夹加载 " (itoa (length file-list)) " 个文件")) T)
  306.              (progn (princ "\n文件夹中没有DWG文件") nil)
  307.            )
  308.           )
  309.           (T (alert (strcat "无效路径:\n" clean-path)) nil)
  310.         )
  311.       )
  312.       nil
  313.     )
  314.   )

  316.   (defun update-factor-state (scale-mode)
  317.     (if (= scale-mode "ScaleToFit")
  318.       (mode_tile "txt_factor" 0)
  319.       (mode_tile "txt_factor" 1)
  320.     )
  321.   )

  323.   (defun generate-worker-lsp (filepath block printer style media scale-mode factor / f)
  324.     (setq f (open filepath "w"))
  325.     (if f
  326.       (progn
  327.         (write-line ";; BatchPlot Worker V1.1" f)
  328.         (write-line "(princ "\\n[Worker] 加载中...")" f)
  329.         (write-line "" f)
  330.         (write-line "(defun ss->list (ss / n lst)" f)
  331.         (write-line "  (if ss (repeat (setq n (sslength ss)) (setq lst (cons (ssname ss (setq n (1- n))) lst)))) lst)" f)
  332.         (write-line "" f)
  333.         (write-line "(defun ax:2dpoint (pt / arr)" f)
  334.         (write-line "  (setq arr (vlax-make-safearray vlax-vbdouble (cons 0 1)))" f)
  335.         (write-line "  (vlax-safearray-put-element arr 0 (float (car pt)))" f)
  336.         (write-line "  (vlax-safearray-put-element arr 1 (float (cadr pt)))" f)
  337.         (write-line "  (vlax-make-variant arr))" f)
  338.         (write-line "" f)
  339.         (write-line "(defun shrink-bounding (bd factor / ll ur cx cy hw hh)" f)
  340.         (write-line "  (setq ll (car bd) ur (cadr bd))" f)
  341.         (write-line "  (setq cx (/ (+ (car ll) (car ur)) 2.0))" f)
  342.         (write-line "  (setq cy (/ (+ (cadr ll) (cadr ur)) 2.0))" f)
  343.         (write-line "  (setq hw (/ (- (car ur) (car ll)) 2.0 factor))" f)
  344.         (write-line "  (setq hh (/ (- (cadr ur) (cadr ll)) 2.0 factor))" f)
  345.         (write-line "  (list (list (- cx hw) (- cy hh)) (list (+ cx hw) (+ cy hh))))" f)
  346.         (write-line "" f)
  347.         (write-line "(defun islandscape (bd)" f)
  348.         (write-line "  (> (abs (- (caadr bd) (caar bd))) (abs (- (cadadr bd) (cadar bd)))))" f)
  349.         (write-line "" f)
  350.         (write-line "(defun getwidth (bd)" f)
  351.         (write-line "  (max (abs (- (caadr bd) (caar bd))) (abs (- (cadadr bd) (cadar bd)))))" f)
  352.         (write-line "" f)
  353.         (write-line "(defun fixscale (n / i large)" f)
  354.         (write-line "  (setq i 0 large (> n 100))" f)
  355.         (write-line "  (while (or (> n 100) (< n 10))" f)
  356.         (write-line "    (if large (setq n (/ n 10.0)) (setq n (* n 10.0)))" f)
  357.         (write-line "    (setq i (1+ i)))" f)
  358.         (write-line "  (setq n (fix (+ 0.5 n)))" f)
  359.         (write-line "  (repeat i (if large (setq n (* n 10.0)) (setq n (/ n 10.0)))) n)" f)
  360.         (write-line "" f)
  361.         (write-line "(defun sort-frames (bdlist / fuzz)" f)
  362.         (write-line "  (setq fuzz 10.0)" f)
  363.         (write-line "  (vl-sort bdlist" f)
  364.         (write-line "    (function (lambda (a b)" f)
  365.         (write-line "      (if (equal (caar a) (caar b) fuzz)" f)
  366.         (write-line "        (> (cadar a) (cadar b))" f)
  367.         (write-line "        (< (caar a) (caar b)))))))" f)
  368.         (write-line "" f)
  369.         (write-line "(defun str-split (str delim / lst pos)" f)
  370.         (write-line "  (while (setq pos (vl-string-search delim str))" f)
  371.         (write-line "    (if (> pos 0) (setq lst (cons (substr str 1 pos) lst)))" f)
  372.         (write-line "    (setq str (substr str (+ 2 pos))))" f)
  373.         (write-line "  (if (/= str "") (setq lst (cons str lst)))" f)
  374.         (write-line "  (reverse lst))" f)
  375.         (write-line "" f)
  376.         (write-line "(defun process-layout (doc lay lay-name cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor /" f)
  377.         (write-line "         ss elist obj name minpt maxpt bdlist pW pH paperW i plot-bd scale frame-w target-list)" f)
  378.         (write-line "  (princ (strcat "\\n[" lay-name "]"))" f)
  379.         (write-line "  (if (vl-string-search ";" cfg-block)" f)
  380.         (write-line "    (setq target-list (mapcar (function strcase) (str-split cfg-block ";")))" f)
  381.         (write-line "    (setq target-list (list (strcase cfg-block))))" f)
  382.         (write-line "  (vla-ZoomExtents (vlax-get-acad-object))" f)
  383.         (write-line "  (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 410 lay-name))))" f)
  384.         (write-line "  (if ss" f)
  385.         (write-line "    (progn" f)
  386.         (write-line "      (setq elist (ss->list ss) bdlist nil)" f)
  387.         (write-line "      (foreach ent elist" f)
  388.         (write-line "        (setq obj (vlax-ename->vla-object ent))" f)
  389.         (write-line "        (setq name (if (vlax-property-available-p obj 'EffectiveName)" f)
  390.         (write-line "                     (vla-get-EffectiveName obj) (vla-get-Name obj)))" f)
  391.         (write-line "        (if (member (strcase name) target-list)" f)
  392.         (write-line "          (if (not (vl-catch-all-error-p" f)
  393.         (write-line "                (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'minpt 'maxpt))))" f)
  394.         (write-line "            (progn" f)
  395.         (write-line "              (setq minpt (vlax-safearray->list minpt))" f)
  396.         (write-line "              (setq maxpt (vlax-safearray->list maxpt))" f)
  397.         (write-line "              (setq bdlist (cons (list (list (car minpt) (cadr minpt))" f)
  398.         (write-line "                                       (list (car maxpt) (cadr maxpt))) bdlist))))))))" f)
  399.         (write-line "  (if bdlist" f)
  400.         (write-line "    (progn" f)
  401.         (write-line "      (setq bdlist (sort-frames bdlist))" f)
  402.         (write-line "      (princ (strcat " 找到 " (itoa (length bdlist)) " 个图框"))" f)
  403.         (write-line "      (vl-catch-all-apply 'vla-put-ActiveLayout (list doc lay))" f)
  404.         (write-line "      (vla-RefreshPlotDeviceInfo lay)" f)
  405.         (write-line "      (vl-catch-all-apply 'vla-put-ConfigName (list lay cfg-printer))" f)
  406.         (write-line "      (vla-RefreshPlotDeviceInfo lay)" f)
  407.         (write-line "      (vl-catch-all-apply 'vla-put-CanonicalMediaName (list lay cfg-media))" f)
  408.         (write-line "      (if (/= cfg-style "")" f)
  409.         (write-line "        (vl-catch-all-apply 'vla-put-StyleSheet (list lay cfg-style)))" f)
  410.         (write-line "      (vla-put-PaperUnits lay 1)" f)
  411.         (write-line "      (vla-GetPaperSize lay 'pW 'pH)" f)
  412.         (write-line "      (setq paperW (max pW pH) i 0)" f)
  413.         (write-line "      (foreach bd bdlist" f)
  414.         (write-line "        (setq i (1+ i))" f)
  415.         (write-line "        (princ (strcat "\\n  打印[" (itoa i) "/" (itoa (length bdlist)) "]"))" f)
  416.         (write-line "        (if (and (= cfg-scale-mode "ScaleToFit") (/= cfg-factor 1.0))" f)
  417.         (write-line "          (setq plot-bd (shrink-bounding bd cfg-factor))" f)
  418.         (write-line "          (setq plot-bd bd))" f)
  419.         (write-line "        (if (= (islandscape bd) (> pW pH))" f)
  420.         (write-line "          (vla-put-PlotRotation lay 0)" f)
  421.         (write-line "          (vla-put-PlotRotation lay 1))" f)
  422.         (write-line "        (vla-SetWindowToPlot lay (ax:2dpoint (car plot-bd)) (ax:2dpoint (cadr plot-bd)))" f)
  423.         (write-line "        (vla-put-PlotType lay 4)" f)
  424.         (write-line "        (vla-put-CenterPlot lay :vlax-true)" f)
  425.         (write-line "        (cond" f)
  426.         (write-line "          ((= cfg-scale-mode "ScaleToFit")" f)
  427.         (write-line "           (vla-put-UseStandardScale lay :vlax-true)" f)
  428.         (write-line "           (vla-put-StandardScale lay 0))" f)
  429.         (write-line "          ((= cfg-scale-mode "1:1")" f)
  430.         (write-line "           (vla-put-UseStandardScale lay :vlax-false)" f)
  431.         (write-line "           (vla-SetCustomScale lay 1.0 1.0))" f)
  432.         (write-line "          ((= cfg-scale-mode "Auto")" f)
  433.         (write-line "           (setq frame-w (getwidth bd))" f)
  434.         (write-line "           (setq scale (fixscale (/ frame-w paperW)))" f)
  435.         (write-line "           (vla-put-UseStandardScale lay :vlax-false)" f)
  436.         (write-line "           (vla-SetCustomScale lay 1.0 scale)))" f)
  437.         (write-line "        (if (vl-catch-all-error-p" f)
  438.         (write-line "              (vl-catch-all-apply 'vla-PlotToDevice (list (vla-get-Plot doc))))" f)
  439.         (write-line "          (princ " X")" f)
  440.         (write-line "          (princ " OK"))))" f)
  441.         (write-line "    (princ " 无匹配图框")))" f)
  442.         (write-line "" f)
  443.         (write-line "(defun c:AutoRunBatchPlot (/ acad doc layouts lay layout-list)" f)
  444.         (write-line "  (vl-load-com)" f)
  445.         (write-line "  (setq acad (vlax-get-acad-object))" f)
  446.         (write-line "  (setq doc (vla-get-ActiveDocument acad))" f)
  447.         (write-line "  (setq layouts (vla-get-Layouts doc))" f)
  448.         (write-line "  (if (getvar "BACKGROUNDPLOT") (setvar "BACKGROUNDPLOT" 0))" f)
  449.         (write-line (strcat "  (setq cfg-block "" block "")") f)
  450.         (write-line (strcat "  (setq cfg-printer "" printer "")") f)
  451.         (write-line (strcat "  (setq cfg-style "" style "")") f)
  452.         (write-line (strcat "  (setq cfg-media "" media "")") f)
  453.         (write-line (strcat "  (setq cfg-scale-mode "" scale-mode "")") f)
  454.         (write-line (strcat "  (setq cfg-factor " (rtos factor 2 6) ")") f)
  455.         (write-line "  (process-layout doc (vla-Item layouts "Model") "Model"" f)
  456.         (write-line "    cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor)" f)
  457.         (write-line "  (setq layout-list nil)" f)
  458.         (write-line "  (vlax-for lay layouts" f)
  459.         (write-line "    (if (/= (vla-get-Name lay) "Model")" f)
  460.         (write-line "      (setq layout-list (cons lay layout-list))))" f)
  461.         (write-line "  (setq layout-list (vl-sort layout-list" f)
  462.         (write-line "    (function (lambda (a b) (< (vla-get-TabOrder a) (vla-get-TabOrder b))))))" f)
  463.         (write-line "  (foreach lay layout-list" f)
  464.         (write-line "    (process-layout doc lay (vla-get-Name lay)" f)
  465.         (write-line "      cfg-block cfg-printer cfg-style cfg-media cfg-scale-mode cfg-factor))" f)
  466.         (write-line "  (princ "\\n--- 当前文件完成 ---")" f)
  467.         (write-line "  (princ))" f)
  468.         (write-line "" f)
  469.         (write-line "(c:AutoRunBatchPlot)" f)
  470.         (close f)
  471.         filepath
  472.       )
  473.       nil
  474.     )
  475.   )

  477.   (defun generate-scr-file (scr-path worker-path temp-dir file-list / f fname full-path)
  478.     (setq worker-path (path-slash worker-path))
  479.     (if file-list
  480.       (progn
  481.         (setq f (open scr-path "w"))
  482.         (if f
  483.           (progn
  484.             (write-line "(setvar "SDI" 0)" f)
  485.             (write-line "(setvar "FILEDIA" 0)" f)
  486.             (write-line "(setvar "CMDECHO" 0)" f)
  487.             (write-line "(if (getvar "SECURELOAD") (setvar "SECURELOAD" 0))" f)
  488.             (write-line "(if (getvar "XREFNOTIFY") (setvar "XREFNOTIFY" 0))" f)
  489.             (write-line "(if (getvar "PROXYNOTICE") (setvar "PROXYNOTICE" 0))" f)
  490.             (foreach file file-list
  491.               (setq fname (vl-filename-base file))
  492.               (setq full-path (strcat temp-dir "\" fname ".dwg"))
  493.               (setq full-path (path-slash full-path))
  494.               (write-line (strcat "_.OPEN "" full-path """) f)
  495.               (write-line "_.DELAY 300" f)
  496.               (write-line (strcat "(if (findfile "" worker-path "") (load "" worker-path ""))") f)
  497.               (write-line "_.DELAY 100" f)
  498.               (write-line "_.CLOSE _N" f)
  499.             )
  500.             (write-line "(setvar "FILEDIA" 1)" f)
  501.             (write-line "(setvar "CMDECHO" 1)" f)
  502.             (write-line "(if (getvar "SECURELOAD") (setvar "SECURELOAD" 1))" f)
  503.             (write-line "(princ "\\n==============================")" f)
  504.             (write-line "(princ "\\n  批量打印全部完成!")" f)
  505.             (write-line "(princ "\\n==============================")" f)
  506.             (write-line "(princ)" f)
  507.             (close f)
  508.             T
  509.           )
  510.           nil
  511.         )
  512.       )
  513.       nil
  514.     )
  515.   )

  517.   ;; ========== DCL 中文界面 ==========
  518.   (defun write-dcl (filename / f)
  519.     (setq f (open filename "w"))
  520.     (if f
  521.       (progn
  522.         (write-line "batchplot : dialog {" f)
  523.         (write-line "  label = "批量打印 V1.1";" f)
  524.         (write-line "  : row {" f)
  525.         (write-line "    : boxed_column {" f)
  526.         (write-line "      label = "待打印文件";" f)
  527.         (write-line "      : row {" f)
  528.         (write-line "        : edit_box { key = "txt_path"; width = 30; edit_limit = 512; }" f)
  529.         (write-line "        : button { label = "..."; key = "btn_browse"; width = 3; fixed_width = true; }" f)
  530.         (write-line "      }" f)
  531.         (write-line "      : row {" f)
  532.         (write-line "        : button { label = "加载路径"; key = "btn_load"; width = 10; }" f)
  533.         (write-line "        : button { label = "添加文件"; key = "btn_add"; width = 10; }" f)
  534.         (write-line "        : button { label = "清空"; key = "btn_clear"; width = 6; }" f)
  535.         (write-line "      }" f)
  536.         (write-line "      : list_box { key = "lst_files"; width = 36; height = 15; multiple_select = false; }" f)
  537.         (write-line "      : row {" f)
  538.         (write-line "        : text { key = "txt_count"; label = "共 0 个文件"; width = 16; }" f)
  539.         (write-line "        : button { label = "删除选中"; key = "btn_remove"; width = 10; }" f)
  540.         (write-line "      }" f)
  541.         (write-line "    }" f)
  542.         (write-line "    : column {" f)
  543.         (write-line "      : boxed_column {" f)
  544.         (write-line "        label = "图框设置";" f)
  545.         (write-line "        : row {" f)
  546.         (write-line "          : edit_box { label = "块名:"; key = "txt_block"; width = 22; }" f)
  547.         (write-line "          : button { label = "拾取"; key = "btn_pick"; width = 6; }" f)
  548.         (write-line "        }" f)
  549.         (write-line "        : text { label = "多个块名用分号;分隔"; }" f)
  550.         (write-line "      }" f)
  551.         (write-line "      : boxed_column {" f)
  552.         (write-line "        label = "打印机设置";" f)
  553.         (write-line "        : popup_list { label = "打印机:"; key = "pop_printer"; width = 32; }" f)
  554.         (write-line "        : popup_list { label = "样式表:"; key = "pop_style"; width = 32; }" f)
  555.         (write-line "        : popup_list { label = "纸张:  "; key = "pop_media"; width = 32; }" f)
  556.         (write-line "      }" f)
  557.         (write-line "      : boxed_column {" f)
  558.         (write-line "        label = "比例设置";" f)
  559.         (write-line "        : popup_list { label = "比例:"; key = "pop_scale"; width = 18; }" f)
  560.         (write-line "        : edit_box { label = "放大系数:"; key = "txt_factor"; width = 12; }" f)
  561.         (write-line "        : text { label = "(放大系数仅布满图纸时有效)"; }" f)
  562.         (write-line "      }" f)
  563.         (write-line "      : boxed_column {" f)
  564.         (write-line "        label = "使用说明";" f)
  565.         (write-line "        : text { label = "1. 路径栏可粘贴文件夹或DWG路径"; }" f)
  566.         (write-line "        : text { label = "2. 点击[加载路径]导入文件"; }" f)
  567.         (write-line "        : text { label = "3. 选中列表项可查看完整路径"; }" f)
  568.         (write-line "      }" f)
  569.         (write-line "    }" f)
  570.         (write-line "  }" f)
  571.         (write-line "  spacer_1;" f)
  572.         (write-line "  ok_cancel;" f)
  573.         (write-line "}" f)
  574.         (close f)
  575.         T
  576.       )
  577.       nil
  578.     )
  579.   )

  581.   ;; ========== 主程序 ==========
  582.   (load-settings)
  583.   (setq plotters (get-plotters))
  584.   (setq styles (get-styles))
  585.   (setq dcl-file (vl-filename-mktemp "bp_scr" nil ".dcl"))
  586.   (write-dcl dcl-file)
  587.   (setq dcl-id (load_dialog dcl-file))
  588.   (setq loop T)
  589.   
  590.   (if (valid-folder-p sel-folder)
  591.     (progn
  592.       (load-folder-files sel-folder)
  593.       (setq input-path sel-folder)
  594.     )
  595.   )
  596.   
  597.   (while loop
  598.     (if (not (new_dialog "batchplot" dcl-id))
  599.       (setq loop nil)
  600.       (progn
  601.         (start_list "pop_printer") (mapcar 'add_list plotters) (end_list)
  602.         (start_list "pop_style") (mapcar 'add_list styles) (end_list)
  603.         (start_list "pop_scale")
  604.         (add_list "布满图纸")
  605.         (add_list "自动比例")
  606.         (add_list "1:1")
  607.         (end_list)
  608.         
  609.         (update-file-list-display)
  610.         
  611.         (if (and input-path (/= input-path ""))
  612.           (set_tile "txt_path" input-path)
  613.           (if sel-folder (set_tile "txt_path" sel-folder))
  614.         )
  615.         
  616.         (cond
  617.           ((= sel-scale "ScaleToFit") (set_tile "pop_scale" "0"))
  618.           ((= sel-scale "Auto") (set_tile "pop_scale" "1"))
  619.           ((= sel-scale "1:1") (set_tile "pop_scale" "2"))
  620.           (T (set_tile "pop_scale" "0") (setq sel-scale "ScaleToFit"))
  621.         )
  622.         
  623.         (update-factor-state sel-scale)
  624.         
  625.         (if sel-block (set_tile "txt_block" sel-block))
  626.         (set_tile "txt_factor" (if sel-factor sel-factor "1.0"))
  627.         
  628.         (if (and sel-plotter (member sel-plotter plotters))
  629.           (set_tile "pop_printer" (itoa (vl-position sel-plotter plotters)))
  630.         )
  631.         
  632.         (if (and sel-style (member sel-style styles))
  633.           (set_tile "pop_style" (itoa (vl-position sel-style styles)))
  634.         )
  635.         
  636.         (defun update-media-list (idx)
  637.           (if (and plotters (< (atoi idx) (length plotters)))
  638.             (progn
  639.               (setq sel-plotter (nth (atoi idx) plotters))
  640.               (setq media-list (get-media-names sel-plotter))
  641.               (start_list "pop_media")
  642.               (if media-list
  643.                 (mapcar 'add_list media-list)
  644.                 (add_list "无可用纸张")
  645.               )
  646.               (end_list)
  647.               (if (and media-list sel-media (member sel-media media-list))
  648.                 (set_tile "pop_media" (itoa (vl-position sel-media media-list)))
  649.                 (if media-list (setq sel-media (car media-list)))
  650.               )
  651.             )
  652.           )
  653.         )
  654.         
  655.         (update-media-list
  656.           (if (and sel-plotter (member sel-plotter plotters))
  657.             (itoa (vl-position sel-plotter plotters))
  658.             "0"
  659.           )
  660.         )
  661.         
  662.         (action_tile "btn_pick" "(done_dialog 2)")
  663.         (action_tile "btn_browse" "(done_dialog 3)")
  664.         (action_tile "btn_load" "(done_dialog 7)")
  665.         (action_tile "btn_add" "(done_dialog 4)")
  666.         (action_tile "btn_remove" "(done_dialog 5)")
  667.         (action_tile "btn_clear" "(done_dialog 6)")
  668.         
  669.         (action_tile "lst_files"
  670.           "(progn (setq selected-file-idx (atoi $value)) (update-path-display selected-file-idx))"
  671.         )
  672.         
  673.         (action_tile "txt_path" "(setq input-path $value)")
  674.         (action_tile "pop_printer" "(update-media-list $value)")
  675.         (action_tile "pop_style" "(setq sel-style (nth (atoi $value) styles))")
  676.         (action_tile "pop_media" "(if media-list (setq sel-media (nth (atoi $value) media-list)))")
  677.         (action_tile "txt_block" "(setq sel-block $value)")
  678.         (action_tile "txt_factor" "(setq sel-factor $value)")
  679.         
  680.         (action_tile "pop_scale"
  681.           "(progn (cond ((= $value "0") (setq sel-scale "ScaleToFit")) ((= $value "1") (setq sel-scale "Auto")) ((= $value "2") (setq sel-scale "1:1"))) (update-factor-state sel-scale))"
  682.         )
  683.         
  684.         (action_tile "accept" "(setq input-path (get_tile "txt_path"))(done_dialog 1)")
  685.         (action_tile "cancel" "(done_dialog 0)")
  686.         
  687.         (setq result (start_dialog))
  688.         
  689.         (cond
  690.           ((= result 1)
  691.            (setq loop nil)
  692.            (if (null sel-scale) (setq sel-scale "ScaleToFit"))
  693.            (save-settings)
  694.            
  695.            (if (and file-list (> (length file-list) 0) sel-block (/= sel-block "") sel-media)
  696.              (progn
  697.                (setq temp-dir "C:\\BatchPlotTemp")
  698.                (princ "\n======================================")
  699.                (princ "\n[批量打印 V1.1] 准备中...")
  700.                (princ (strcat "\n文件数: " (itoa (length file-list))))
  701.                (princ (strcat "\n图框: " sel-block))
  702.                (princ (strcat "\n比例: " sel-scale))
  703.                (princ "\n======================================")
  704.                
  705.                (if (prepare-temp-env file-list temp-dir)
  706.                  (progn
  707.                    (setq worker-path (strcat temp-dir "\\BP_Worker.lsp"))
  708.                    (setq scr-path (strcat temp-dir "\\BP_Job.scr"))
  709.                    (setq factor-num (atof sel-factor))
  710.                    (if (or (= factor-num 0.0) (< factor-num 0.1)) (setq factor-num 1.0))
  711.                   
  712.                    (princ "\n生成Worker...")
  713.                    (if (generate-worker-lsp worker-path sel-block sel-plotter sel-style sel-media sel-scale factor-num)
  714.                      (progn
  715.                        (princ " OK")
  716.                        (princ "\n生成脚本...")
  717.                        (if (generate-scr-file scr-path worker-path temp-dir file-list)
  718.                          (progn
  719.                            (princ " OK")
  720.                            (unload_dialog dcl-id)
  721.                            (setq dcl-id nil)
  722.                            (princ "\n启动打印...")
  723.                            (command "_.SCRIPT" scr-path)
  724.                          )
  725.                          (alert "脚本生成失败!")
  726.                        )
  727.                      )
  728.                      (alert "Worker生成失败!")
  729.                    )
  730.                  )
  731.                  (alert "准备临时环境失败!\n请检查磁盘空间和权限。")
  732.                )
  733.              )
  734.              (alert "请检查:\n- 文件列表不能为空\n- 必须填写图框块名\n- 必须选择纸张")
  735.            )
  736.           )
  737.          
  738.           ((= result 2)
  739.            (setq temp (pick-block))
  740.            (if (and temp (/= temp ""))
  741.              (if (and sel-block (/= sel-block ""))
  742.                (setq sel-block (strcat sel-block ";" temp))
  743.                (setq sel-block temp)
  744.              )
  745.            )
  746.           )
  747.          
  748.           ((= result 3)
  749.            (setq temp (browse-folder "选择DWG文件夹"))
  750.            (if temp (setq input-path temp))
  751.           )
  752.          
  753.           ((= result 4)
  754.            (setq temp (browse-single-file))
  755.            (if temp
  756.              (if (add-file-to-list temp)
  757.                (progn (setq input-path temp) (princ (strcat "\n已添加: " (vl-filename-base temp))))
  758.                (princ "\n文件已存在或无效")
  759.              )
  760.            )
  761.           )
  762.          
  763.           ((= result 5)
  764.            (if (and selected-file-idx (>= selected-file-idx 0) (< selected-file-idx (length file-list)))
  765.              (progn
  766.                (princ (strcat "\n已删除: " (vl-filename-base (nth selected-file-idx file-list))))
  767.                (remove-selected-file selected-file-idx)
  768.                (setq selected-file-idx nil)
  769.              )
  770.              (alert "请先选择要删除的文件")
  771.            )
  772.           )
  773.          
  774.           ((= result 6)
  775.            (setq file-list nil selected-file-idx nil input-path "")
  776.            (princ "\n文件列表已清空")
  777.           )
  778.          
  779.           ((= result 7)
  780.            (load-from-input-path input-path)
  781.           )
  782.          
  783.           ((= result 0) (setq loop nil))
  784.         )
  785.       )
  786.     )
  787.   )
  788.   
  789.   (if dcl-id (unload_dialog dcl-id))
  790.   (if (and dcl-file (findfile dcl-file)) (vl-file-delete dcl-file))
  791.   (princ)
  792. )
  • 上一篇：没有了
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025