vb6操作execl导入导出数据库源代码

VB6操作EXCEL导入数据库

 Private Function FunImpExcel(ByVal strFilePath As String) As Integer 
    'Excel文件格式 
    '第一行为表名，第二行为列名，其余行均为数据 
    On Error GoTo hErr 
    Dim objConn As New ADODB.Connection 
    Dim objRS As New ADODB.Recordset 
  
    If Dir(strFilePath) = "" Then 
        MsgBox "文件不存在" , vbCritical, "错误" 
        Exit Function   
    End If 
    '定义Excel对象 
    Dim xlsApp As Object 
    Dim xlsWb As Object 
    Dim xlsWs As Object 
     
    Set xlsApp = CreateObject("Excel.Application") '建立excel对象 
    Set xlsWb = xlsApp.Workbooks.Open(strFilePath) '要打开的文档路径 
    Set xlsWs = xlsWb.Worksheets(1) '选工作表，有多张表时，可以参考此，变换序号指定不同的表 
     
    xlsWs.Activate 
    xlsApp.Visible = false '隐藏，否则会在界面显示出来 
    'Excel表格的行数和列数 
    Dim iRowCnt As Integer 
    Dim iColCnt As Integer 
    iRowCnt = xlsWs.UsedRange.Rows.Count '这个并不完全准确，在操作数据时要设置退出条件 
    iColCnt = xlsWs.UsedRange.Columns.Count'这个并不完全准确，在操作数据时要设置退出条件 
    '下面要根据具体的表格情况决定，这里前面两行是表名和列名 
    If iRowCnt <= 2 Then 
        MsgBox "没有需要导入的明细数据" , vbCritical, "错误" 
        GoTo hErr 
    End If 
    '从第3行开始是明细数据 
    For i = 3 To iRowCnt 
        '设置退出条件 
        If Trim$(xlsWs.Cells(i, 3).Value) = "" Then 
            mdlPub.debug_print "on date found anymore:" & i 
            Exit For 
        End If 
        '第一条数据时，先打开数据库，这里是access 
        if 3 = i then  
            '数据库访问操作可以封装成一个公共的函数或过程 
            Dim strConn as String 
            strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=true;Data Source=test.mdb" 
            objConn.CursorLocation = adUseClient 
            objConn.Open strConn 
            strSQL = "select * from [要导入的表名] where 1=2 "             
            objRS.CursorLocation = adUseClient 
            objRS.Open strSQL, objConn, adOpenKeyset, adLockOptimistic 
        End if 
        '新增一条记录，注意各个字段的数据类型匹配问题， 
        '最好全部统一先转化为字符串，再转化为对应的类型     
        objRS.AddNew 
        objRS.Fields("数据库列名１") = Trim(CStr(xlsWs.Cells(i, 1).Value))   
        objRS.Fields("数据库列名2") = Trim(CStr(xlsWs.Cells(i, 2).Value))  
        '..... 
        objRS.Fields("数据库列名n") = CLng(Trim(CStr(xlsWs.Cells(i, n).Value)))   
         
        '如果Excel列名与要导入的数据库列能按顺序一一对应， 
        '则可以按以下方式,但要解决不同字段的数据格式匹配问题，比较麻烦 
        'For j = 0 To RS.Fields.Count - 1 
        '    RS.Fields(j) = Trim(CStr(xlsWs.Cells(i, 1).Value)) 
        'Next 
         
        '更新到数据库 
        objRS.Update 
    Next i 
     
    objRS.Close 
    objConn.Close 
    Set objRS = Nothing 
    Set objConn = Nothing 
     
    xlsWb.Close '关闭excel文件 
    xlsApp.Quit '退出excel 
     
    Set xlsWs = Nothing 
    Set xlsWb = Nothing 
    Set xlsApp = Nothing 
    FunImpExcel = 0'成功则返回０ 
     
    Exit Function   
hErr: 
    ImpExcelCertDtl = -１　'失败则返回１ 
    If Not (xlsWb Is Nothing) Then xlsWb.Close        '关闭文件 
    If Not (xlsApp Is Nothing) Then xlsApp.Quit 
 
    Set xlsWs = Nothing 
    Set xlsWb = Nothing 
    Set xlsApp = Nothing 
    MsgBox "文件导入失败" , vbCritical, "错误" 
     
End Function

对于一个Excel文件中多个表格的情况，可以循环逐一导入。

为了方便，对于excel对象的定义可以明确一些，这样能自动弹出提示，方便编码。

如：
 Dim xlsApp As New Excel.Application 
Dim xlsWb As Excel.Workbook 
Dim xlsWs As Excel.Worksheet 

 但这样定义时需要在工程中引入excel组件。

 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

将数据导出至Excel

 '----------------- 
