dbconn.bas

数据连接V1.0 包括Access/Excel/SQL/UDL UDL的创建/修改

Attribute VB_Name = "DB"
'====数据源连接模块 V1.5====

'   作者:我是乖猪猪
'   QQ:68492919
'   博客:http://hi.baidu.com/sedjamm
'   E-mail:[e-mail]

'   使用方法:   首先引用 Microsoft ActiveX Data Objects 2.5 Library
'               引用方法:工程->引用->勾选Microsoft ActiveX Data Objects 2.5 Library
'               当Microsoft ActiveX Data Objects版本低于2.5时,ADODB没有Stream对象和Record对象
'               用户自己可以通过{Public|Private|Dim} 实例名 as New ADODB.Connection 来定义一个ADODB.Connection实例
'               用户自己可以通过{Public|Private|Dim} 实例名 as New ADODB.Recordset 来定义一个ADODB.Recordset实例 等ADODB的实例
'               也可直接使用给大家定义好的实例名为JDB,JRS的Connection,Recordset实例

'               还需要的DLL文件:    msado15.dll
'                                   oledb32.dll
'                                   oledb32r.dll
'                                   OLEDB32X.DLL
'               把这几个DLL文件拷贝到工程文件所在的DLL子目录下.


'    注意：1.当使用Excle方式时，选择记录集时表名为 [工作表$]
'            例：   ConnRS JDB, JRS, "select * from [Sheet1$]"
'===========================

'====API引用====

Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Long
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String
End Type

'====数据源变量====
Public JDB As New ADODB.Connection      '----这个 ADODB.Connection 用户使用,作用域:全局----
Public JRS As New ADODB.Recordset       '----这个 ADODB.Recordset 用户使用,作用域:全局----

'====SQL服务器变量====
Public JServerName As String            '----SQL服务器名----
Public JUserID As String                '----用户名----
Public JPassword As String              '----密码----
Public JDefaultDB As String            '----默认数据库名----

'====自定义过程:设置SQL服务器变量====
'   ----使用SQL方式接连前使用----
Public Sub SetSQLDef(ServerName As String, UserID As String, Password As String, DefaultDB As String)
JServerName = ServerName
JUserID = UserID
JPassword = Password
JDefaultDB = DefaultDB
End Sub

'====自定义函数:连接数据源====
'       DBClass=1   无密码的Access数据源连接，ConnStr=mdb文件的完整路径。

'       DBClass=2   SQL Server 方式连接，ConnStr没有用
'                   要使用SetSQLDef先设置SQL服务器变量

'       DBClass=3   无密码的Excle数据源连接，ConnStr=xls文件的完整路径。
'                   例：ConnDB JDB,3,App.Path & "\Temp.xls"

'       DbClass=4   使用udl文件连接
'                   connstr 为udl文件的完整路径

'       DBClass=11 有密码的Access数据源连接，ConnStr=mdb文件的完整路径 & "*" & 密码
'                   例：ConnDB JDB, 11, App.Path & "\sysDB.mdb*ps123"

'       返回值为：连接成功=True；连接失败=False
Public Function ConnDB(DBs As ADODB.Connection, DBClass As Long, ByVal connstr As String) As Boolean
    connstr = Trim(connstr)
    If DBs.State = adStateOpen And Not IsEmpty(adStateOpen) Then DBs.Close
    Select Case DBClass
    Case 1:    DBs.Open "PROVIDER=Microsoft.jet.OLEDB.4.0;data source= " & connstr
    
    Case 2:    DBs.Open "Provider=SQLOLEDB.1;Password=" & JPassword & ";Persist Security Info=True;User ID=" & JUserID & ";Initial Catalog=" & JDefaultDB & ";Data Source=" & JServerName
    Case 3:
                
            With DBs
                .Provider = "Microsoft.Jet.OLEDB.4.0"
                .ConnectionString = "Data Source=" & connstr & ";Extended Properties=Excel 8.0;"
                .Provider = "MSDASQL"
                .ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};DBQ=" & connstr & ";"
                .CursorLocation = adUseClient
                .Open
            End With

    Case 4:
        With DBs
            .ConnectionString = "FILE NAME=" & connstr
            .Open
        End With
    
    

    Case 11:
        Dim temp As Integer
            temp = InStr(connstr, "*")
    DBs.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Left(connstr, temp - 1) & ";Persist Security Info=False;Jet OLEDB:database password=" & Right(connstr, Len(connstr) - temp)
    Case Else:
    
    End Select
    ConnDB = DBs.State = adStateOpen And Not IsEmpty(adStateOpen)
End Function

'====自定义函数:选择记录集（游标）====

'           SQLStr SQL语句，一般为"select * from table"，可由自己的程序设计制定。
'           返回值为：连接成功=True；连接失败=False
'           注意：当使用Excle方式时，选择记录集时表名为 [工作表$]
'           例:   ConnRS JDB, JRS, "select * from [Sheet1$]"
            
Public Function ConnRS(DBs As ADODB.Connection, RSs As ADODB.Recordset, SQLstr As String) As Boolean
    If RSs.State = adStateOpen And Not IsEmpty(adStateOpen) Then RSs.Close
        RSs.Open SQLstr, DBs, adOpenDynamic, adLockBatchOptimistic
    ConnRS = RSs.State = adStateOpen And Not IsEmpty(adStateOpen)
End Function


'====自定义过程:关闭数据源====
Public Sub CloseDB(DBs As ADODB.Connection)
    If DBs.State = adStateOpen And Not IsEmpty(adStateOpen) Then DBs.Close
End Sub

'====自定义过程:关闭记录集（游标）====
Public Sub CloseRS(RSs As ADODB.Recordset)
If RSs.State = adStateOpen And Not IsEmpty(adStateOpen) Then RSs.Close
End Sub


'====自定义函数:新建/覆盖UDL文件====

'       参数:
'           UDLname     文件完整路径
'           Mode        False:如果文件存在,不覆盖./True:如果文件存在,覆盖.
'           CreateOpen  新建后打开文件. False:不打开/True:打开

'       返回值:         True:成功/False失败


Public Function CreateUDL(UDLname As String, Mode As Boolean, CreateOpen As Boolean) As Boolean

On Error GoTo CreateUDLErrPro

    If Right(UDLname, 4) <> ".udl" Then UDLname = UDLname & ".udl"
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set a = fs.CreateTextFile(UDLname, Mode)
        a.Close
    CreateUDL = True
    If CreateOpen Then
        Dim ExecStr As String
        ExecStr = "rundll32.exe " & App.Path & "\DLL\oledb32.dll,OpenDSLFile " & UDLname
        Shell ExecStr
    End If



CreateUDLErrPro:
    Select Case Err.Number
    Case 0:
    Case 58:
        CreateUDL = False
    End Select
    
End Function


'====自定义过程:打开UDL文件====
'
Public Sub OpenUDL(UDLname As String)
        Dim ExecStr As String
        ExecStr = "rundll32.exe " & App.Path & "\DLL\oledb32.dll,OpenDSLFile " & UDLname
        Shell ExecStr
End Sub


'====自定义过程:删除UDL文件====


Public Sub DeleteUDL(UDLname As String)
    If LCase(Right(UDLname, 4)) = ".udl" Then
        Dim result As Long, fileop As SHFILEOPSTRUCT
        With fileop
            .hwnd = 0
            .wFunc = &H3
            .pFrom = UDLname & vbNullChar & vbNullChar
            .fFlags = &H40
        End With
        result = SHFileOperation(fileop)
    End If
    
End Sub