VBA 操作数据库

 

连接Oracle数据库

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

ADODB方式连接SqlServer数据库

数据库连接方法：

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