'从数据从数据库导出至excel，并弹出保存文件对话框 
'------------------- 
Private Function FunExpExcel() 
 
    On Error GoTo hErr 
    '注意引用excel组件，也可以直接定义为对象object 
    Dim xlsApp As New Excel.Application 
    Dim xlsWb As Excel.Workbook 
    Dim xlsWs As Excel.Worksheet 
    Dim strFilePath As String 
    Dim strFileNm As String 
    Dim iColIdx As Integer 
     
    Dim objTmp As Object 
 
    '创建excel 
    Set xlsApp = CreateObject("Excel.Application") 
    xlsApp.Visible = False 
    xlsApp.SheetsInNewWorkbook = 1 '定义表格个数 
    '新增一张表格， 这里可以增加多张表 
    Set xlsWb = xlsApp.Workbooks.Add 
    '指定sheet，指定第一张，如果有多张，可以具体指定哪一个 
    Set xlsWs = xlsWb.Worksheets(1) 
      
    'xlsApp.Visible = False 
    xlsWs.Activate 
    xlsWs.Select 
    '第一行为标题 
    xlsWs.Cells(1, 1).Value = "表格标题" 
    '第二行为列名,第一列列名“序号” 
    xlsWs.Cells(2, 1).Value = "序号" 
    .... 
    xlsWs.Cells(2, n).Value = "序号" 
    '如果是datagrid，可以直接用对应的列名 
    'For iColIdx = 0 To Me.grdQryInst.Columns.Count - 1 
    '    xlsWs.Cells(2, iColIdx + 2).Value = Me.datagrid1.Columns(iColIdx).Caption 
    'Next 
    '设置第一列序号为数字格式 
    xlsWs.Columns("A:A").NumberFormatLocal = "0_ " 
     
    '设置其它列为文本格式,函数NumToChar26能将数字转化为对应的excel列名，如2->B,3->C,自已实现 
    'xlsWs.Columns(NumToChar26(2) & ":" & NumToChar26(Me.datagrid1.Columns.Count)).NumberFormatLocal = "@" 
     
    '----这里打开数据库，查询数据略，自己实现，如果是datagrid,则可以按下面的方法 
    'Dim RS As ADODB.Recordset 
    'Set RS = Me.datagrid1.DataSource 
    '从第三行开始写明细数据 
    RS.MoveFirst 
    For iRowIdx = 0 To RS.RecordCount - 1 
        xlsWs.Cells(iRowIdx + 3, 1).Value = CStr(iRowIdx + 1) 
        '对第一行，按顺序逐列写单元格 
        For iColIdx = 0 To RS.Fields.Count - 1 
           xlsWs.Cells(iRowIdx + 3, iColIdx + 2).Value = RS.Fields(iColIdx).Value 
        Next 
        RS.MoveNext 
    Next 
    '-----写完数据，下面设置导出excel格式　 
    '标题格式设置 
    Set objTmp = xlsWs.Range(xlsWs.Cells(1, 1), xlsWs.Cells(1, iColIdx + 2 - 1)) 
    objTmp.Merge　'合并单元格 
    '标题排版 
    With objTmp 
        .HorizontalAlignment = xlCenter 
        .VerticalAlignment = xlCenter 
    End With 
    With objTmp.Font 
        .Name = "宋体" 
        .Size = 18 
    End With 
  
    '第2行开始，设置边框，字体与标题不同 
    Set objTmp = xlsApp.Range(xlsWs.Cells(2, 1), xlsWs.Cells(iRowIdx + 3 - 1, iColIdx + 2 - 1)) 
    With objTmp.Font 
        .Name = "宋体" 
        .Size = 10 
        .Underline = xlUnderlineStyleNone 
        .ColorIndex = xlAutomatic 
    End With 
    objTmp.Borders(xlDiagonalDown).LineStyle = xlNone 
    objTmp.Borders(xlDiagonalUp).LineStyle = xlNone 
    With objTmp.Borders(xlEdgeLeft) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With objTmp.Borders(xlEdgeTop) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With objTmp.Borders(xlEdgeBottom) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With objTmp.Borders(xlEdgeRight) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With objTmp.Borders(xlInsideVertical) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With objTmp.Borders(xlInsideHorizontal) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
     
    '设置列宽，自动扩展 
    For iColIdx = 1 To Me.grdQryInst.Columns.Count + 1 
        xlsWs.Columns(NumToChar26(iColIdx) & ":" &　NumToChar26(iColIdx)).EntireColumn.AutoFit 
    Next 
        
   '弹出保存文件对话框，要在窗体上增加commondialog控件，控件命名dlgFile 
    Me.dlgFile.DialogTitle = "保存至" 
    Me.dlgFile.Flags = &H200 
    Me.dlgFile.DefaultExt = ".xls" 
     
    Me.dlgFile.Filter = "Excel数据文件 *.xls|*.xls" '过滤器 
    Me.dlgFile.InitDir = App.Path 
    Me.dlgFile.FileName = strFileNm & ".xls" 
    Me.dlgFile.ShowSave 
     
    If Err <> 32755 Then strFilePath = dlgFile.FileName 
    If "" <> strFilePath Then 
        xlsWb.SaveAs strFilePath 
    Else 
        mdlPub.ShowInfo "文件未保存" 
    End If 
     
    xlsWb.Close 
    xlsApp.Quit 
    Set xlsWs = Nothing 
    Set xlsWb = Nothing 
    Set xlsApp = Nothing 
    FunExpExcel = 0 '成功则返回0 
    mdlPub.ShowInfo "已保存至" & strFilePath 
    Exit Sub 
hErr: 
    FunExpExcel = -1'失败则返回1 
    If Err.Number <> 0 Then mdlPub.ShowErrMsg "导出错" 
    If Not (xlsWb Is Nothing) Then Set xlsWs = Nothing 
    If Not (xlsWb Is Nothing) Then 
        xlsWb.Close 
        Set xlsWb = Nothing 
    End If 
    If Not (xlsWb Is Nothing) Then 
        xlsApp.Quit 
        Set xlsApp = Nothing 
    End If 
 
End Function
注意，在使用VB操作

excel过程中，对于excel对象的引用都要用到本地定义的excel三个变量xlsApp，xlsWb，xlsWs之一做前缀，否则，   会出现残留EXCEL进程的情况，下次操作EXCEL时会报错。原因是没有加本地定义的变量做前缀，而使用了EXCEl的全局变量形式，xlsWb.Close， xlsApp.Quit语句只是退出局部EXCEL，无法退出全局EXCEL。