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

  • 0
    点赞
  • 2
    收藏
    觉得还不错? 一键收藏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值