请问在asp中用 FileSystemObject来操作word时，能不能在原有的word文档上添加新的数据？

[szwendy]

是添加新的数据，而不是重新生成新的word文档，谢谢！

[pp4u]

Public Function print1(vkvalue As String, vkvalue1 As String) As Boolean
On Error Resume Next
Dim s As String

If Dir("c:\temp", vbDirectory) = "" Then
MkDir "c:\temp"
End If
s = Dir("c:\temp\*.doc")
Do While s <> ""
Kill "c:\temp\" & s
s = Dir()
Loop

Dim strarray() As String
Dim I As Integer
Dim str() As String
Dim J As Integer

If Dir(vkvalue1) = "" Then
'替换文件不存在
MsgBox "未找到" & vkvalue1 & "文件" '提示替换文件不存在信息
Exit Function '退出函数
End If
strarray = Split(vkvalue, ";")
Set wordApp = CreateObject("word.Application") '创建应用类
wordApp.Visible = False '设置不可见
wordApp.Documents.Open (vkvalue1)
rndname = "c:\temp\" & CLng(Now()) & rand() & ".doc"
wordApp.ActiveDocument.SaveAs (rndname)
For I = 0 To (UBound(strarray) - 1)
str = Split(strarray(I), ",")
wordApp.Selection.GoTo Name:=str(0)
wordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wordApp.Selection.Font.Size = 11 '(设定文字的大小)
wordApp.Selection.Font.Bold = True
wordApp.Selection.Font.Name = "宋体"
wordApp.Selection.TypeText (str(1))
wordApp.Selection.TypeParagraph
Next I
wordApp.Visible = True
Exit Function



End Function

[szwendy]

我的意思是想先做好一个word文档，加上页眉页脚，然后再通过asp从数据库中读取记录写入这个word文档中，这样就得到了一个完整的word文档。因为我不知如何用asp往word中加入页眉页脚，如果哪位大虾知道如何用ASP加入页眉页脚，烦请赐教，谢谢！！

[yonghengdizhen]

看看word vba参考吧,连中文的参考都不愿意看的话,就没救了.

方法其实无非就是设置书签,定位书签,替换书签内容

fso是不能修改word文档的

[szwendy]

to: yonghengdizhen(9.18 我的祖国在腐烂)
能不能讲的详细些，我看了一下word vba,还是不行，能不能给出一段代码，在下感激不尽。

[yonghengdizhen]

