ITPub博客

首页 > Linux操作系统 > Linux操作系统 > vb操作Word[两个过程]

vb操作Word[两个过程]

原创 Linux操作系统 作者:iDotNetSpace 时间:2009-07-03 18:13:56 0 删除 编辑
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(21), 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(11), 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(00)
  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/,如需转载,请注明出处,否则将追究法律责任。

请登录后发表评论 登录
全部评论

注册时间:2008-01-04

  • 博文量
    2376
  • 访问量
    5303907