Excel中用VBA鏈接Oracle實現位置隨意標題

我用的是Oracle 11g + Microsoft Office 2010 旗艦版 

首先要添加引用類庫：

  Microsoft ActiveX Data Objects Recordset 6.0（或者2.8）Library

  Microsoft Activex Data Objects 6.1（或者2.8） Library

 

鏈接Oracle的字符串有三種，而我試驗了幾次兩種，一種是odbc，另一種是ado方式

這兩種鏈接方式如下：

odbc： 

"DSN=orcl;UID=scott;PWD=tiger;DBQ=ORCL;DBA=W;APA=T;EXC=F;

FEN=T;QTO=T;FRC=10;FDL=10;LOB=T;RST=T;BTD=F;BNF=F;BAM=IfAllSuccessful;

NUM=NLS;DPM=F;MTS=T;MDI=F;CSR=F;FWC=F;FBS=64000;TLO=O;MLD=0;ODA=F;"

ado：

"Provider = OraOLEDB.Oracle;Persist Security Info=true;User ID = scott;Password = whg;Data Source=(DESCRIPTION=(ADDRESS=(PROTOCOL=TCP)(HOST=192.168.178.168)(PORT=1521))(CONNECT_DATA=(SERVICE_NAME=Orcl)))"

其中odbc只能實現鏈接本機數據庫，不能遠程，而ado方式可以實現遠程連接，只需把host後面的ip改成目標地址即可。

做了一個活動標題的excel vba例子，所謂活動標題，是位置比較隨意，可以互換位置，但中間不能有空的單元格，如果表頭中有“序列”的話，可以自動編號。下面就貼上代碼

VBA代碼

Option Explicit
Public Const DATA_START_ROW As Byte = 4 '數據起始位置
Public fieldsCount As Integer
Public fieldsZH() As String '中文名稱 表頭
Public fieldsEN() As String '英文名稱，數據庫字段
Public fieldsType() As String '字段類型

'初始化字段值
Sub initFields()
    Dim i As Integer
    ThisWorkbook.Sheets(1).Activate
    With Range("A1").CurrentRegion
        fieldsCount = .Rows.Count
    End With

    ReDim fieldsZH(fieldsCount - 1)
    ReDim fieldsEN(fieldsCount - 1)
    ReDim fieldsType(fieldsCount - 1)

    For i = 0 To fieldsCount - 1
        fieldsZH(i) = Cells(i + 1, 1)
        fieldsEN(i) = Cells(i + 1, 2)
        fieldsType(i) = Cells(i + 1, 3)
    Next
End Sub

Option Explicit

'定義鏈接屬性
Dim conn As ADODB.Connection '##################################################
Dim rs As ADODB.Recordset '#######################################
Dim OraID As String
Dim OraUsr As String
Dim oraPwd As String
Dim serIP As String
Dim sqlStr As String

'初始化鏈接屬性
Sub InitConnect()
    On Error GoTo ConnectingError
    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    OraID = "orcl"       'Oracle數據庫的相關配置
    OraUsr = "scott"      '用戶名
    oraPwd = "tiger"      '登錄密碼
    serIP = "127.0.0.1"   '數據庫ip地址和數據困服務器名
    conn.ConnectionString = "Provider = OraOLEDB.Oracle.1;" & _
    "Password=" & oraPwd & ";User ID=" & OraUsr & _
    ";Data Source=(DESCRIPTION=(ADDRESS=(PROTOCOL=TCP)" & _
    "(HOST=" & serIP & ")(PORT=1521))" & _
    "(CONNECT_DATA=(SERVICE_NAME=" & OraID & ")))"
    'MsgBox conn.ConnectionString
    conn.Open
    rs.ActiveConnection = conn
    Exit Sub
ConnectingError:
    MsgBox "無法連接數據庫，請檢查數據庫服務配置"
    Exit Sub
End Sub

'從Excel同步到Oracle
Sub ExcelToOracle()

End Sub

'關閉連接
Sub CloseConnect()
    On Error Resume Next
    If Not IsEmpty(rs) Then
        rs.Close
    End If
    If Not IsEmpty(conn) Then
        conn.Close
    End If
End Sub