Private Function GetMaterial(conn As ADODB.Connection, rs As ADODB.Recordset, autoid As Variant)
Dim strSQL As String, i As Integer, j As Integer
Dim tmpjc As String, tmpyb As String
strSQL = "SELECT A.regtbl,A.sname,A.num,B.detail,A.SDESC FROM tblmattersave A,zdb B"
strSQL = strSQL & " WHERE A.numdw=B.Code(+) AND B.Kind(+)='381'"
strSQL = strSQL & " AND (regtbl='J" & autoid & "' OR regtbl='S" & autoid & "') AND ASCII(orderid)=ASCII('U')"
rs.Open strSQL, conn
i = 0
j = 0
While Not rs.EOF
If Left(rs("regtbl"), 1) = "J" Then '检材
i = i + 1
tmpjc = tmpjc & "[" & i & "]" & rs("sname") & rs("num") & rs("detail") & ":" & rs("SDESC") & vbCrLf
Else '样本
j = j + 1
tmpyb = tmpyb & "[" & j & "]" & rs("sname") & rs("num") & rs("detail") & ":" & rs("SDESC") & vbCrLf
End If
rs.MoveNext
Wend
If i > 0 Then
tmpjc = "检材：" & tmpjc
End If
If j > 0 Then
tmpyb = "样本：" & tmpyb
End If
rs.Close
GetMaterial = tmpjc & tmpyb
End Function
Private Function GetObjectInfo(conn As ADODB.Connection, rs As ADODB.Recordset, autoid As Variant)
Dim strSQL As String, tempStr As String
strSQL = "SELECT B.detail AS Employment," '========================3
strSQL = strSQL & "num AS Age," '========================4
strSQL = strSQL & "d.Detail AS Sex," '========================6
strSQL = strSQL & "casing AS address," '========================7
strSQL = strSQL & "place AS memo," '========================8
strSQL = strSQL & "sname AS Name," '========================9
strSQL = strSQL & "sdesc AS unitname," '========================10
strSQL = strSQL & "sthing AS Origin," '========================11
strSQL = strSQL & "C.detail AS Educational" '========================13
strSQL = strSQL & " FROM tblmatterbak A,zdb B,zdb C,zdb D"
strSQL = strSQL & " WHERE A.savedw=B.code(+) AND B.kind(+)='08'"
strSQL = strSQL & " AND A.confidential=C.code(+) AND C.kind(+)='02'"
strSQL = strSQL & " AND A.numdw=D.code(+) AND D.kind(+)='01'"
strSQL = strSQL & " AND regtbl='P" & autoid & "' AND ASCII(orderid)<>ASCII('U') AND SUBSTR(orderid,1,2)<>'UU'"
rs.Open strSQL, conn
If Not rs.EOF Then
tempStr = "姓名:" & vbTab & rs("name") & vbCrLf
tempStr = tempStr & "性别:" & vbTab & rs("sex") & vbCrLf
tempStr = tempStr & "年龄:" & vbTab & rs("age") & vbCrLf
tempStr = tempStr & "职业:" & vbTab & rs("Employment") & vbCrLf
tempStr = tempStr & "文化程度:" & vbTab & rs("Educational") & vbCrLf
tempStr = tempStr & "籍贯:" & vbTab & rs("origin") & vbCrLf
tempStr = tempStr & "工作单位:" & vbTab & rs("unitname") & vbCrLf
tempStr = tempStr & "住址:" & vbTab & rs("address") & vbCrLf
tempStr = tempStr & "备注:" & vbTab & rs("memo") & vbCrLf
End If
rs.Close
GetObjectInfo = tempStr
End Function
Private Function GetAttachment(conn As ADODB.Connection, rs As ADODB.Recordset, CheckUpID As Variant, SessionID As Variant)
Dim stm As New ADODB.Stream
Dim strSQL As String, i As Integer
Dim attachment, AttachmentFile As String
i = 0
Set stm = New ADODB.Stream
strSQL = "SELECT id,kind,description,matternum,recordman,recordtime,resultpic"
strSQL = strSQL & " FROM tblcheckuppic WHERE checkupid='" & CheckUpID & "' ORDER BY recordtime DESC"
conn.CursorLocation = adUseClient
rs.Open strSQL, conn, 3, 3
While Not rs.EOF
i = i + 1
attachment = attachment & "[" & i & "]" & rs("kind") & rs("description") & rs("matternum") & rs("recordman") & rs("recordtime") & vbCrLf
If Not IsNull(rs("resultpic")) Then
AttachmentFile = App.Path & "\" & SessionID & "_PICTURE[" & i & "].JPG"
stm.Mode = adModeReadWrite
stm.Type = adTypeBinary
stm.Open
stm.Write rs("resultpic")
stm.SaveToFile AttachmentFile, 2
stm.Close
attachment = attachment & "<IMG SRC='" & AttachmentFile & "'>" & vbCrLf
End If
rs.MoveNext
Wend
rs.Close
Set stm = Nothing
GetAttachment = attachment
End Function
Private Function PreConvertHTML(strContent As Variant)
Dim oRegExp As New RegExp, oMatch As Match, oMatchs As MatchCollection
Dim tempStr As String
oRegExp.Global = True
oRegExp.IgnoreCase = True
oRegExp.MultiLine = True
oRegExp.Pattern = "<TABLE>[.\r\n\s\S]*<\/TABLE>"
Set oMatchs = oRegExp.Execute(strContent)
For Each oMatch In oMatchs
tempStr = Replace(oMatch.value, vbCrLf, "<BR>")
tempStr = Replace(tempStr, vbTab, "<SPACE>")
tempStr = Replace(tempStr, "<TR><TD>", "")
tempStr = Replace(tempStr, "</TD><TD>", vbTab)
tempStr = Replace(tempStr, "</TD></TR>", vbCrLf)
strContent = Replace(strContent, oMatch.value, tempStr)
Next
PreConvertHTML = strContent
End Function
Private Sub PostConvertHTML(strContent As Variant)
Dim oRegExp As New RegExp, oMatch As Match, oMatchs As MatchCollection
Dim fso As New FileSystemObject
oRegExp.Global = True
oRegExp.IgnoreCase = True
oRegExp.MultiLine = True
oRegExp.Pattern = "<IMG SRC='([.\s\S]*)'>"
Set oMatchs = oRegExp.Execute(strContent)
For Each oMatch In oMatchs
If fso.FileExists(oMatch.SubMatches(0)) Then '删除附件中包含的所有图片文件
fso.DeleteFile oMatch.SubMatches(0), True
End If
Next
End Sub
Private Sub ConvertHTML(oWordApp As Word.Application, oWordDoc As Word.Document, strBookMark As String, strContent As Variant, iType As Integer)
If Not oWordDoc.Bookmarks.Exists(strBookMark) Then Exit Sub
Dim oFileSystem As New FileSystemObject
oWordDoc.Bookmarks(strBookMark).Select
oWordApp.Selection.Text = strContent
If iType = 1 Then '处理HTML文本转换
oWordApp.Selection.Find.ClearFormatting
With oWordApp.Selection.Find
.Text = "\<TABLE\>(*)\</TABLE\>"
.MatchWildcards = True
.Forward = True
End With
With oWordApp.Selection
Do
.Collapse Direction:=wdCollapseStart
If (.Find.Execute(ReplaceWith:="\1", Replace:=wdReplaceOne)) Then
Set oTable = .ConvertToTable(Separator:=vbTab)
End If
.Collapse Direction:=wdCollapseEnd
bFind = .Find.Execute
Loop Until Not bFind
End With
oWordDoc.Bookmarks(strBookMark).Select
With oWordApp.Selection.Find
.MatchWildcards = False
.Execute FindText:="<BR>", ReplaceWith:=vbCrLf, Replace:=wdReplaceAll
.Execute FindText:="<SPACE>", ReplaceWith:=vbTab, Replace:=wdReplaceAll
End With
With oWordApp.Selection.Find
.Text = "\<IMG SRC='(*)'\>"
.MatchWildcards = True
.Forward = True
End With
With oWordApp.Selection
Do
.Collapse Direction:=wdCollapseStart
If (.Find.Execute(ReplaceWith:="\1", Replace:=wdReplaceOne)) Then
If oFileSystem.FileExists(.Text) Then
strFileName = .Text
Set oInlineShape = .InlineShapes.AddPicture(strFileName, False, True)
'oFileSystem.DeleteFile strFileName, True
End If
End If
.Collapse Direction:=wdCollapseEnd
bFind = .Find.Execute
Loop Until Not bFind
End With
Set oFileSystem = Nothing
End If
End Sub

