作者：未知 来源：月光软件站 加入时间：2005-2-28　月光软件站

工程引用说明：本代码的使用是基于Microsoft Excel 2003使用的，未在其它版本的Office上测试过，因此在VB中应当引用Microsoft Excel 11.0
代码其它内容说明：本代码中使用了VsFlexGrid做为源数据；并且可以命名EXCEL 工作单（SHEET）的名称，其中第一段代码是将内容保存到一个新的EXCEL 工作簿中，而第二个则是将内容保存到一个已存在的工作簿中。

为了显示进度，我使用了一个显示进度的窗体，frmPBar，可以去掉相关的该段代码。

Public Sub GridToExcel(srcGrid As VSFlexGrid, shName As String)
    '将Grid中的数据导出到Excel表格中
    Dim i As Integer
    Dim j As Integer
   
    Dim appXL As Variant
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Dim rng, rng1, rng2 As Excel.Range
   
    On Error GoTo errhandler
   
    Set appXL = CreateObject("Excel.Application")
    Set wb = appXL.Workbooks.Add()
   
    wb.Activate
   
    Set sh = wb.Worksheets.Add()
    sh.Name = shName
   
    frmPBar.Caption = "正在导出数据，请稍候......"
    frmPBar.Show
   
    For i = 0 To srcGrid.Rows - 1
        For j = 1 To srcGrid.Cols - 1
            sh.Cells(i + 1, j) = srcGrid.Cell(flexcpText, i, j)
            DoEvents
        Next j
    Next i
   
    Unload frmPBar
       
    appXL.Visible = True
    Exit Sub
errhandler:
    MsgBox Err.Description
   
End Sub

Public Sub GridToExistExcel(srcGrid As VSFlexGrid, fileName As String, shName As String)
    '将Grid中的数据导出到一个指定文件的Excel表格中
    Dim i As Integer
    Dim j As Integer
   
    Dim appXL As Variant
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Dim rng, rng1, rng2 As Excel.Range
   
    On Error GoTo errhandler
   
    Set appXL = CreateObject("Excel.Application")
    'Set wb = appXL.Workbooks.Add()
    Set wb = appXL.Workbooks.Open(fileName)
    wb.Activate
   
    Set sh = wb.Worksheets.Add()
    sh.Name = shName
   
    frmPBar.Caption = "正在导出数据，请稍候......"
    frmPBar.Show
    For i = 0 To srcGrid.Rows - 1
        For j = 1 To srcGrid.Cols - 1
            sh.Cells(i + 1, j) = srcGrid.Cell(flexcpText, i, j)
            DoEvents
        Next j
    Next i
    Unload frmPBar
   
    appXL.Visible = True
    Exit Sub
errhandler:
    MsgBox Err.Description
   
End Sub

相关软件：