作者：lianghc

描述：最近在使用infamatica 將excel  的資料匯入oracle時，遇到意外終止錯誤，無法將資料匯入。於是採用VBA將資料匯入資料庫，是辦公人員一鍵同步excel的資料導資料庫中，這種做法的前提是提供標準的模板。下面是解決問題過程中收集的連線資料庫的方法，整理一下供大家參考。

1、引用法

引用ADO相關元件：開啟VBA編輯器，在選單中點選“工具”--》“引用”。確保“Microsoft ActiviteX Data Objects 2.8 Library”和“Microsoft ActiviteX Data ObjectS Recordset 2.8 Library”被勾選上。引用後再宣告:

Dim cnn As New Connection '宣告連結物件
Dim rst As New Recordset '宣告記錄集物件

例子：

Dim cnn As New Connection 
Dim rst As New Recordset 
cnn.Open "Provider=msdaora.1;Data Source=dl580;User Id=emssxjk;Password=emssxjk;" 
OraOpen = True '成功執行後，資料庫即被開啟 

sqls = "select count(*) from tb_evt_dlv where mail_num='" & emsid & "'" 
Set rst = cnn.Execute(sqls) 
If rst(0) > 0 Then 
sqls = "select b.zj_code,b.zj_mc,b.jgfl,b.city,b.ssxs from tb_evt_dlv a, tb_jg b " 
sqls = sqls & "where a.dlv_bureau_org_code = b.zj_code and a.mail_num='" & emsid & "' and rownum=1" 
Set rst = cnn.Execute(sqls) 
sqls = "CopyFromRecordset" 
'maxrow = Sheets(qfxx).[A65536].End(xlUp).Row 
'If maxrow > 1 Then Sheets(qfxx).Range("a2:H" & maxrow).ClearContents 
Cells(row1, pos_sav).CopyFromRecordset rst 
Else 
sqls = "select b.zj_code,b.zj_mc,b.jgfl,b.city,b.ssxs from tb_evt_mail_clct a, tb_jg b " 
sqls = sqls & "where a.clct_bureau_org_code = b.zj_code and a.mail_num='" & emsid & "' and rownum=1" 
Set rst = cnn.Execute(sqls) 
sqls = "CopyFromRecordset" 
'maxrow = Sheets(qfxx).[A65536].End(xlUp).Row 
'If maxrow > 1 Then Sheets(qfxx).Range("a2:H" & maxrow).ClearContents 
Cells(row1, pos_sav + 5).CopyFromRecordset rst 
End If 
 

2、建立法

不需要引用ADO相關元件，直接使用CreateObject函式建立ADO物件，即：
Set cnn = CreateObject("ADODB.connection") '建立ado物件
Set rst = CreateObject("ADODB.recordset") '建立記錄集
下面是例程（和上面例程類似，前半部分不同，後面的相同）：

Dim cnn As Object, rst As Object 

Set cnn = CreateObject("ADODB.Connection") 
Set rst = CreateObject("ADODB.Recordset") 
cnn.Open "Provider=msdaora.1;Data Source=dl580;User Id=emssxjk;Password=emssxjk;" 
OraOpen = True '成功執行後，資料庫即被開啟 
 

其它元件的使用也和這個差不多，建議用建立法，這樣就不用管“引用”中的設定了，例如：

Dim dic As Object '直接建立不需要引用
Set dic = CreateObject("scripting.dictionary") '建立字典物件


Dim fso as Object '直接建立不需要引用

Set fso = CreateObject("Scripting.FileSystemObject") '建立檔案物件模型

上面內容引自：http://blog.csdn.net/iamlaosong/article/details/45096059  （這個部落格寫的不錯）

我的示例：

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
    
Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long

Public Function GetGUID() As String
    '(c) 2000 Gus Molina
    
    Dim udtGUID As GUID
    
    If (CoCreateGuid(udtGUID) = 0) Then
    
        GetGUID = _
        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
    End If

End Function
’前面的是生成唯一標識GUID的程式碼。
Sub Table_to_Oracle()

    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    Dim datasource As String
    Dim userid As String
    Dim password As String
    
    On Error GoTo Err_Handle  '如果遇到錯誤就跳轉到錯誤處，並提示錯誤
        
        ThisWorkbook.Sheets("1").Select '將連線資訊存在表格裡
        datasource = ""
        userid = ""
        password = ""
     
        cnn.Open "Provider=msdaora;Data Source=" & datasource & ";User Id=" & userid & ";Password=" & password & ";" '開啟資料庫連線
            
        
                C_TEST= GetGUID  '插入32位的GUID

        If deleteflag Then
            cnn.Execute ("delete from TOP_REPAYPLAN where C_PROJECTCODE= " & C_PROJECTCODE)
            deleteflag = False
         End If
                
         insert_sql = "insert into TABLE_TEST(C_TEST) "
         value_sql = " values(" & C_TEST & ")"
                
         Set rst = cnn.Execute(insert_sql & value_sql)
           
     
        cnn.Close
        
        MsgBox "成功匯入！", vbInformation, "匯入資訊"
        Exit Sub
Err_Handle:
    MsgBox Err.Description, vbExclamation, "異常資訊"

End Sub

Sub readme()
   MsgBox "您好，資料匯入過程中如果有出錯資訊，請聯絡開發人員。", vbInformation, "友情提示"
End Sub
 

'網上收集的另一段比較好的程式碼：

Public Sub ConOra()
On Error GoTo ErrMsg:
Dim ConnDB As ADODB.Connection
Set ConnDB = New ADODB.Connection
Dim ConnStr As String
Dim DBRst As ADODB.Recordset
Set DBRst = New ADODB.Recordset
Dim SQLRst As String
Dim OraOpen As Boolean
OraOpen = False
OraID = "orcl" 'Oracle資料庫的相關配置
OraUsr = "scott"
OraPwd = "tiger"
ConnStr = "Provider = MSDAORA.1;Password=" & OraPwd & _
";User ID=" & OraUsr & _
";Data Source=" & OraID & _
";Persist Security Info=True"
ConnDB.CursorLocation = adUseServer
ConnDB.Open ConnStr
OraOpen = True '成功執行後，資料庫即被開啟
'MsgBox "Connect to the oracle database Successful!", vbInformation, "Connect Successful"
DBRst.ActiveConnection = ConnDB
DBRst.CursorLocation = adUseServer
DBRst.LockType = adLockBatchOptimistic
SQLRst = "Select * From TB_USER"
DBRst.Open SQLRst, ConnDB, adOpenStatic, adLockBatchOptimistic

For Each x In DBRst.Fields
 x.Name
 Next
 Do Until DBRst.EOF
   
   For Each i In DBRst.Fields
      Response.Write (i.Value)
   Next
    DBRst.MoveNext
    
  Loop
  DBRst.Close
DBRst.MoveFirst
Exit Sub
ErrMsg:
OraOpen = False
MsgBox "Connect to the oracle database fail ,please check!", vbCritical, "Connect fail!"
End Sub