首页 > > 程序设计 > delphi >

VB高效导入Excel2003和Excel2007文件到MSHFlexGr…

2018-06-17 21:09:40来源：未知阅读 ()

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