200分请教word报表动态生成,up者给分

您好，这是一段excel的，给你借鉴一下  'Dim xlApp As Excel.Application
        'Dim xlBook As Excel.Workbooks
        'Dim XlSheet As Excel.Worksheets
        'xlApp = CreateObject("Excel.Application")
        'xlBook = xlApp.Workbooks.Add
        '' XlSheet = xlBook.Worksheets(1)        'xlApp.Visible = True        'XlSheet.Cells(1, 1).Value = "test"        'xlApp = Nothing
        'xlBook = Nothing
        'XlSheet = Nothing

Private Sub create_word_rpt(code As String, name As String)
   On Error GoTo lable_1
   Set oWord = Nothing
   Set oDoc = Nothing   Dim sTemp As String
   Set oRS = New ADODB.Recordset
   oRS.Open " exec rpt_yszl '" + code + "' ", cnn_base, adOpenKeyset, adLockReadOnly
   If oRS.RecordCount < 1 Then
      MsgBox "记录数为零，不能生成报表。", vbOKOnly, "提示"
      Exit Sub
   End If
   sTemp = oRS.GetString(adClipString, -1, vbTab)
   Dim i As Integer
   Dim ss As String
   ss = ""
   For i = 0 To oRS.Fields.count - 1
     If i < oRS.Fields.count - 1 Then
         ss = ss & oRS.Fields(i).name & vbTab
     Else
         ss = ss & oRS.Fields(i).name
     End If
   Next
   sTemp = ss & vbCrLf & sTemp
   oRS.Close
   Set oRS = Nothing
   Set oWord = CreateObject("Word.Application")
   oWord.Documents.Add  'App.Path + "temp.doc", False, 0
   Set oDoc = oWord.ActiveDocument
   On Error GoTo lable_2
   With oDoc.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(2.54)
        .BottomMargin = CentimetersToPoints(2.54)
        .LeftMargin = CentimetersToPoints(2.17)
        .RightMargin = CentimetersToPoints(2.17)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.5)
        .FooterDistance = CentimetersToPoints(1.75)
        .PageWidth = CentimetersToPoints(29.7)
        .PageHeight = CentimetersToPoints(21)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .GutterPos = wdGutterPosLeft
        .LayoutMode = wdLayoutModeLineGrid
   End With
