VB高效导入Excel2003和Excel2007文件到MSHFlexGrid控件显示

1.VB高效导入Excel2003和Excel2007文件到MSHFlexGrid控件显示

2.以前也有Excel导入通用功能，但速度有些慢一会把两种实现方式都提供出为参考对比。

一、原通用导入excel文件到MSHFlexGrid控件如下：

Public Function DRExcel(fd As MSHFlexGrid, CD1 As CommonDialog) As Boolean   '导入Excel文件函数  20120621孙广乐

Dim file_name As String
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.worksheet
Dim xlQuery As Excel.QueryTable
Dim r   'r为行数
Dim i, j
On Error GoTo a:
file_name = ""
fnum = FreeFile
CD1.Flags = &H2
With CD1
  .Flags = cdlOFNHideReadOnly & cdlOFNOverwritePrompt
  ' 设置过滤器
  .Filter = "xls文档(*.xls)|*.xls|xlsx文档(*.xlsx)|*.xlsx"        '只能导入xls这种文件格式
   ' 指定缺省的过滤器
  .FilterIndex =
  '.ShowSave
  .ShowOpen
  file_name = .filename
End With

If file_name = "" Then       '判断文件是否存在
  DRExcel = False
  Exit Function
End If

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
'xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open(file_name)
Set xlSheet = xlBook.Worksheets()

'测列数
j =
Do While xlSheet.Cells(, j) <> ""
 j = j +
Loop
i =
Do While xlSheet.Cells(i, ) <> ""
 i = i +
Loop
If j =  Or i =  Then
  MsgBox "不允许导入空表！"
  DRExcel = False
  Exit Function
End If

fd.Visible = True
fd.rows = i -
fd.Cols = j - 

For i =  To fd.rows

  For j =  To fd.Cols  '列数
         fd.TextMatrix(i - , j - ) = xlSheet.Cells(i, j)
  Next j
Next i

'xlApp.Application.Visible = True

xlBook.Close
xlApp.Quit   '"交还控制给Excel

fd.ColAlignment() =  '物品代码
MsgBox "完成导入"
fd.FixedRows =
fd.FixedCols =
CD1.filename = ""
DRExcel = True
a:
End Function

二、新方法，高效把excel文件导入到MSHFlexGrid控件。这个非常高效。如下：

FGrid1.FixedCols = 

Dim file_name As String
file_name = ""
CD1.Flags = &H2
With CD1
  .Flags = cdlOFNHideReadOnly & cdlOFNOverwritePrompt
  ' 设置过滤器
  .Filter = "xls文档(*.xls)|*.xls|xlsx文档(*.xlsx)|*.xlsx"        '只能导入xls这种文件格式
   ' 指定缺省的过滤器
  .FilterIndex =
  '.ShowSave
  .ShowOpen
  file_name = .filename
End With

If file_name = "" Then       '判断文件是否存在
    MsgBox ("选择的文件已经不存在了")
  Exit Sub
End If

Dim excelid As Excel.Application
    Set excelid = New Excel.Application
    excelid.Workbooks.Open (file_name)

    excelid.ActiveWindow.SplitRow =
    excelid.ActiveWorkbook.save
    excelid.ActiveWorkbook.Close
    excelid.Quit

Dim CHART1 As New ADODB.Connection, chart2 As New ADODB.Recordset
    CHART1.CursorLocation = adUseClient

    If Right(file_name, ) = ".xlsx" Then 'excel2007版本以上
        CHART1.Open "Provider=Microsoft.ACE.OLEDB.12.0;Persist Security Info=False;Data Source=" & file_name & ";Extended Properties='Excel 12.0;HDR=Yes'"
    Else
        CHART1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & file_name & ";Extended Properties='Excel 8.0;HDR=Yes'"
    End If
    Dim rs As ADODB.Recordset
    Set rs = CHART1.OpenSchema(adSchemaTables)
    Dim ls_name As String
    ls_name = rs.Fields().Value '取哪个sheet页数据
    chart2.Open "select * From [" & ls_name & "]", CHART1, adOpenKeyset, adLockOptimistic
    Set FGrid1.DataSource = chart2

Set CHART1 = Nothing
Set chart2 = Nothing
    

作者：王春天  2013.11.14  地址：http://www.cnblogs.com/spring_wang/p/3423105.html