Lisp操控Word完全手册

(Defun gxl-word-app-Init

       (/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2)

    (setq msg  "\n 初始化微软Word "

         msg1 "\042初始化Word错误\042"

         msg2 (strcat

               "\042 警告"

               "\n ===="

               "\n 无法在您的计算机上检测到微软Word软件"

               "\n 如果您确认已经安装Word, 请发送电子邮"

               "\n 件到Gu_xl@sohu.com获取更多的解决方案\042"

              )

    )
  (if (null mswc-wd100Words)
    (progn
      (if (and (setq GGG
                    (vl-registry-read
                     "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Winword.EXE"
                     "Path"
                    )
              )
              (setq GGG (strcase (strcat GGG "Winword.EXE")))
         )
       (progn
         (foreach OSVar (list "SYSTEMROOT" "WINDIR"
                            "WINBOOTDIR"     "SYSTEMDRIVE"
                            "USERNAME"  "COMPUTERNAME"
                            "HOMEDRIVE"       "HOMEPATH"
                            "PROGRAMFILES"
                           )
           (if    (vl-string-search (strcat "%" OSVar "%") GGG)
             (setq GGG       (vl-string-subst
                       (strcase (getenv OSVar))
                      (strcat "%" OSVar "%")
                       GGG
                     )
             )
           )
        )
         (setq   Olb8  (findfile (vl-string-subst "MSWORD.OLB" "WINWORD.EXE" GGG))
         )
         (cond  ((= (vl-filename-base (vl-filename-directory GGG))
                  "OFFICE11"
               )
               (setq TLB Olb8
                     Out "2003"
               )
              )
  ((= (vl-filename-base (vl-filename-directory GGG))
                  "OFFICE12"
               )
               (setq TLB Olb8
                     Out "2007"
               )
              )
              (t (setq Out "Version Unknown"))
         )
         (if TLB
           (progn
             (princ (strcat MSG Out "..."))
             (vlax-import-type-library
              :tlb-filename    TLB               :methods-prefix
              "mswm-"             :properties-prefix
              "mswp-"             :constants-prefix "mswc-"
              )
           )
         )
       )
       (progn
         (if vldcl-msgbox
(vldcl-msgbox "x" msg1 msg2)
(alert (read msg2))
)
         (exit)
       )
      )
    )
  ) 
mswc-wd100Words
)
;;;创建Word Application
;;;(setq wordapp (gxl-word-app-New 1))
(Defun gxl-word-app-New (UnHide / Rtn)
  (if (gxl-word-app-init)
    (progn

      (if (setq Rtn (vlax-get-or-create-object "Word.Application"))
       (progn
         (vlax-invoke-method
           (vlax-get-property Rtn 'Documents)
           'Add
         )
         (if UnHide
           (vla-put-visible Rtn :vlax-true)
           (vla-put-visible Rtn :vlax-false)
         )
       )
      )
    )
  )
  Rtn
)
;;;打开Word文件
;;;(setq wordapp (gxl-word-app-open (getfiled "选择文件" "" "doc" 0) 1))
(Defun gxl-word-app-open (DocFile UnHide /  Rtn)
  (setq DocFile (strcase DocFile))
  (if (null (wcmatch DocFile "*.DOC"))
    (setq DocFile (strcat DocFile ".DOC"))
  )
  (if (and (findfile DocFile)
          (setq Rtn (vlax-get-or-create-object "Word.Application"))
      )
    (progn
 ;|
      (vlax-invoke-method
       (vlax-get-property Rtn 'Documents)
 (vla-get-Documents rtn)
       'Open
       DocFile
      )
      |;
      (mswm-open (vla-get-Documents rtn) DocFile)

      (if UnHide

       (vla-put-visible Rtn :vlax-true)

       (vla-put-visible Rtn :vlax-false)

      )

    )

  )

  Rtn

)
;;; (gxl-word-app-save (vla-get-ActiveDocument wordapp)) 保存word文档
(Defun gxl-word-app-save (DocObj)
  (mswm-Save DocObj)
)
;;;(gxl-word-app-saveas (vla-get-ActiveDocument wordapp) Filename) 另存为 (gxl-word-app-saveas (vla-get-ActiveDocument wordapp) "c:\\a1.doc")
(Defun gxl-word-app-saveas (DocObj Filename / Rtn)

  (if (null filename)

    (setq filename (strcat (getvar "dwgprefix") "DOC.DOC"))

  ) ;_ if

  (if (null (wcmatch (setq filename (strcase Filename)) "*`.DOC"))

    (setq filename (strcat filename ".DOC"))

  ) ;_ if

  (if (findfile Filename)

    (vl-file-delete (findfile Filename))

  ) ;_ if
;|
  (vlax-invoke-method

    (vlax-get-property wordapp "ActiveDocument")

    "SaveAs"
    Filename
  ) ;_ vlax-invoke-method
|;
 
  (vla-saveas DocObj Filename)
  (findfile Filename)

) ;_ Defun
;;;(gxl-word-app-quit wordapp SaveYN) 退出Word
;;;(gxl-word-app-quit wordapp1 nil)
(Defun gxl-word-app-quit (wordapp SaveYN / error)

  (if SaveYN
;|
    (vlax-invoke-method
      (vlax-get-property wordapp "ActiveDocument")
      'Close
      :vlax-true
    )|;
    (mswm-Close (vla-get-ActiveDocument wordapp) :vlax-true)
    ;|
    (vlax-invoke-method
      (vlax-get-property wordapp "ActiveDocument")
      'Close
      :vlax-False
    )
    |;
    (mswm-Close (vla-get-ActiveDocument wordapp) :vlax-False)
  )
 
  (vlax-release-object wordapp)

  (setq wordapp nil)

(gc)
)
;;;退出word
;;;(gxl-word-app-kill nil)
(Defun gxl-word-app-kill (SaveYN / wordObj error)
  (setq wordObj (vlax-get-object "Word.Application"))
  (if wordObj
    (while (not (VL-CATCH-ALL-ERROR-P (setq error (VL-CATCH-ALL-APPLY 'vlax-get-property (list wordObj "ActiveDocument")))))
      (if SaveYN
      (vlax-invoke-method error 'close :vlax-true)
 (vlax-invoke-method error 'close :vlax-False)
 )
 
      )
    )
      (vlax-invoke-method wordObj 'QUIT)

  (vlax-release-object wordObj)

  (setq wordObj nil)

 
  (gc)
)
;;;增加Word
;;;(gxl-word-book-add wordapp)
(defun gxl-word-Document-add (wordapp)
  ;|
  (vlax-invoke-method
    (vlax-get-property wordapp 'Documents)
    'Add

  ) ;_ vlax-invoke-method
  |;
  (mswm-add (vla-get-Documents wordapp))
)
;;;(gxl-word-get-activeDocument wordapp) 获取活动文档
(defun gxl-word-get-activeDocument (wordapp)
  ;(vlax-get-property wordapp "ActiveDocument")
  (vla-get-ActiveDocument wordapp)
  )
;;;Range方法
(defun gxl-word-Range (DocObj startpos endPos)
  (mswm-range DocObj startpos endPos)
  )
;;;获取文档最后的段落
;;;(setq pg (gxl-word-get-lastparagraph (gxl-word-get-activeDocument (vlax-get-object "Word.Application"))))
(defun gxl-word-get-lastparagraph (docobj)
  (mswp-get-last (mswp-get-paragraphs docobj))
  )
;;;获取段落范围
;;;(setq rg (gxl-word-get-range pg))
(defun gxl-word-get-range (obj)
  (mswp-get-Range obj)
  )
;;;段尾插入文本
;;;(gxl-word-insertafter rg "gxl-word-insertafter")
(defun gxl-word-insertafter (range text)
  (mswm-InsertAfter range text)
  )
;;;段尾插入文本
;;;(gxl-word-insertBefore rg "gxl-word-insertBefore")
(defun gxl-word-insertBefore (range text)
  (mswm-InsertBefore range text)
  )
;;;设置粗体 :vlax-true or :vlax-false
;;;(gxl-word-bold rg :vlax-true)
(defun gxl-word-bold (range boolen)
  (mswp-put-bold range boolen)
  )
;;;设置下划线
;;;(gxl-word-underline rg mswc-wdUnderlineSingle)
(defun gxl-word-underline (range lt)
  (mswp-put-Underline range lt)
  )
;;;设置字体
;;;(mswp-put-name (mswp-get-font (mswm-range (gxl-word-get-activeDocument wordapp) 0 20)) "宋体")
;;; (vlax-for obj (MSWP-GET-PARAGRAPHS (gxl-word-get-activeDocument wordapp)) (mswp-put-name(mswp-get-font (MSWP-GET-RANGE obj))"宋体") )
(defun gxl-word-put-FontName (range name)
  (mswp-put-name (mswp-get-font range) name)
  )

;;;设置字体大小
;;;(mswp-put-Size (mswp-get-font (mswm-range (gxl-word-get-activeDocument wordapp) 0 20)) 24)
;;;(vlax-for obj (MSWP-GET-PARAGRAPHS (gxl-word-get-activeDocument wordapp)) (mswp-put-size(mswp-get-font (MSWP-GET-RANGE obj))20))
(defun gxl-word-put-FontSize (range Size)
  (mswp-put-Size (mswp-get-font range) Size)
  )