vb編程把excel中的數據導入SQL SERVER數據庫及導出為excel

2011-07-25 16:43:23|  分類： Visual Basic|字號 訂閱

 

 

把excel中的數據導入SQL SERVER數據庫（access數據類似）：

Private Sub Command1_Click()
Dim strconn As String ' 定義Excel 連接字符串
Dim cn As ADODB.Connection ' 定義Excel 連接
Set cn = New ADODB.Connection
' 初始化commandialog1 的屬性，選取Excel 文件，文
' 件名保存在CommanDialog1.filename 中備用

CommonDialog1.Filter = " 電子表格文件(.xls) |*.xls"
CommonDialog1.DialogTitle = " 請選擇要導入的文件"
CommonDialog1.ShowOpen

' 設置連接SQL 數據庫的連接字符串
strtemp = " [odbc;Driver= {SQL Server} ;Server=(local);Database=Afws;UID=sa;PWD=sa]"
' 設置Excel 數據連接
strconn = " Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" & CommonDialog1.FileName & " ; Extended Properties=Excel 8.0" 
cn.Open strconn

strSql = "insert into " & strtemp & ".hw_level1 select * from [sheet1$]"
cn.Execute strSql, lngRecsAff, adExecuteNoRecords

MsgBox " 成功導入到SQL 數據庫中！", vbExclamation + vbOKOnly

cn.Close
Set cn = Nothing

End Sub

---

從access數據庫中導出數據到為excel（sql數據庫類似）：

dim conn as adodb.connection
Dim rs1 As New ADODB.Recordset
dim sql as string

set conn=new adodb.connection
if conn.state<>0 then conn.close
conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path &"\sclsylb.mdb"

sql="SELECT * FROM QS800"      'QS800表你應該很熟悉
if rs1.state<>0 then rs1.close
rs1.cursorlocation=aduserclient
rs1.open sql,conn,1,3


'導出xls表
Dim xlApp     As New Excel.Application
Dim xlBook     As Excel.Workbook
Dim xlSheet     As Excel.Worksheet
Dim xlQuery     As Excel.QueryTable
'On Error GoTo OutPutErr
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
Set xlQuery = xlSheet.QueryTables.Add(rs1, xlSheet.Range("a1 "))

With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
End With

xlQuery.FieldNames = True
xlQuery.Refresh
cmdlg.Flags = 2
cmdlg.Filter = "EXCEL文檔(*.xls)"
cmdlg.ShowSave

If cmdlg.FileName <> "" Then
    xlApp.DisplayAlerts = False
    xlBook.SaveAs FileName:=cmdlg.FileName

    If MsgBox("導出成功,是否打開查看?", vbOKCancel, "導出EXCEL") = vbOK Then
        xlApp.Workbooks().Open cmdlg.FileName
        xlApp.Visible = True
    Else
        xlApp.Quit
    End If
End If
If xlApp <> Null Then Set xlApp = Nothing
set conn=nothing
set rs1=nothing