[yonghengdizhen]

Private Function LoadTemplate(oWordApp As Word.Application, ByVal TemplatePath As String, ByVal SaveFileName As String, ByVal smallspec As String, ByVal BookType As String) As Word.Document
Dim oWordDoc As Word.Document
If smallspec = "法医现场" Or smallspec = "法医临床" Then
Set LoadTemplate = oWordApp.Documents.Open(TemplatePath & "\fy_jianding.doc")
LoadTemplate.SaveAs SaveFileName
If (smallspec <> "法医现场") Then
LoadTemplate.Bookmarks("尸检案由").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
LoadTemplate.Bookmarks("尸检现场情况").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
LoadTemplate.Bookmarks("尸检在场人员").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
End If
If (smallspec <> "法医临床") Then
LoadTemplate.Bookmarks("活体病历摘要").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
End If
If (BookType <> "鉴定书") Then
LoadTemplate.Bookmarks("鉴定书结论").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
End If
If (BookType <> "意见书") Then
LoadTemplate.Bookmarks("意见书意见").Select
oWordApp.Selection.Tables(1).Select
oWordApp.Selection.Tables(1).Delete
End If
ElseIf BookType = "鉴定书" Then
Set LoadTemplate = oWordApp.Documents.Open(TemplatePath & "\hn_jianding.doc")
LoadTemplate.SaveAs SaveFileName
ElseIf BookType = "报告书" Then
Set LoadTemplate = oWordApp.Documents.Open(TemplatePath & "\hn_baogao.doc")
LoadTemplate.SaveAs SaveFileName
ElseIf BookType = "意见书" Then
Set LoadTemplate = oWordApp.Documents.Open(TemplatePath & "\yijian.doc")
LoadTemplate.SaveAs SaveFileName
End If
End Function
'生成检验文书
Public Function CheckUp(CheckUpID As Variant, BookTitles As Variant, TemplatePath As Variant, SessionID As Variant, userid As Variant) As Variant
Dim oWordApp As New Word.Application
Dim oWordDoc As Word.Document, oTable As Word.Table
Dim fso As New FileSystemObject, stm As New ADODB.Stream
Dim arrTitle As Variant
Dim TopTitle As String, SaveFileName As String, strSQL As String, spec_no As String, UnitName As String
Dim autoid As String, sjr As String, sjdw As String, yjaq As String, jyyq As String, spld As String
Dim jysj As String, jyjl As String, zyjy As String
Dim jdr1 As String, jdr1post As String, jdr2 As String, jdr2post As String, zhuanye As String
Dim strMaterial, strAttachment As String
Dim jytime As Date, sjsj As Date
Dim i As Integer
Dim wslx As String
oWordApp.Visible = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open "DRIVER={Microsoft ODBC for Oracle};SERVER=database;UID=sxxz;PWD=sxxz;"

