vb操作Word[两个过程]

Public conDb As String
    Public Sub exportWordReport(rs As ADODB.Recordset, filePath As String)
    Dim WordApp As word.Application
        Err.Number = 0
        On Error GoTo notloaded
       ' Set WordApp = GetObject(, "Word.Application")
'notloaded:
      '  If Err.Number = 429 Then
            Set WordApp = CreateObject("Word.Application")
          '  theError = Err.Number
       ' End If
        WordApp.Visible = True
        
        With WordApp
            Set newDoc = .Documents.Add
            With .Selection
           ' .InsertCaption Label, "报表表格"
            Dim i, j As Integer
            i = 0
            j = 0
            For i = 1 To rs.Fields.count Step 1
                    .InsertAfter Text:=rs.Fields(i - 1).Name
                    If i <> rs.Fields.count Then .InsertAfter Text:=vbTab
                    Next i
                    .InsertAfter Text:=vbCr
                rs.MoveFirst
                While Not rs.BOF And Not rs.EOF  'Worksheets("Sheet1").Range("A1:B10")
                For j = 1 To rs.Fields.count Step 1
                  If IsNull(rs.Fields(j - 1).Value) Then
                    .InsertAfter "    "
                  Else
                    .InsertAfter Text:=rs.Fields(j - 1).Value
                  End If
                    If j <> rs.Fields.count Then .InsertAfter Text:=vbTab
                    Next j
                    .InsertAfter Text:=vbCr
                    'count = count + 1
                    'If count Mod rs.Fields.count = 0 Then  '2
                   '     .InsertAfter Text:=vbCr
                   ' Else
                  '      .InsertAfter Text:=vbTab
                  '  End If
                    rs.MoveNext
                Wend 'Next
                .Range.ConvertToTable Separator:=wdSeparateByTabs
                .Tables(1).AutoFormat Format:=wdTableFormatClassic1
                '.Select
                '.InsertAfter vbCr
               ' .InsertDateTime "yyyy-mm-dd  hh:mm:ss"
            End With
            newDoc.SaveAs FileName:=filePath
        End With
        
       ' If theError = 429 Then WordApp.Quit
        Set WordApp = Nothing
        Exit Sub
notloaded:
MsgBox "无法执行导出Word报表操作," & errMsg, vbCritical, "导出Word报表提示"
End Sub

Public Sub exportFormExcelTable(ByVal sql As String, title As String)
 On Error GoTo errlabel
 '进行数据转换
 
 '打开数据库

 '把数据导入EXCEL
  Dim cn As New ADODB.Connection
  Dim rs As New ADODB.Recordset
  cn.Open conDb
  rs.Open sql, cn, adOpenKeyset, adLockOptimistic '"select * from customers "
  If rs.RecordCount > 0 Then
    Dim ex As New EXCEL.Application
    Dim exbook As New EXCEL.Workbook
    Dim exsheet As New EXCEL.Worksheet
    Set exbook = ex.Workbooks.Add '添加一个新的BOOK
    Set exsheet = exbook.Worksheets("sheet1") '把sheet1作为当前操作的sheet,添加一个新的SHEET exbook.Worksheets.Add
    Dim count As Integer
    count = rs.Fields.count - 1
    exsheet.Cells(1, count / 2).Value = title
    For j = 0 To count Step 1
      exsheet.Cells(2, j + 1).Value = rs.Fields(j).Name
    Next j
  Dim i, k As Integer
  i = 3
  k = 0
  rs.MoveFirst
  While (Not rs.EOF And Not rs.BOF)
  For k = 0 To count
  'ex.Range(Chr(65 + k) & i).Value = rs.Fields(k).Value
  ex.Cells(i, k + 1) = rs.Fields(k).Value
  Next k
  i = i + 1
  rs.MoveNext
  Wend
  '画表格
  With ex
    'Range("A2:" & Chr(65 + count) & (rs.RecordCount + 2)).Select
    .Range(Cells(2, 1), Cells(rs.RecordCount + 2, count + 1)).Select
    .Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    .Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With .Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
   'ex.Visible = True
   'exsheet.Range("A1:" & Chr(65 + count) & (rs.RecordCount + 2)).Select
   exsheet.Range(Cells(1, 1), Cells(rs.RecordCount + 2, count + 1)).Select
   .Selection.Copy
   End With
  rs.Close
  cn.Close
  Dim word As word.Application
  Set word = CreateObject("Word.Application")
  With word
  .Documents.Add
  With .Selection
  Dim excelData As Object
  Set excelData = word.ActiveDocument.Range(0, 0)
  excelData.PasteSpecial
  '    .Paste  'ExcelTable False, True, False
  End With
  '.Documents(1).SaveAs "C:\1.doc"
  word.Visible = True
  End With
  
  Set excelData = Nothing
  Set word = Nothing
  ex.DisplayAlerts = False
  ex.Quit
  Set exbook = Nothing
  Set exsheet = Nothing
  Set ex = Nothing
  
  Else
  MsgBox "没有数据源,无法执行导出Word报表操作!", vbOKOnly, "导出Word报表提示"
  End If
  Exit Sub
errlabel:
  MsgBox "无法执行导出Word报表操作," & errMsg, vbCritical, "导出Word报表提示"
End Sub

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/12639172/viewspace-608291/，如需转载，请注明出处，否则将追究法律责任。

转载于:http://blog.itpub.net/12639172/viewspace-608291/