'從Oracle同步到Excel
Sub OracleToExcel()
    InitConnect '初始化鏈接
    initFields  '初始化字段
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim excelTitleSeq() As Integer '存儲表頭對應的數據庫字段所在位置
    Dim flag As Boolean '循環跳出標識
    Dim idSeq As Integer ' 表頭中“序列”的下標

    ThisWorkbook.Sheets(2).Activate
    sqlStr = "select * from empinfo where newdata=1"
    rs.Open Source:=sqlStr, LockType:=adLockBatchOptimistic

    ReDim excelTitleSeq(rs.Fields.Count - 1)
    For i = 0 To rs.Fields.Count - 1
        excelTitleSeq(i) = -1
    Next



    '----------------------新算法, 序列位置隨意
    For i = 0 To Cells(DATA_START_ROW - 1, 1).CurrentRegion.Columns.Count - 1 '循環匹配表頭
        If Cells(1, DATA_START_ROW - 1).Value = "序列" Then
            idSeq = i + 1
        End If
        flag = False
        For j = 0 To fieldsCount - 1 '依次找到對應的數據庫字段的下標
            If Trim(Cells(DATA_START_ROW - 1, i + 1)) = Trim(fieldsZH(j)) Then
                For k = 0 To rs.Fields.Count - 1 '從數據庫字段中查找這個對應值
                    If UCase(Trim(fieldsEN(j))) = UCase(Trim(rs.Fields(k).Name)) Then
                        excelTitleSeq(i) = k
                        flag = True
                        Exit For
                    End If
                Next
            End If
            If flag Then
                Exit For
            End If
        Next
    Next




    '給表格賦值
    i = DATA_START_ROW
    Do Until rs.EOF
        For j = 0 To rs.Fields.Count - 1
            If idSeq <> 0 Then '判斷是否有“序列”
                Cells(i, idSeq).Value = i - DATA_START_ROW + 1
            End If

            If excelTitleSeq(j) <> -1 Then
                Cells(i, j + 1).Value = rs.Fields(excelTitleSeq(j)).Value
            End If
        Next
        i = i + 1
        rs.MoveNext
    Loop
    CloseConnect
End Sub

sql語句

 

--人員基本信息表
create table empinfo(
   email varchar2(50), --郵箱
   eno varchar2(12) unique, --人員編號
   ename varchar2(20) not null, --人員姓名
   eid varchar2(20) unique, --身份證號碼
   cardno varchar2(6) unique, --卡號
   status varchar2(20), --狀態
   org varchar2(50), --人員組織
   egroup varchar2(50), --組別 由group改-
   groupno varchar2(10), --組號 由組別截取第一位
   formation varchar2(25), --編制
   sex varchar2(10), --性別
   birthday varchar2(20), --出生日期
   address varchar2(100), --家庭住址
   drivetime varchar2(20), --車程
   graduate varchar2(50), --畢業院校
   major varchar2(50), --專業
   job varchar2(50), --職務
   elevel varchar2(20), --等級 由level改
   eresume varchar2(10), --簡歷 是否有 由resume改
   erole varchar2(50), --角色 由role改
   tutor varchar2(20), --導師
   phone varchar2(20), --電話
   tel varchar2(20), --座機
   education varchar2(20), --學歷
   leveltime varchar2(20), --等級時間
   graduateyear varchar2(10), --畢業年份
   interntime varchar2(20), --見習時間
   comtime varchar2(20), --入司時間
   deptime varchar2(20), --入部門時間
   depyear varchar2(10), --入部門年度
   beforeinfo varchar2(500), --入部門前情況
   leavetime varchar2(20), --離職時間
   workinfo varchar2(500), --工作經歷
   projectexpr varchar2(500), --衛生政務項目經歷
   tecinfo varchar2(50), --技術認證
   certificate varchar2(10), --證書
   marriage varchar2(10), --婚姻 已婚 未婚 離異
   childyear varchar2(10), --小孩年份
   im1 varchar2(20), --及時通訊工具1
   im2 varchar2(20), --及時通訊工具2
   linkman varchar2(20), --緊急聯繫人
   linkmanphone varchar2(20), --緊急聯繫人電話
   tecdirection varchar2(50), --推薦技術方向
   homephone varchar2(20), --家庭電話
   comments varchar2(500), --備註
   newdata varchar2(1)  --最新數據標識
);

附件中，只實現了從Oracle導出到excel，另一個按鈕功能沒有實現