On Error GoTo ErrorHandler
'=============================取检验及委托数据用于文书生成 ===============================
strSQL = "SELECT MAX(spec_no)+1 AS specno FROM tblbook WHERE spec"
strSQL = strSQL & " IN(SELECT A.zdy4 FROM zdb A,tblcheckup B WHERE A.kind='382' AND A.Code=B.zhuanye AND B.id='" & Trim(CheckUpID) & "')"
rs.Open strSQL, conn
If Not rs.EOF Then
If Not IsNull(rs("specno")) Then
spec_no = rs("specno") + 1 '文书编号
Else
spec_no = 1
End If
Else
spec_no = 1
End If
rs.Close
strSQL = "SELECT B.zdy3 FROM tbluser A,zdb B WHERE A.ksdcode=b.code AND B.Kind='06' AND A.UserID='" & Trim(userid) & "'"
rs.Open strSQL, conn
If Not rs.EOF Then
UnitName = rs("zdy3") '用户所在单位简称
Else
'错误处理,用户数据为空
End If
rs.Close
strSQL = "SELECT A.autoid,A.sendman,A.senddate,A.unit,NVL(A.casedetail,' ') AS casedetail,NVL(A.requests,' ') AS requests,"
strSQL = strSQL & "nvl(B.SPLD,' ') AS spld,nvl(B.jysj,' ') AS jysj,nvl(B.jyjl,' ') AS jyjl,nvl(B.jlzyyj,' ') AS jlzyyj,"
strSQL = strSQL & "nvl(B.jyr,' ') AS jyr,nvl(B.jyr2,' ') AS jyr2,B.jytime,"
strSQL = strSQL & "nvl(C.zdy4,' ') AS zhuanye,nvl(D.zdy4,' ') AS zyxl,nvl(C.detail,' ') AS spec,nvl(D.Detail,' ') AS smallspec"
strSQL = strSQL & " FROM tblgaaccepta A,tblcheckup B,zdb C,zdb D"
strSQL = strSQL & " WHERE A.autoid=B.acceptno"
strSQL = strSQL & " AND B.zhuanye=C.Code(+) AND C.kind(+)='382'"
strSQL = strSQL & " AND B.zyxl=D.Code(+) AND D.kind(+)='400'"
strSQL = strSQL & " AND B.ID='" & CheckUpID & "'"
rs.Open strSQL, conn
If Not rs.EOF Then
autoid = rs("autoid")
sjr = rs("sendman") '送检人
sjsj = rs("senddate") '送检时间
sjdw = rs("unit") '送检单位
jyaq = rs("casedetail") '简要案情
jyyq = rs("requests") '检验要求
spld = rs("spld") '审批领导
jysj = rs("jysj") '检验
jyjl = rs("jyjl") '结论
zyyj = rs("jlzyyj") '论证(分析依据)
jysj = PreConvertHTML(jysj)
jyjl = PreConvertHTML(jyjl)
zyyj = PreConvertHTML(zyyj)
jdr1 = rs("jyr") '鉴定人1
jdr2 = rs("jyr2") '鉴定人2
jytime = rs("jytime") '检验时间
zhuanye = rs("zhuanye") '专业简称
zyxl = rs("zyxl") '专业小类简称
spec = rs("spec") '专业全称
smallspec = rs("smallspec") '专业小类全称
Else
'错误处理,委托或检验数据为空
End If
rs.Close
strSQL = "SELECT a.detail FROM zdb a,tbltechman b WHERE a.kind='389' AND a.code=b.techpost AND b.username='" & jdr1 & "'"
rs.Open strSQL, conn
If Not rs.EOF Then
jdr1post = rs("detail") '检定人职称
End If
rs.Close
strSQL = "SELECT a.detail FROM zdb a,tbltechman b WHERE a.kind='389' AND a.code=b.techpost AND b.username='" & jdr2 & "'"
rs.Open strSQL, conn
If Not rs.EOF Then
jdr2post = rs("detail") '检定人2职称
End If
rs.Close
strMaterial = GetMaterial(conn, rs, autoid)
strObjectInfo = GetObjectInfo(conn, rs, autoid)
strAttachment = GetAttachment(conn, rs, CheckUpID, SessionID)
arrTitle = Split(BookTitles, ",")

