【Gu_xl】Lisp操控Word编程技术
本帖最后由 Gu_xl 于 2013-6-11 10:44 编辑(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)
)
本帖最后由 jiaodahaoren 于 2010-12-24 20:09 编辑
回复 Gu_xl 的帖子
这是什么呢？函数的入口在哪儿？ 来向 G 版学习，真的很佩服版主，版主的天赋和灵性令人神往，难以企及，只能心向往之~ snddd2000 发表于 2018-3-9 16:05
gu版，请教个问题，lisp操作word替换文字的函数的参数怎么写？
(vlax-invoke-method
Find ...
(setq word (vlax-create-object "Word.Application"))
(vlax-put-property word 'Visible 1)
(setq docs (vlax-get-property word 'Documents))
(setq doc (vlax-invoke-method docs 'Open "C:/Users/Administrator/Desktop/测试.doc"))
(setq range (vlax-get-property doc 'Content))
(setq find (vlax-get-property range 'Find))
(vlax-invoke-method find 'ClearFormatting)
(setq thq "b792")
(setq thh "BBBB")
;(vlax-invoke-method find 'Execute "BBBB" :vlax-true :vlax-true :vlax-false :vlax-false :vlax-false :vlax-true :vlax-false :vlax-false "b792" 2 :vlax-false :vlax-false :vlax-false)
;(vlax-invoke-method find 'Execute "b792" :vlax-true :vlax-true :vlax-false :vlax-false :vlax-false :vlax-true :vlax-false :vlax-false "BBBB" 2 :vlax-false :vlax-false :vlax-false)
(vlax-invoke-method find 'Execute thq :vlax-true :vlax-true :vlax-false :vlax-false :vlax-false :vlax-true :vlax-false :vlax-false thh 2 :vlax-false :vlax-false :vlax-false)
;(vlax-invoke-method find 'Execute (cons 'Replace 'wdReplaceAll) (cons 'Forward 1))
(vlax-invoke-method doc 'SaveAs "D:/New.docx" )
(vlax-invoke-method doc 'Close)
(vlax-invoke-method word 'Quit)
;;;(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)
)
支持！学习！谢谢分享！ 回复 jiaodahaoren 的帖子
呵呵，你还需努力，这些可能对你来说太难了！ 熟悉word对象模型的再改改excel相关的l代码应该能把这个搞出来，但需要一些时间，不管怎么样支持一下吧 本帖最后由 Gu_xl 于 2010-12-25 10:38 编辑
;;;Lisp 操控Word示例
;;;编制：Gu_xl 2010年12月
(defun c:myword (/ *WordApp* documentparagraph Range)
;;;初始化Word
(gxl-word-app-Init)
;;;新建Word 的应用程序
(setq *WordApp* (gxl-word-app-New nil))
;;;新建文档
(setq document (gxl-word-Document-add *WordApp*))
;;;保存文档
;(gxl-word-app-saveas document "d:\\MyTest.Doc")
(MSWM-add (mswp-get-paragraphs document))
;;;获取文档最后的段落
(setq paragraph (mswp-get-last (mswp-get-paragraphs document)))
;;;设置段落居中
(vla-put-alignment paragraph mswc-wdAlignParagraphCenter)
;;;获取段落的Range
(setq Range (MSWP-GET-RANGE paragraph))
;;;设置Range字体为黑体
(mswp-put-name (mswp-get-font range) "黑体")
;;; 设置Range字体大小
(mswp-put-size (mswp-get-font range) 16)
;;;设置Range字体加粗
(mswp-put-bold range :vlax-true)
;;;添加文字内容
(MSWM-INSERTAFTER Range "Lisp 操控Word示例")
;;;文档添加新的段落
(MSWM-add (mswp-get-paragraphs document))
;;;获取文档最后的段落
(setq paragraph (mswp-get-last (mswp-get-paragraphs document)))
;;;设置段落居左对齐
(vla-put-alignment paragraph mswc-wdAlignParagraphLeft)
;;;获取段落的Range
(setq Range (MSWP-GET-RANGE paragraph))
(mswp-put-name (mswp-get-font range) "宋体")
(mswp-put-size (mswp-get-font range) 14)
(mswp-put-bold range :vlax-false)
(MSWM-INSERTAFTER Range "Lisp 操控Word示例的第一段落")
;;;文档添加新的段落
(MSWM-add (mswp-get-paragraphs document))
;;;获取文档最后的段落
(setq paragraph (mswp-get-last (mswp-get-paragraphs document)))
;;;设置段落居左对齐
(vla-put-alignment paragraph mswc-wdAlignParagraphLeft)
;;;获取段落的Range
(setq Range (MSWP-GET-RANGE paragraph))
(MSWM-INSERTAFTER Range "2010年12月 编制 By :Gu_xl")
;;;保存文档
(GXL-WORD-APP-SAVEAS document "d:\\MyTest.Doc")
;;;保存所有文档退出
(gxl-word-app-kill t)
)
谢谢楼主共享代码！ MARK!!!!!!!!!!!!!!!!!!!! 太难度了！！！