VB高效导入Excel2003和Excel2007文件到MSHFlexGrid控件显示
2013年11月14日 作者：Admin
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控件。这个很是高效。如下：
部件中添加Microsoft Common Dialog Control 6.0控件，然后拖入窗体中；
FGrid1改成表格控件名称（如MSHFlexGrid1），cd1改成Common Dialog控件名称（如CommonDialog1） 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 " * 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
|
