vba操作数据库
Sub test()
' 连接 Oracle数据库
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.Open "Provider=MSDAORA.1;Data Source=数据源;User ID=用户名;Password=密码;Persist Security Info=True"
cn.Execute ("执行的数据库更新语句")
' 通过表或者查询创建数据集
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open "表名", cn, adOpenKeyset, adLockOptimistic
MsgBox rs.RecordCount
rs.Close
rs.Open "Select 字段 From 表名 Where 条件", cn, adOpenKeyset, adLockOptimistic
MsgBox rs.RecordCount
' 关闭数据集和数据连接
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
数据库连接方法：
Public Function conn_sqlServer(ByVal serverIP As String, _
userid As String, _
password As String, _
database As String) As Connection
Dim sConStr As String
sConStr = "driver=sql server;" _
& "server=" & serverIP _
& ";Uid=" & userid _
& ";Pwd=" & password _
& ";Database=" & database
Set conn = New ADODB.Connection
conn.Open sConStr
If conn Is Nothing Then
MsgBox "データベースは失敗につながります."
Exit Function
Else
Set conn_sqlServer = conn
End If
End Function
其中，各参数代表的意义如下：
serverIP ：数据库服务器的IP地址、userid：数据库的用户名、password：数据库的用户密码、database：数据库
的实例名。
关闭数据库连接方法代码如下
Public Function closeConnection(ByVal conn As Connection)
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
conn.Close
End If
End Function
其中，参数 conn ：要关闭的连接。
执行查询语句的方法代码如下：
Public Function executeQuery(ByVal conn As Connection, querySql As String) As Recordset
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
rs.Open querySql, conn, 1, 3
End If
Set executeQuery = rs
End Function
其中，参数 conn ：数据库连接、querySql ：查询语句。返回值为查询结果集。
执行非查询语句的方法代码如下：
Public Function excuteUpdateDatabase(ByVal conn As Connection, updateSql As String) As Boolean
Dim excuteResult As Boolean
excuteResult = False
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
conn.BeginTrans
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
Set rs = conn.Execute(updateSql)
End If
If rs Is Nothing Then
msgbox "いかなる行に影響していません"
Else
excuteResult = True
conn.CommitTrans
End If
excuteUpdateDatabase = excuteResult
End Function
其中，参数 conn ：数据库连接、querySql ：非查询语句。返回值：成功返回true，否侧返回false。
开启事务方法代码如下
Public Function begin_trans(ByVal conn As Connection)
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
conn.BeginTrans
End If
End Function
其中，参数 conn：数据库连接。
提交事务的方法代码如下
Public Function commit_trans(ByVal conn As Connection)
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
conn.CommitTrans
End If
End Function
其中，参数 conn：数据库连接。
回滚事务的方法代码如下
Public Function roolback_trans(ByVal conn As Connection)
If conn Is Nothing Then
MsgBox "データベースの接続は空です"
Else
conn.RollbackTrans
End If
End Function
其中，参数 conn：数据库连接。
调用存储过程代码如下
Public Function callPr_restore(ByVal conn As Connection, pr_restore_name As String)
Dim CNN_cmd As ADODB.Command
Set CNN_cmd = New ADODB.Command
Set CNN_cmd.ActiveConnection = conn
CNN_cmd.CommandText = pr_restore_name
CNN_cmd.CommandType = adCmdStoredProc
'------------------------有参存储过程加以下代码----------------------------------
With CNN_cmd
' 两种方式给参数赋值
' 第一种：CNN_cmd.P阿rameters（参数索引）.value = 参数值
' 第二种：.CNN_cmd.Parameters.Append .CreateParameter(参数名，adVarChar, adParamInput, 10,
参数值）
.Parameters(1).Value = "20030611"
.Parameters.Append .CreateParameter("stunum", adVarChar, adParamInput, 10, "20030610")
.Parameters.Append .CreateParameter("sPrefix", adVarChar, adParamInput, 4, "2004")
.Parameters.Append .CreateParameter("iLength", adInteger, adParamInput, , 5)
.Parameters.Append .CreateParameter("sSequenceNumber", adVarChar, adParamOutput, 7,
sSequenceNumber)
End With
'---------------------------------------END--------------------------------------------
CNN_cmd.Execute
End Function
其中，参数conn：数据库连接、pr_restore_name：存储过程名。
---------从数据库取数存放到excel表格------
Function Open_Conn(SqlDatabaseName, SqlPassword, SqlUsername)
Dim Conn As ADODB.Connection '声明ADODB.Connection对象变量
Dim Rdset As ADODB.Recordset
Dim TempC As String
Dim sSQL As String
Dim Rng As String
Dim I As Integer
sSQL = "select Code,Area, KDtime, PDtime, DDtime, WCtime, Clerk, Status from work "
'打开数据库连接
Set Conn = New ADODB.Connection
sConnStr = "Provider=sqloledb;server=ewaysun;Uid=sa;Pwd=;Database=helpdesk"
Conn.Open sConnStr
Rng = [a65535].End(xlUp).Row '判断有记录的最后一行
If Rng <> 1 Then '判断清空的起始行
Range(Cells(2, 1), Cells(Rng, 8)).ClearContents '清空数据
Cells(2, 1).CopyFromRecordset Conn.Execute(sSQL) '查询后插入单元格
Columns("C:E").Select
Selection.NumberFormatLocal = "yyyy-mm-dd hh:mm"
Columns("F:F").Select
Selection.NumberFormatLocal = "[$-F400]hh:mm:ss AM/PM"
Rng = [a65535].End(xlUp).Row
Range(Cells(2, 1), Cells(Rng, 8)).Select
'按人名排序
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Range(Cells(2, 1), Cells(Rng, 8)).Select
'设置表格底纹
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'位置居中
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Else
Cells(2, 1).CopyFromRecordset Conn.Execute(sSQL) '查询后插入单元格
Rng = [a65535].End(xlUp).Row '判断有记录的最后一行
Range(Cells(2, 1), Cells(Rng, 8)).Select
'按人名排序
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Columns("C:E").Select
Selection.NumberFormatLocal = "yyyy-mm-dd hh:mm"
Columns("F:F").Select
Selection.NumberFormatLocal = "[$-F400]hh:mm:ss AM/PM"
End If
Cells(2, 1).Select
If Conn Is Nothing Then
MsgBox "数据连接错误!"
End If
End Function
----------------------------------------------------通过querytable属性向excel中导入数据--------------------------------------------
向Excel中导入数据的函数
Public Function fillData(ByVal rs As ADODB.Recordset, _
sheetIndex As Integer, _
beginCell As String, _
EdgeLine As String, _
InsideLine As String)
With Sheets(sheetIndex).QueryTables.Add(rs, Sheets(sheetIndex).Range(beginCell))
.FieldNames = False
.Refresh
End With
Call setBorders(sheetIndex, beginCell, EdgeLine, InsideLine)
End Function
其中，rs为结果集、sheetIndex为sheet的索引、beginCell为开始添加数据的cell、EdgeLine为数据区域的外部边框线宽、InsideLine为数据区域的内部边框线宽。
设置数据区域边框的函数
Private Function setBorders(ByVal sheetIndex As Integer, _
beginCell As String, _
EdgeLine As String, _
InsideLine As String)
Sheets(sheetIndex).Range(beginCell).CurrentRegion.Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = EdgeLine
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = EdgeLine
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = EdgeLine
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = EdgeLine
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = InsideLine
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = InsideLine
.ColorIndex = xlAutomatic
End With
End Function
其中，sheetIndex为sheet的索引、beginCell为开始添加数据的cell、EdgeLine为数据区域的外部边框线宽、InsideLine为数据区域的内部边框线宽。
QeryTable的属性列表如下：
With QueryTable.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