[yonghengdizhen]

For i = LBound(arrTitle) To UBound(arrTitle)
If spec = "法医" Then
zhuanye = zhuanye & zyxl '法医专业应加上专业小类的简称
End If
TopTitle = UnitName & "公刑技" & Trim(zhuanye) & "鉴字 〔" & Year(Now()) & "〕" & spec_no & "号"
SaveFileName = TemplatePath & "\" & userid & Year(Now()) & Month(Now()) & Day(Now()) & Hour(Now()) & Minute(Now()) & Second(Now()) & ".doc"
BookType = Right(Trim(arrTitle(i)), 3)
'==============================装载文书模板================================
Set oWordDoc = LoadTemplate(oWordApp, TemplatePath, SaveFileName, smallspec, BookType)
'==============================处理文书内容================================
ConvertHTML oWordApp, oWordDoc, "发文字号", TopTitle, 0
ConvertHTML oWordApp, oWordDoc, "文书标题", arrTitle(i), 0
ConvertHTML oWordApp, oWordDoc, "委托单位", sjdw, 0
ConvertHTML oWordApp, oWordDoc, "送检单位", sjdw, 0
ConvertHTML oWordApp, oWordDoc, "送检人", Replace(sjr, ";", " "), 0
ConvertHTML oWordApp, oWordDoc, "送检时间", sjsj, 0
ConvertHTML oWordApp, oWordDoc, "委托时间", sjsj, 0
ConvertHTML oWordApp, oWordDoc, "检验时间", jytime, 0
ConvertHTML oWordApp, oWordDoc, "简要案情", jyaq, 0
ConvertHTML oWordApp, oWordDoc, "案情摘要", jyaq, 0
ConvertHTML oWordApp, oWordDoc, "送检材料", strMaterial, 0
ConvertHTML oWordApp, oWordDoc, "检验对象", strObjectInfo, 0 '暂时未准备
ConvertHTML oWordApp, oWordDoc, "检验要求", jyyq, 0
If (BookType = "鉴定书") Then
ConvertHTML oWordApp, oWordDoc, "检验", jysj, 1
Else
ConvertHTML oWordApp, oWordDoc, "检验", jysj & zyyj, 1
End If
ConvertHTML oWordApp, oWordDoc, "检验所见", jysj, 1
ConvertHTML oWordApp, oWordDoc, "分析说明", zyyj, 1
ConvertHTML oWordApp, oWordDoc, "论证", zyyj, 1
ConvertHTML oWordApp, oWordDoc, "意见", jyjl, 1
ConvertHTML oWordApp, oWordDoc, "结论", jyjl, 1
ConvertHTML oWordApp, oWordDoc, "附件", strAttachment, 1
ConvertHTML oWordApp, oWordDoc, "鉴定人A职称", jdr1post, 0
ConvertHTML oWordApp, oWordDoc, "鉴定人A", jdr1, 0
ConvertHTML oWordApp, oWordDoc, "鉴定人B职称", jdr2post, 0
ConvertHTML oWordApp, oWordDoc, "鉴定人B", jdr2, 0
If oWordDoc.Bookmarks.Exists("文书生成日期") Then
oWordDoc.Bookmarks("文书生成日期").Select
oWordApp.Selection.Fields.Update
End If
oWordDoc.Close
'============================将文书添加进入数据库==============================
stm.Type = adTypeBinary
stm.Mode = adModeReadWrite
stm.Open
stm.LoadFromFile SaveFileName

