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 = 1

  '.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(1)

    

'测列数

j = 1

Do While xlSheet.Cells(1, j) <> ""

 j = j + 1

Loop

i = 1

Do While xlSheet.Cells(i, 1) <> ""

 i = i + 1

Loop

If j = 1 Or i = 1 Then

  MsgBox "不允许导入空表！"

  DRExcel = False

  Exit Function

End If



fd.Visible = True

fd.rows = i - 1

fd.Cols = j - 1

    

For i = 1 To fd.rows

     

  For j = 1 To fd.Cols  '列数

         fd.TextMatrix(i - 1, j - 1) = xlSheet.Cells(i, j)

  Next j

Next i

    

'xlApp.Application.Visible = True



xlBook.Close

xlApp.Quit   '"交还控制给Excel



fd.ColAlignment(0) = 0 '物品代码

MsgBox "完成导入"

fd.FixedRows = 1

fd.FixedCols = 0

CD1.filename = ""

DRExcel = True

a:

End Function

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

FGrid1.FixedCols = 0



Dim file_name As String

file_name = ""

CD1.Flags = &H2

With CD1

  .Flags = cdlOFNHideReadOnly & cdlOFNOverwritePrompt

  ' 设置过滤器

  .Filter = "xls文档(*.xls)|*.xls|xlsx文档(*.xlsx)|*.xlsx"        '只能导入xls这种文件格式

   ' 指定缺省的过滤器

  .FilterIndex = 1

  '.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 = 0

    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, 5) = ".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(2).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