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/，如需轉載，請註明出處，否則將追究法律責任。

vb操作Word[兩個過程]

相關文章