求关于lotusscript实现所有数据导入word并把它导出来的代码
问题描述：用lotusscript写关于导出word，且把整张单的所有数据都导进去，包括附件也导入到WORD里的具体代码。
[解决办法]
Class CWord
'当前用户会话
s As NotesSession
'当前数据库对象
currDb As NotesDatabase
'对象是否有效
isValid As Variant
'文件保存相对路径
FilePath As String
'Word模版保存目录
WordModelPath As String
'Word文件保存目录
WordDocPath As String
'路径分隔符
sep As String
'析构函数中是否自动删除Word应用程序
bAutoExitWordApp As Variant
'在自动删除Word应用程序时是否保存Word文档
bSaveChanges As Variant
'Word 应用程序对象
Public wordApp As Variant
fileNameList List As String
filePathList List As String
Function CreatedWordDocByWordModelDoc(wordModelDoc As NotesDocument,sWordModelNameItemName As String,sRTItemNameContainsWordModel As String,wordDocObject As Variant) As Variant
CreatedWordDocByWordModelDoc=False
If isValid Then
Dim item As Variant
'word 应用程序 Documents 集合
Dim documents As Variant
'Word模板名
Dim wordModelName As String
'Word模板路径名（含文件名）
Dim wordModelFilePath As String
Dim key As String
If wordModelDoc.HasItem(sWordModelNameItemName) Then
Set item=wordModelDoc.GetFirstItem(sWordModelNameItemName)
If Trim(item.Text)<>"" Then key=item.Text
End If
wordModelFilePath=GetFilePathByKey(key)
If ""=wordModelFilePath Then
Dim rtItem As Variant
Dim wordModelFileName As String
'提取以 sRTItemNameContainsWordModel 的值为名的RTF域中的第一个附件(Word模板)
If wordModelDoc.HasItem(sRTItemNameContainsWordModel) Then
Set rtItem =wordModelDoc.GetFirstItem(sRTItemNameContainsWordModel)
If ( rtItem.Type = RICHTEXT ) Then
Forall o In rtItem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
wordModelFileName = o.Source
key=wordModelFileName
wordModelFilePath=GetFilePathByKey(key)
If ""=wordModelFilePath Then
wordModelFilePath = WordModelPath$ & wordModelFileName
fileNameList(key) = wordModelFileName
filePathList(key) = wordModelFilePath
Call o.ExtractFile( wordModelFilePath )
Set o = Nothing
End If
Exit Forall
End If
End Forall
End If
End If
End If
If ""<>wordModelFilePath Then
Set documents = wordApp.Documents
'生成新的Word文档
Set wordDocObject = documents.Add(wordModelFilePath)
If Not wordDocObject Is Nothing Then CreatedWordDocByWordModelDoc=True
End If
End If
End Function
'把Notes文档转换为Word文档
Function ConvertNotesToWord(toConvertedDoc As NotesDocument,wordDocObject As Variant,bookMarkFieldNamesOdd List As String) As Variant
On Error Goto LblErrorHandler
'初步判断所传参数的正确性
If (wordDocObject Is Nothing) Or (toConvertedDoc Is Nothing) Then
ConvertNotesToWord = False
Exit Function
End If
'书签名
Dim bookMark As String
Dim vMicroResult As Variant
Forall e In bookMarkFieldNamesOdd
bookMark = Listtag(e)
If wordDocObject.Bookmarks.Exists(bookMark) Then
wordDocObject.Bookmarks(bookMark).Select
If Instr(e,"Byval#")>0 Then
wordApp.Selection.TypeText(Strright(e,"Byval#"))
Elseif Instr(e,"ByFormula#")>0 Then
vMicroResult = Evaluate(Strright(e,"ByFormula#"),toConvertedDoc)
wordApp.Selection.TypeText(vMicroResult(0))
Elseif Trim(e)="*" Then
Else
If toConvertedDoc.HasItem(e) Then
vMicroResult = Evaluate(
[解决办法]
@Implode(@Text(
[解决办法]
& e &
[解决办法]
);"，")
[解决办法]
,toConvertedDoc)
If Cstr(vMicroResult(0))="" Then
wordApp.Selection.TypeText("N/A")
Else
wordApp.Selection.TypeText(vMicroResult(0))
End If
End If
End If
End If
End Forall
Exit Function
LblErrorHandler:
Print "在“WordOperateLSLib”中，类“CWord” ConvertNotesToWord 函数中第 "+Cstr(Erl())+" 行发生 <"+Error$+"> 错误！"
Resume Next
End Function
Sub New(bAutoExitWordApp As Variant,bSaveChanges As Variant)
On Error Goto ErrorHandler
Set s=New NotesSession
Set currDb = s.CurrentDatabase
If Ucase(s.platform)="UNIX" Or Ucase(s.platform)="LINUX" Then
FilePath$=Trim(s.Getenvironmentstring("Directory",True)+"/Temp")
sep$="/"
Else
FilePath$=Trim(s.Getenvironmentstring("Directory",True)+"\Temp")
sep$=""
End If
'建立操作系统文件子目录存放下载的Word模版
If Not Dir$(FilePath$,16)<>"" ThenMkdir FilePath$
'创建Word模板子目录
WordModelPath$ = Trim(FilePath$ & sep$ & "WordModel")
If Not Dir$(WordModelPath$,16)<>"" ThenMkdir WordModelPath$
'创建Word文件子目录
WordDocPath$ = Trim(FilePath$ & sep$ & "WordFile")
If Not Dir$(WordDocPath$,16)<>"" ThenMkdir WordDocPath$
FilePath$ = FilePath$ + sep$
WordModelPath$ = WordModelPath$ + sep$
WordDocPath$ = WordDocPath$ + sep$
Me.bAutoExitWordApp=GetBooleanValue(bAutoExitWordApp)
Me.bSaveChanges=GetBooleanValue(bSaveChanges)
Set wordApp = CreateObject("Word.Application")
If Not Isnull(wordApp) And Not Isempty(wordApp) Then isValid=True
Exit Sub
ErrorHandler:
isValid = False
Print "在“WordOperateLSLib”库中，类“CWord” New 函数中第 "+Cstr(Erl())+" 行发生 <"+Error$+"> 错误！"
Exit Sub
End Sub
'通过关键字获取Word模板名
Function GetFileNameByKey(key As String) As String
If isValid = False Or "" = key Then
GetFileNameByKey = ""
End If
If Iselement(fileNameList(key)) Then
GetFileNameByKey = fileNameList(key)
Else
GetFileNameByKey = ""
End If
End Function
'通过关键字获取Word模板名（含路径）
Function GetFilePathByKey(key As String) As String
If isValid = False Or "" = key Then
GetFilePathByKey = ""
End If
If Iselement(filePathList(key)) Then
GetFilePathByKey = filePathList(key)
Else
GetFilePathByKey = ""
End If
End Function
Sub DeleteFile(filePath)
If ""<>Trim(filePath) Then Kill filePath
End Sub
Function GetBooleanValue(vValue As Variant) As Variant
On Error Goto LblSetFalse
If True=vValue Then
GetBooleanValue=True
Else
GetBooleanValue=False
End If
Exit Function
LblSetFalse:
GetBooleanValue=False
Exit Function
End Function
Sub Delete
On Error Goto ErrorHandler
If bAutoExitWordApp Then
If Not Isnull(wordApp) And Not Isempty(wordApp) Then
If Not wordApp Is Nothing Then
If bSaveChanges Then
Forall w In wordApp.Workbooks
Call w.Save
End Forall
End If
'退出 Word 应用程序
Call wordApp.Quit
'释放对象
Set wordApp = Nothing
End If
End If
End If
Exit Sub
ErrorHandler:
Print "在“WordOperateLSLib”中，类“CWord” Delete 函数中第 "+Cstr(Erl())+" 行发生 <"+Error$+"> 错误！"
Exit Sub
End Sub
End Class
