wmf通过布局输出，速度较慢，请高手们优化一下

xiaoyingzi

;;源码及思路来自明经论坛帖子
;;http://bbs.mjtd.com/thread-179473-1-1.html

(vl-load-com)

;===============================================================================
(defun ZoomW_VLA (pt1 pt2)
  (vla-ZoomWindow (vlax-get-acad-object) (vlax-3d-point pt1) (vlax-3d-point pt2))
)
;===============================================================================
;; 桌面路径
(defun GetdesktopPath ( / wsh desktopPath )
  (setq wsh (vlax-create-object "WScript.Shell" ))
  (setq desktopPath (vla-item (vlax-get wsh 'SpecialFolders) "Desktop"))
  (vlax-release-object wsh)
  (if (findfile desktopPath) desktopPath nil)
)
;===============================================================================
;; PowerShell路径
(defun GetPowerShellPath (/ regPath sysPath)
  (if (setq regPath
        (vl-registry-read
          "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\powershell.exe"
        )
      )
      (progn
        (if (wcmatch regPath "*%SystemRoot%*")
            (setq regPath (vl-string-subst (getenv "SystemRoot")
                           "%SystemRoot%" regPath
                          )
            )
        )
        (if (findfile regPath) regPath nil )
      )
  )
)
;===============================================================================
;; 画图路径
(defun GetMSPaintPath (/ regPath sysPath)
  ;; 先尝试注册表
  (if (setq regPath
        (vl-registry-read
          "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\mspaint.exe"
        )
      )
      (if (findfile regPath) regPath nil )
    ;; 注册表失败则使用系统路径
     (progn
       (setq sysPath (strcat (getenv "SystemRoot") "\\System32\\mspaint.exe"))
       (if (findfile sysPath) sysPath nil )
     )
  )
)
;===============================================================================
;; 采用wsh方式运行程序
(defun mystartapp (strings ifwait / obj_wsh)
  (setq obj_wsh (vlax-create-object "wscript.shell"))
  (if (= ifwait T)
      (vlax-invoke obj_wsh 'run strings 0 1)
      (vlax-invoke obj_wsh 'run strings 0 0)
  )
  (vlax-release-object obj_wsh)
)

;===============================================================================
; 将字符串或表写入文件 (快于 write-line 函数);设置图幅通用函数
(defun vldos-writefile (fil txt mode / list->string filobj filpth filsys opnfil line)
  ;;使用"\r\n"串联字符串.尾部加换行,不然添加模式下会有重叠的行
  (defun list->string (slist / line rtn)
    (if (= (type slist) 'str)
      (setq rtn slist)
      (progn
        (setq rtn "")
        (foreach line slist
          (if (= rtn "")
            (setq rtn line)
            (setq rtn (strcat rtn "\r\n" line))
          )
        )
      )
    )
    rtn
  )
  (if txt
    (progn
      (if (and
            mode
            (findfile fil)
          )
        (vl-file-delete fil);为T时删除原文件
      )
      (if (setq filsys (vlax-create-object "Scripting.FileSystemObject"))
        (progn
          (if (null (setq filpth (findfile fil)));没有文件就创建并打开文件
            ;文件编码为为ASCII格式
            ;最后一个参数控制编码 0 = ascii编码, -1 = unicode编码, -2 system default编码
            (setq opnfil (vlax-invoke-method filsys "CreateTextFile" fil 0 0))
            (setq filobj (vlax-invoke filsys "GetFile" filpth)
                  opnfil (vlax-invoke filobj "OpenAsTextStream" 8 0);添加模式
            )
          )
          (if opnfil
            (progn
              (vlax-invoke opnfil "Write" (list->string txt))
              (vlax-invoke opnfil "Close")
              (vlax-release-object opnfil)
              (if (= (type filobj) 'vla-object)
                (vlax-release-object filobj)
              )
              (vlax-release-object filsys)
            )
          )
        )
      )
      (if (setq filpth (findfile fil))
        (setq filpth (vldos-formatpath filpth))
      )
    )
  )
  filpth
)
;===============================================================================
(defun vldos-formatpath (string);格式化路径并返回大写
  (while (vl-string-search "/" string)
    (setq string (vl-string-subst "\\" "/" string))
  )
  (while (vl-string-search "\\\\" string)
    (setq string (vl-string-subst "\\" "\\\\" string))
  )
  (setq string (strcase string))
  string
)
;===============================================================================
;;;(mj:delim "aa 10 b10x20.2" "")返回("aa 10 b10x20.2")
(defun mj:delim (str delim / l1 l2)
  (setq str (vl-string->list str)
        delim (vl-string->list delim)
  )
  (while str
    (if (not (member (car str) delim))
      (setq l1 (cons (car str) l1))
      (if l1
          (setq l2 (cons (vl-list->string (reverse l1)) l2)
                l1 nil
          )
      )
    )
    (setq str (cdr str))
  )
  (if l1
    (setq l2 (cons (vl-list->string (reverse l1)) l2))
  )
  (reverse l2)
)
;===============================================================================
(defun lm:substnth (a n l / i)
  (setq i -1)
  (mapcar
    '(lambda (x)
       (if (= (setq i (1+ i))
              n
           )
         a
         x
       )
     )
    l
  )
)
;===============================================================================
(defun ctb_modfiy_lw&col (ctbpath lw col lw1 colst1 lw2 colst2 scr colst3 colst4
                          revcol7 / n origctb1 origctb2 origctb3 origctb colpol
                          coln1 coln2 coln3 coln4)
  (if col (setq col (IndexToRgbv2 col)) (setq col 0))
  (if (not lw) (setq lw "0.01"))
  (if (not lw1) (setq lw1 "0.05"))
  (if (not lw2) (setq lw2 "0.09"))
  (if (= col 0)                                ;采用对象颜色colpol="1"
      (setq colpol (if revcol7 "5" "1"))
      (setq colpol "5")                        ;采用指定颜色colpol="5"
  )
  (setq origctb1 (list
         "PIAFILEVERSION_2.0,CTBVER1\n"
         "description=\"\n"
         "aci_table_available=TRUE\n"
         "scale_factor=1.0\n"
         "apply_factor=FALSE\n"
         "custom_lineweight_display_units=0\n"
         "aci_table{\n"
        )
  )
  (setq n 0 )
  (repeat 255
    (setq origctb2
      (append origctb2
        (list
         (strcat " " (itoa n) "=\"Color_" (itoa (+  n  1)) " \n")
        )
       )
    )
    (setq n (+ n 1))
  )
  (setq origctb2
    (append origctb2
      (list
        "}\n"
        "plot_style{\n"
      )
    )
  )
  (setq n 0)
  (repeat 255
    (setq origctb2
      (append origctb2
        (list
         (strcat " " (itoa n) "{\n")
         (strcat "  name=\"Color_" (itoa (+  n  1)) " \n")
         (strcat "  localized_name=\"Color_" (itoa (+  n  1)) " \n")
         "  description=\"\n"
         (strcat "  color=" (itoa (- -1006632961 col )) "\n")
         (strcat "  mode_color=" (itoa (- -1006632961 col )) "\n")
         (strcat "  color_policy=" colpol "\n")
         "  physical_pen_number=0\n"
         "  virtual_pen_number=0\n"
         "  screen=100\n"
         "  linepattern_size=0.5\n"
         "  linetype=31\n"
         "  adaptive_linetype=TRUE\n"
         "  lineweight=1\n"
         "  fill_style=73\n"
         "  end_style=4\n"
         "  join_style=5\n"
         " }\n"
        )
      )
    )
    (setq n (+ n 1))
  )
  (setq origctb3
    (list
         "}\n"
         "custom_lineweight_table{\n"
         (strcat " 0=" lw "\n")
         (strcat " 1=" lw1 "\n")
         (strcat " 2=" lw2 "\n")
         " 3=0.1\n"
         " 4=0.12\n"
         " 5=0.15\n"
         " 6=0.18\n"
         " 7=0.20\n"
         " 8=0.25\n"
         " 9=0.30\n"
         " 10=0.35\n"
         " 11=0.40\n"
         " 12=0.45\n"
         " 13=0.50\n"
         " 14=0.55\n"
         " 15=0.60\n"
         " 16=0.65\n"
         " 17=0.70\n"
         " 18=0.80\n"
         " 19=0.90\n"
         " 20=1.00\n"
         " 21=1.20\n"
         " 22=1.40\n"
         " 23=1.60\n"
         " 24=1.80\n"
         " 25=2.00\n"
         " 26=2.20\n"
         "}\n"
    )
  )
  (setq origctb (append origctb1 origctb2 origctb3))
  (if colst1
    (foreach coln1 colst1
      (setq origctb
        (lm:substnth "  lineweight=2\n"
            (+ (* (- coln1 1) 18) 277) origctb
        )
      )
    )
  )
  (if colst2
    (foreach coln2 colst2
      (setq origctb
        (lm:substnth "  lineweight=3\n"
            (+ (* (- coln2 1) 18) 277) origctb
        )
      )
    )
  )
  (if colst3
    (foreach coln3 colst3
      (setq origctb
        (lm:substnth (strcat "  screen=" scr "\n")
             (+ (* (- coln3 1) 18) 273) origctb
        )
      )
    )
  )
  (if colst4
    (foreach coln4 colst4
      (setq origctb  (lm:substnth "  color=-1006632961\n"
                        (+ (* (- coln4 1) 18) 268) origctb
                     )
            origctb  (lm:substnth "  mode_color=-1006632961\n"
                        (+ (* (- coln4 1) 18) 269) origctb
                     )
            origctb  (lm:substnth "color_policy=1\n"
                        (+ (* (- coln4 1) 18) 270) origctb
                     )
      )
    )
  )
  (if revcol7                                        ;是否反转7号线颜色
    (progn
      (setq origctb (lm:substnth "  color=-1006632962\n" 376 origctb)
            origctb (lm:substnth "  mode_color=-1006632962\n" 377 origctb)
      )
    )
  )
  (vldos-writefile ctbpath (apply 'strcat origctb ) t)
)
;===============================================================================
;;索引颜色转换成rgb颜色
;;例如 (IndexToRgbv 7)
;;结果 16777215
(defun IndexToRgbv (ind_col / app doc col)
   (setq app (vlax-get-acad-object)
         doc (vla-get-activedocument app)
   )
   (setq col (vla-get-truecolor (vla-get-ActiveLayer doc)))
   (if (not (vl-catch-all-apply 'vla-put-ColorIndex (list col ind_col)))
     (progn
       (vla-get-display (vla-get-preferences (vla-get-application app)))
       (+ (* (vla-get-blue col) 65536)
          (* (vla-get-green col) 256)
          (vla-get-red col)
       )
     )
   )
)
;===============================================================================
;;索引颜色转换成rgb颜色(反色)
;;例如 (IndexToRgbv2 1)
;;结果 65535
(defun IndexToRgbv2 (ind_col / app doc col)
   (setq app (vlax-get-acad-object)
         doc (vla-get-activedocument app)
   )
   (setq col (vla-get-truecolor (vla-get-ActiveLayer doc)))
   (if (not (vl-catch-all-apply 'vla-put-ColorIndex (list col ind_col)))
     (progn
       (vla-get-display (vla-get-preferences (vla-get-application app)))
       (cond ((= ind_col 7) 16777215)
             ((= ind_col 0) 0)
             ((= ind_col 256) 1)
             (T (+ (- 255 (vla-get-blue col) )
                   (* (- 255 (vla-get-green col)) 256)
                   (* (- 255 (vla-get-red col)) 65536)
                )
             )
       )
     )
   )
)
;;==============================================================================
;; 截图主程序
(defun c:qq (/ myerr myend print_wmf oldcmdecho oldosmode oldattdia oldattreq
               oldbgplot odimzin app doc layout rcols lw1cols lw2cols lw3cols
               lnwid lnwid1 lnwid2 ptscr bgcol fgcol flsuf dwgName basePath
               scrn)
;;==============================================================================
  ;自定义出错函数
  (defun myerr (msg)
    (vl-catch-all-error-p
     (vl-catch-all-apply
     '(lambda ()
        (setq msg (strcase msg t))
        (if (wcmatch msg "*break,*cancel*,*exit*")
            (princ "\n*取消*\n")
            (if (= testpdfdata 1)
                (princ (strcat "\n** 错误: " msg " **\n"))
            )
        )
        (myend)
      )
     )
    )
    (princ)
  )

  ;自定义结尾函数
  (defun myend ()
    (setvar "dimzin" odimzin)
    (setvar "backgroundplot" oldbgplot)
    (setvar "attreq" oldattreq)
    (setvar "attdia" oldattdia)
    (setvar "osmode" oldosmode)
    (setvar "cmdecho" oldcmdecho)
    (setq *error* olderr)
  )


  (defun print_wmf (/ HAS ShowPlotStyles Backgroundcolor
                   Background Layoutbackground img-count
                   wmffile suffix tempLayout pt1 pt2 pt11 pt22 ss dist)
    ;;判断"符号表"是否存在-龙龙仔
    (defun HAS (TYPE NAME)
      (if (not (vl-catch-all-error-p
                  (vl-catch-all-apply 'vla-item
                      (list ((eval (read (strcat "vla-get-" TYPE)))
                                (vla-get-activedocument (vlax-get-acad-object))
                            )
                            NAME
                      )
                  )
               )
          )
          t
      )
    )
    (defun ShowPlotStyles (value)
      (vla-put-ShowPlotStyles layout value)
      (vla-regen doc AcActiveViewport)
    )
    (defun Backgroundcolor (modecolor layoutcolor / prefdisplay)
      (setq prefDisplay
         (vla-get-display (vla-get-preferences (vla-get-application app)))
      )
      (vla-put-GraphicsWinModelBackgrndColor prefDisplay
          (vlax-make-variant modecolor vlax-vbLong)
      )
      (vla-put-GraphicsWinLayoutBackgrndColor prefDisplay
          (vlax-make-variant layoutcolor vlax-vbLong)
      )
    )
    (setq Background (getenv "Background"))
    (setq Layoutbackground (getenv "Layout background"))
    (setq suffix ".wmf")
    (princ "\n所导出的WMF格式，在插入文档时，为矢量透明高清大图，可无限缩放，如需底色可自由填充。")
    (setq scrn 0)
    (while (and  (setq pt1 (getpoint "\n请指定截图的第一个角点：\n"))
                 (setq pt2 (getcorner pt1 "\n请指定截图的另一个角点：\n"))
           )
      (setq img-count
        (length
          (vl-remove-if-not
            '(lambda (f)
              (eq (strcase (vl-filename-extension f) T) suffix )
             )
            (vl-directory-files basePath "*.*" 1)
          )
        )
      )
      (setvar "WMFBKGND" 1);;背景透明
      (setq dist 1);;这个是WMF的边界框
      (if (setq ss (ssget "C" pt1 pt2 ))
        (progn
          (setq start (getvar "MILLISECS"))
          (setq wmffile
               (strcat basePath "scr" (itoa (+ 1 img-count)) "_" dwgName suffix)
          )
          (if (HAS "LAYOUTS" "截图用临时布局")
            (progn
              (setq tempLayout (vla-item (vla-get-layouts doc) "截图用临时布局"))
              (vla-put-activelayout doc tempLayout)
            )
            (progn
              (setq tempLayout (vla-add (vla-get-layouts doc) "截图用临时布局"))
              (vla-put-activelayout doc tempLayout)
            )
          )
          (setq layout (vla-get-activelayout doc))
          (setvar "tilemode" 0)
          (command "erase" (ssget "X" '((0 . "VIEWPORT"))) "");删除所有布局视口
          (command "mview"
                  (setq pt11 (list (- (car pt1) dist) (- (cadr pt1) dist) 0))
                  (setq pt22 (list (+ (car pt2) dist) (+ (cadr pt2) dist) 0))
          )
          (ZoomW_VLA pt11 pt22);;不缩放的话就找不到可用于激活的视口了
          (if (= (getvar "CVPORT") 1)(command "mspace"));激活视口;(command "pspace");切换到图纸空间
          (ZoomW_VLA pt11 pt22)
          (setvar "lwdisplay" 1)
          ;(vla-put-plotwithplotstyles layout :vlax-true);打印线宽按打印样式
          ;(vla-put-PlotWithLineweights layout :vlax-false);使用对象线宽
          (vla-Put-StyleSheet layout "myimg.ctb")
          (Backgroundcolor (IndexToRgbv bgcol) (IndexToRgbv bgcol))
          (ShowPlotStyles :vlax-true)
          (command "wmfout" wmffile ss "")
          (Backgroundcolor Background Layoutbackground)
          (setvar "tilemode" 1);切换回模型空间
          (setvar "lwdisplay" 0)
          ;(ShowPlotStyles :vlax-false)
          (vl-catch-all-apply 'vla-delete (list tempLayout))
          (setq tempLayout nil)
          (setq ss (ssadd))
          (sssetfirst nil nil)
          (setq end (getvar "MILLISECS"))
          (princ (strcat "\n耗时: " (itoa (- end start)) " 毫秒"))
          (princ (strcat "\n---------------第 " (itoa (1+ scrn)) " 张---------------"))
        )
        (princ "\n没有选中实体!")
      )
      (setq scrn (+ scrn 1))
     ;|
      ;复制到粘贴板
      (setq pscmd
           (strcat
            "Add-Type -AssemblyName System.Windows.Forms; "
            "[System.Windows.Forms.Clipboard]::SetImage([System.Drawing.Image]::FromFile('"
            (vldos-formatpath wmffile)
            "'))"
           )
      )
      (mystartapp
           (strcat
            "\"" (GetPowerShellPath) "\" "
            "-ExecutionPolicy Bypass "               ;绕过执行策略
            "-Command \"" pscmd "\""
            )
            T
      )
      (princ "\n截图已复制到粘贴板!")
      |;
      ;打开画图
      (mystartapp
              (strcat (GetPowerShellPath) " -Command \"& '" (GetMSPaintPath) "' '"
                (vldos-formatpath wmffile) "'\""
              )
              T
      )
    )
    (if (> scrn 1)
      (princ (strcat "\n---------------共 " (itoa scrn) " 张---------------\n"))
    )
    (if (> scrn 0)
      (princ "\n截图已生成在桌面上！")
    )
  )

;;==============================================================================
  ;主程序开始
  (setq olderr *error*)
  (setq *error* myerr)
  (setq oldcmdecho (getvar "cmdecho"))
  (setq oldosmode (getvar "osmode"))
  (setq oldattdia (getvar "attdia"))
  (setq oldattreq (getvar "attreq"))
  (setq oldbgplot (getvar "backgroundplot"))
  (setq odimzin (getvar "dimzin"))

  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (setvar "attdia" 0)
  (setvar "attreq" 0)
  (setvar "backgroundplot" 0)
  (setvar "dimzin" 0)

  (setq app (vlax-get-acad-object)
        doc (vla-get-activedocument app)
        layout (vla-get-activelayout doc)
  )


  ;; 设置打印文件夹
  (setq dwgName (vl-filename-base (getvar "dwgname")))
  (setq basePath (strcat (GetdesktopPath) "\\"))
  (setq path-ctb (strcat (getenv "PrinterStyleSheetDir") "\\" ))
  (setq ctb-name (strcat path-ctb "myimg.ctb"))
  (if (not (vl-file-directory-p basePath)) (vl-mkdir basePath))

  (setq bgcol 0)       ; 背景颜色 0为黑色 7为白色
  (setq lnwid "0.00")  ; 打印线宽\
  (setq fgcol 7)       ; 打印对象颜色 0为保留对象颜色 7为黑色
  (setq lnwid1 "0.00") ; 打印线宽1
  (setq lw1cols  nil)  ; 对应线宽1颜色表1
  (setq lnwid2 "0.00") ; 打印线宽2
  (setq lw2cols  nil)  ; 对应线宽1颜色表2
  (setq ptscr "100")    ; 淡显值
  (setq lw3cols  nil)  ; 对应线宽1颜色表3
  (setq rcols    nil)  ; 保留对象颜色表

  (ctb_modfiy_lw&col
    ctb-name
    lnwid
    fgcol
    lnwid1
    lw1cols
    lnwid2
    lw2cols
    ptscr
    lw3cols
    rcols
    (if (and (= bgcol 0) (or (= fgcol 0) (= fgcol 7))) T nil)
  )
  (print_wmf)
  ;(vlax-invoke-method (vlax-create-object "Shell.Application") 'Open basePath)

  (myend)
  (princ)
)

(princ)

xiaoyingzi

有对话框版本的见http://bbs.mjtd.com/thread-193523-1-1.html