lable_2:
    With oWord.Selection
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Font.Size = 20
          .Font.Bold = wdToggle
          .TypeText "应收帐款帐龄分析"
          .TypeParagraph
          .TypeParagraph
           .ParagraphFormat.Alignment = wdAlignParagraphLeft
          .Font.Size = 10
          .Font.Bold = wdToggle
           .TypeText "地区: " + name + "                       制表人：" + zy_operator + "                        制表日期：" + ndate
          .EndKey wdLine
          .InsertAfter "                                         单位：元"
          .EndKey wdLine
          .TypeParagraph
          Set oRange = .Range
   End With
   oRange.Text = sTemp
   oRange.ConvertToTable vbTab, , , , 0 'wdTableFormatColorful2
   With oDoc.Tables(1)
        .Columns(1).Width = 130
        .Columns(2).Width = 35
        .Columns(3).Width = 50
        .Columns(4).Width = 50
        .Columns(5).Width = 50
        .Columns(6).Width = 50
        .Columns(7).Width = 50
        .Columns(8).Width = 50
        .Columns(9).Width = 50
        .Columns(10).Width = 50
        .Columns(11).Width = 60
        .Columns(12).Width = 60
        .Columns(13).Width = 30
        .Rows(1).Select
        .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
         Dim r_count As Integer
         r_count = .Rows.count
         .Rows.Add
         .Cell(r_count + 1, 1).Range.Text = "合   计"
         .Cell(r_count + 1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
         .Cell(r_count + 1, 11).Select
         oWord.Selection.InsertFormula Formula:="=SUM(above)", NumberFormat:="0.00"
         .Cell(r_count + 1, 12).Select
         oWord.Selection.InsertFormula Formula:="=SUM(above)", NumberFormat:="0.00"
         .Select
         oWord.CommandBars("Formatting").Controls.Item(12).Execute
'         oDoc.PrintOut
        oWord.Visible = True
    End With
    Set oDoc = Nothing
    Set oWord = Nothing
    Exit Sub
lable_1:
     Err.Clear
     MsgBox "生成报表出错。", vbOKOnly, "提示"
     Set oDoc = Nothing
     Set oWord = Nothing
End Sub

本人在写一个报表工具
主要思想：动态生成Sql语句,然后导出到Excel
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer

    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable

    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
  '  Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
    With Rs_Data
      '  .MoveFirst
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With

    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh

    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With

'    With xlSheet.PageSetup
'        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
'        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日期："
'        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
'        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
'        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
'        .RightFooter = "&""楷体_GB2312,常规""&10第&P页共&N页"
'    End With

    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = NothingEnd Function
1、总体概述万能报表分为报表生成、报表打印和数据维护三个部分,此报表工具提供系统中的表结构，通过向导自动生成SQL语句，作为数据来源，能够灵活设置报表格式、数据汇总，使用户能够快速生成所需报表。提供报表预览、数据导出到EXCEL2000等功能接口。使熟悉业务的企业一般管理人员，通过阅读本手册或短期的数据库知识培训，就能够制作自己需要的报表。
2、1万能报表报表生成部分的使用万能报表报表生成部分是此模块的核心部分，用户在进行一系列的选择所需要的表，所需字段、条件和关联、分组，排序后，生成所对应的数据查询，程序根据用户生成的查询从数据库中提取数据。
（1）       选表（此项为必选项）在(图1.1)所示左边的区域中,左边树状结构的区域中列出了数据库的所有表，每几个有相应关系的表归在一类中，若数据库的表较多，在左面树状结构的区域中右键，可弹出菜单进行相应的操作。表的增加：在如下所示的界面中,在左边的区域选中一个表后，再点击按钮进行表的选择，将其加入右边的选择框中。表的删除：在右边的区域中，选择一个表后，再点击按钮 ,将所选表移出。
（2）       关联如果用户选择两个或两个以上的表，则须进行关联选择（一个表不需要关联），关联是两个表的字段进行的联结，如（图1.2）所示的“订单明细、订单号=订单、订单号”，意为这两个表的“订单号”进行关联。用户在左右的两个选择框中进行表和字段的选择后，点击则将关联加入下面的显示框中，表示此关联已选择。(3)选择字段所谓的字段选择就是表中列的选择，如（图1.3）所示，左边树状区域列出了所选择的表的所有列，用户选择所需的列后，再点击可将所选择的列加入右边的选择框中，表示此列已选择，用户可以用进行移除。为了控制报表中字段的显示顺序，可以用  来调整字段在报表中的位置，程序默认的列的顺序按右边选择框所示，  则将所选择的所有字段清除，以便用户重新选择所需列。  图1.3按钮的作用是将所选择的关联条件全部清除。图1.2选择完“关联”后，点击进行下一个操作。当然，用户需修改可回上一步。  (8)页面设置在图1.8中，可以进行页面的设置，可以选择纸张，左右边距，进行纸张方向的选择。选择完成后点击，将弹出图1.9所示屏幕。　
2、2万能报表报表打印部分的使用万能报表的打印，如下图：列出用户自己创建的所有报表。此时以大图标的样式呈现在用户面前，如果用户创建的报表很多，可以点击左下角的“小图标”和“列表”选项，用小图标或列表的方式显示，以便用户观看。当用户选中一个报表后，可以点击右边的“常规报表”按钮进行此报表的打印操作，点击“EXCEL报表”，将此报表的数据输入到EXCEL   中，用户可以在电子表格处理软件中对数据进行编排。“删除报表”和“修改报表”可以进行此报表的删除和修改操作。图2.1用户选中一个报表后，单击鼠标右键，会出现如下所示的菜单，菜单的功能同上。图2.2

这是操作word表格等的。你看看
其实要什么功能自己录制宏好了。如果统计的话就用域操作。
        AppWd.Selection.MoveEnd wdStory
'        myDoc.Range.Move 1
        myDoc.Range.Paragraphs.Add
        AppWd.Selection.MoveDown wdLine, 1
        AppWd.Selection.Style = myDoc.Styles("标题 3")
        myDoc.Range.InsertAfter sTableName
        myDoc.Range.Paragraphs.Add
        AppWd.Selection.MoveDown wdLine, 1
        AppWd.Selection.Style = myDoc.Styles("正文")
        AppWd.Selection.MoveDown wdLine, 1
'        AppWd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        Set MyTable = myDoc.Tables.Add(Range:=AppWd.Selection.Range, numrows:=m, numcolumns:=6)
'        AppWd.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
        MyTable.Select
        AppWd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        MyTable.ID = sTableName
        myDoc.Range.Paragraphs.Add

                Dim x As Integer
        MyTable.Columns(1).Width = CentimetersToPoints(1.14)
        MyTable.Columns(2).Width = CentimetersToPoints(2.54)
        MyTable.Columns(3).Width = CentimetersToPoints(5.71)
        MyTable.Columns(4).Width = CentimetersToPoints(2.22)
        MyTable.Columns(5).Width = CentimetersToPoints(1.9)
        MyTable.Columns(6).Width = CentimetersToPoints(1.9)


        For n = 1 To m - 1

            If n = 1 Then

                MyTable.Cell(1, 1).Range.InsertAfter "序号"
                MyTable.Cell(1, 2).Range.InsertAfter "字段名"
                MyTable.Cell(1, 3).Range.InsertAfter "中文说明"
                MyTable.Cell(1, 4).Range.InsertAfter "字段类型"
                MyTable.Cell(1, 5).Range.InsertAfter "字段长度"
                MyTable.Cell(1, 6).Range.InsertAfter "备注"
'                For x = 1 To 6
'                    MyTable.Cell(n, x).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'                Next x
            End If
'            MyTable.Cell(n + 1, 1).Range.ParagraphFormat.Alignment = 1
'            mytable.cell(n + 1, 1).Range.Font.Name = "宋体"
'            mytable.cell(n + 1, 1).Range.Font.Size = 14
            MyTable.Cell(n + 1, 1).Range.InsertAfter n
            MyTable.Cell(n + 1, 2).Range.InsertAfter rsTableContents.Fields(n - 1).Name

            MyTable.Cell(n + 1, 4).Range.InsertAfter FieldType(rsTableContents.Fields(n - 1).Type)

            MyTable.Cell(n + 1, 5).Range.InsertAfter rsTableContents.Fields(n - 1).DefinedSize
'            MyTable.Cell(n + 1, 6).Range.InsertAfter rsTableContents.Fields(n - 1).Name
'            For x = 1 To 6
'                MyTable.Cell(n + 1, x).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'            Next x
        Next n

wzsswz在word方面确实有一手，lihonggen0也不赖，这躺没白来，收藏！

'定义Word对象
   Dim objWord As Object
   Dim i As Long
   Dim arrColValue() As String

   '创建Word对象
   Set objWord = CreateObject("Word.Application")
   objWord.Visible = True

   Dim NewDoc As Object
   Set NewDoc = objWord.Documents.Add
   '设置页边距
   With NewDoc.PageSetup
    .LeftMargin = 56.7
    .RightMargin = 56.7
    .TopMargin = 56.7
    .BottomMargin = 56.7
    .Gutter = 14.175
   End With
   '设置页眉、页脚
   If NewDoc.ActiveWindow.View.SplitSpecial <> 0 Then
       NewDoc.ActiveWindow.Panes(2).Close
   End If
   If NewDoc.ActiveWindow.ActivePane.View.Type = 1 Or NewDoc.ActiveWindow. _
       ActivePane.View.Type = 2 Then
       NewDoc.ActiveWindow.ActivePane.View.Type = 3
   End If
   NewDoc.ActiveWindow.ActivePane.View.SeekView = 9
   objWord.Selection.ParagraphFormat.Alignment = 0
   objWord.Selection.TypeText Text:=tvwMain.SelectedItem.Text & "_报告名称" & vbTab & vbTab
   objWord.Selection.Fields.Add Range:=objWord.Selection.Range, Type:=31   '日期

   If objWord.Selection.HeaderFooter.IsHeader = True Then
       NewDoc.ActiveWindow.ActivePane.View.SeekView = 10
   Else
       NewDoc.ActiveWindow.ActivePane.View.SeekView = 9
   End If

   objWord.Selection.TypeText Text:="页脚" & vbTab & vbTab & "第 "
   objWord.Selection.Fields.Add Range:=objWord.Selection.Range, Type:=33   '页码
   objWord.Selection.TypeText Text:="/"
   objWord.Selection.Fields.Add Range:=objWord.Selection.Range, Type:=26           '页数
   objWord.Selection.TypeText Text:=" 页"
   NewDoc.ActiveWindow.ActivePane.View.SeekView = 0

   '插入空行
   Dim EmptyRange1 As Object
   Set EmptyRange1 = NewDoc.content
   With EmptyRange1
      '居中
      .ParagraphFormat.Alignment = 1
      '回车
      .InsertAfter vbCrLf
      '五号
      .Font.Bold = False
      .Font.Size = 10.5
   End With
   '插入标题
   Dim TitleRange As Object
   Set TitleRange = NewDoc.content
   With TitleRange
      '定位到文档尾
      .moveEnd unit:=1, count:=-1
      .Collapse Direction:=0
      '居中
      .ParagraphFormat.Alignment = 1
      '填入标题并回车
      .InsertAfter tvwMain.SelectedItem.Text
      .InsertAfter vbCrLf
      '粗体、小二
      .Font.Bold = True
      .Font.Size = 18
   End With
   '插入空行
   Dim EmptyRange2 As Object
   Set EmptyRange2 = NewDoc.content
   With EmptyRange2
      '定位到文档尾
      .moveEnd unit:=1, count:=-1
      .Collapse Direction:=0
      '左对齐
      .ParagraphFormat.Alignment = 0
      '回车
      .InsertAfter vbCrLf
      .InsertAfter vbCrLf
      '五号
      .Font.Bold = False
      .Font.Size = 10.5
   End With

   '填入内容
   For i = 1 To lvwTestPionts.ListItems.count
      '取出该行所有要打印的列的值
      Call SelectPrintCol(lvwTestPionts, i, arrColValue)

      With NewDoc.content
         '定位到文档尾
         .moveEnd unit:=1, count:=-1
         .Collapse Direction:=0
         '左对齐
         .ParagraphFormat.Alignment = 0
         '如果是首次打印或者项目层次号发生变化，则打印项目层次号
         If i = 1 Or m_strPreviousTitle <> arrColValue(6) Then
            .InsertAfter arrColValue(5) & "  " & arrColValue(6)
            .InsertAfter vbCrLf
         End If
         '五号
         .Font.Bold = True
         .Font.Size = 14
      End With

      With NewDoc.content
         '定位到文档尾
         .moveEnd unit:=1, count:=-1
         .Collapse Direction:=0
         '左对齐
         .ParagraphFormat.Alignment = 0
         .InsertAfter "用例ID #" & arrColValue(0)
         '四号
         .Font.Bold = False
         .Font.Size = 14
      End With

      With NewDoc.content
         '定位到文档尾
         .moveEnd unit:=1, count:=-1
         .Collapse Direction:=0
         '左对齐
         .ParagraphFormat.Alignment = 0
         .InsertAfter vbCrLf
         .InsertAfter "名称1："
         .InsertAfter vbCrLf
         .InsertAfter vbTab
         .InsertAfter arrColValue(1)
         .InsertAfter vbCrLf
         .InsertAfter "名称2："
         .InsertAfter vbCrLf
         .Font.Bold = False
         .Font.Size = 10.5
      End With

      With NewDoc.content
         '定位到文档尾
         .moveEnd unit:=1, count:=-1
         .Collapse Direction:=0
         '左对齐
         .ParagraphFormat.Alignment = 0
         '缩进
         .InsertAfter arrColValue(2)
         .InsertAfter vbCrLf
         '左右缩进都为0
         .ParagraphFormat.LeftIndent = 0
         .ParagraphFormat.RightIndent = 0
         '首行缩进1厘米（1厘米＝28.35磅）
         .ParagraphFormat.FirstLineIndent = 28.35
         '单倍行距
         .ParagraphFormat.LineSpacingRule = 0
      End With

      With NewDoc.content
         '定位到文档尾
         .moveEnd unit:=1, count:=-1
         .Collapse Direction:=0
         '左对齐
         .ParagraphFormat.Alignment = 0
         .ParagraphFormat.LeftIndent = 0
         .InsertAfter "预期结果：" & vbCrLf
         .InsertAfter vbTab
         .InsertAfter arrColValue(3)
         '回车
         .InsertAfter vbCrLf
      End With
      '记住项目层次号
      m_strPreviousTitle = arrColValue(6)
   Next i

   '释放Word对象
   Set NewDoc = Nothing
   Set objWord = Nothing

调试易

200分请教word报表动态生成,up者给分

解决方案 »