vb如控制word模版将检索到的数据按照模版格式批量生成报告?

Question

Private Sub wordexport_Click()
 Dim count  As Integer
 Dim i As Integer
 count = Adodc1.Recordset.RecordCount
 If count < 1 Then
                MsgBox "无记录打印", vbOKOnly, "提示"
                AdoRs.Close
                Exit Sub
 Else Adodc1.Recordset.MoveFirst
       WordTemps.Documents.Add App.Path + "\取水报告.doc", False
       WordTemps.Selection.WholeStory
       WordTemps.Selection.Copy
       WordTemps.Selection.InsertBreak Type:=wdPageBreak
 For i = 1 To count - 1
    If Adodc1.Recordset.EOF = False Then
       WordTemps.Selection.Paste '粘贴
     End If
 Next i
           WordTemps.Selection.Goto wdGoToBook, , , "表头"
 For i = 1 To count - 1
      On Error Resume Next
      Adodc1.Recordset.MoveNext
   If Adodc1.Recordset.EOF = False Then
           WordTemps.Selection.MoveDown , 9
           WordTemps.Selection.MoveRight Unit:=wdCharacter, count:=10 
            '移动插入位置
            WordTemps.Selection.TypeText Adodc1.Recordset!pH
            WordTemps.Selection.MoveDown
            WordTemps.Selection.TypeText Adodc1.Recordset!色度
            ......  
   End If
Next i
                WordTemps.Visible = True    '显示WORD窗口我用的是移动光标的笨办法,可是光标在移动的过程中老是出错.谁有好方法,拜谢.

Answer 1

这个要挺有耐心的去调试  我只做过EXCEL的 那记录宏代码 已经把我看晕了 有时候就懒得分析了一大堆代码直接贴上去

Answer 2

我弄出来了.
方法比较笨,抛砖引玉吧,希望对大家有帮助.rivate Sub cmd2_Click()
 Dim count  As Integer
 Dim i As Integer
 
      count = Adodc1.Recordset.RecordCount
 If count < 1 Then
      MsgBox "无记录打印", vbOKOnly, "提示"
      AdoRs.Close
      Exit Sub
 Else
      Adodc1.Recordset.MoveFirst
      WordTemps.Documents.Add App.Path + "\取水报告.doc", False
      WordTemps.Selection.WholeStory
      WordTemps.Selection.Copy
 End If
 For i = 1 To count
      On Error Resume Next
     
   If Adodc1.Recordset.EOF = False Then
      WordTemps.Selection.Paste '粘贴
      
           Call WordReplace("strpH", Adodc1.Recordset!pH)
           Call WordReplace("str色", Adodc1.Recordset!色度)
           Call WordReplace("str浑", Adodc1.Recordset!浑浊度)
          ......
            WordTemps.Selection.MoveEnd
            
     End If
      Adodc1.Recordset.MoveNext
Next i
                WordTemps.Visible = True    '显示WORD窗口
                WordTemps.Documents.Close
                WordTemps.Quit
                'Set WordTemps.Document = Nothing
                Set WordTemps = Nothing
                Adodc1.Recordset.Close
End SubPrivate Sub cmd3_Click()Unload Me
End SubFunction WordReplace(SearchString As String, ReplaceString As String, Optional MatchCase As Boolean = False) As Boolean
      '执行WORD   的替换操作，循环进行
      On Error GoTo ErrorMsg         '函数运行时发生遇外或错误,转向错误提示信息
     Set wordArange = WordTemps.ActiveDocument.Range(0, 1)           '指定文件编辑位置
      wordArange.Select   '激活编辑位置      WordReplace = wordArange.find.Execute(SearchString, MatchCase, , , , , , wdFindContinue, , ReplaceString, True)                           '查找并替换
      Exit Function    
ErrorMsg:
      MsgBox Err.Number & ":" & Err.Description             '提示错误信息
      WordReplace = False       '返回错误信息值
      wordDoc.Close   '关闭文档实例
      wordApp.Quit   '关闭WORD实例
      Set wordDoc = Nothing         '清除文件实例
      Set wordApp = Nothing         '清除WORD实例
  

Answer 3

private sub Command1Click()
Dim i As Integer
Dim ifieldcount As Integer
Dim ircordcount As Integer
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim atable As Word.Table
Set wdapp = CreateObject("Word.Application")
Set wddoc = wdapp.Documents.Add
ircordcount = Adodc1.Recordset.RecordCount
wdapp.Visible = True
wdapp.Activate
Set atable = wdapp.ActiveDocument.Tables.Add(wdapp.Selection.Range, ircordcount + 1, 8)'这里表示行数和列数。ircordcount + 1是行数，因为要有表头多以行数要比记录数多一行，列数为8，有多少字段就要多少列atable.Cell(1, 1).Range.InsertAfter "字段1"
atable.Cell(1, 2).Range.InsertAfter "字段2"
atable.Cell(1, 3).Range.InsertAfter "字段3"
atable.Cell(1, 4).Range.InsertAfter "字段4"
atable.Cell(1, 5).Range.InsertAfter "字段5"
atable.Cell(1, 6).Range.InsertAfter "字段6"
atable.Cell(1, 7).Range.InsertAfter "字段7"
atable.Cell(1, 8).Range.InsertAfter "字段8"
If Adodc1.Recordset.RecordCount > 0 Then
ircordcount = Adodc1.Recordset.RecordCount
Adodc1.Recordset.MoveFirst
Do While Adodc1.Recordset.AbsolutePosition <> adPosEOF
atable.Cell(DataGrid1.Book + 1, 1).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 2).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 3).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 4).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 5).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 6).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 7).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 8).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
Adodc1.Recordset.MoveNext
Loop
If Adodc1.Recordset.AbsolutePosition = adPosEOF Then
atable.Cell(DataGrid1.Book + 1, 1).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 2).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 3).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 4).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 5).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 6).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 7).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
atable.Cell(DataGrid1.Book + 1, 8).Range.InsertAfter Adodc1.Recordset.Fields("字段名") & ""
End If
Set wdapp = Nothing
Set wddoc = Nothing
Else
MsgBox "没有可显示记录", , "提示"
End If
end sub

Answer 4

别忘了在工程——引用里面把word勾上