Excel中用VBA链接Oracle实现位置随意标题

nikoo

　　我用的是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>　　其中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，另一个按钮功能没有实现