wslx = "3"
If InStr(1, Trim(arrTitle(i)), "鉴") > 0 Then
wslx = "1"
End If

If InStr(1, Trim(arrTitle(i)), "意见") > 0 Then
wslx = "2"
End If

If InStr(1, Trim(arrTitle(i)), "报告") > 0 Then
wslx = "3"
End If




strSQL = "SELECT * FROM tblbook WHERE title='" & Trim(arrTitle(i)) & "' AND id='" & Trim(CheckUpID) & "'"
rs.Open strSQL, conn, adOpenKeyset, adLockOptimistic
If Not rs.EOF Then
rs("Lrsj") = Now()
rs("uptype") = "doc"
rs("zdy1") = wslx
rs("wjlj").AppendChunk stm.Read
rs.Update
Else
rs.AddNew
rs("jlbh") = Year(Now()) & Month(Now()) & Day(Now()) & Hour(Now()) & Minute(Now()) & Second(Now()) & i
rs("id") = CheckUpID
rs("title") = arrTitle(i)
rs("wjlj").AppendChunk stm.Read
rs("Lrr") = userid
rs("lrsj") = Now()
rs("spleader") = spld
rs("spec") = spec
rs("spec_no") = spec_no
rs("status") = 2
rs("uptype") = "doc"
rs("zdy1") = wslx

rs.Update
End If
rs.Close
stm.Close
fso.DeleteFile SaveFileName, True
Next
PostConvertHTML strAttachment
ErrorHandler:
conn.Close
oWordApp.Quit
Set stm = Nothing
Set fso = Nothing
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Function