' 注意：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 用户使用,作用域:全局----
Public JCMD As New ADODB.Command
'====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=5 使用txt/csv文件连接
' connstr 为csv文件的完整路径，但不包括csv文件名
' 例：D:\CSVDB\test.csv
' ConnDB JDB,5,"C:\CSVDB\"
' ConnRS JDB, JRS, "select * from test.csv"
' 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, Optional ByVal connstr As String) As Boolean
connstr = Trim(connstr)
If DBs.State = adStateOpen And Not IsEmpty(adStateOpen) Then DBs.Close
DBs.CursorLocation = adUseServer
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
On Error GoTo ConnDBErrPro
.ConnectionString = "FILE NAME=" & connstr
.Open
End With
Case 5:
DBs.ConnectionString = "Driver={Microsoft Text Driver (*.txt; *.csv)};DefaultDir=" & connstr
DBs.Open
Case 6:
'JServerName = ServerName
'JUserID = UserID
'JPassword = Password
'JDefaultDB = DefaultDB
'DRIVER={MySQL ODBC 3.51 Driver};
DBs.ConnectionString = "Driver={sql server};uid=" & JUserID & ";pwd=" & JPassword & ";database=" & JDefaultDB & ";server=" & JServerName
DBs.Open
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
ConnDBErrPro:
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, adOpenKeyset, adLockPessimistic
' 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
Dim fs, a
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
