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，另一个按钮功能没有实现