|
не понял насчет мутно, это текст а не принтскрин,
даю поный текс :
---------------
Option Compare Database
Option Explicit
' CurrentProject.BaseConnectionString
' PROVIDER=SQLOLEDB.1;
' INTEGRATED SECURITY=SSPI;PERSIST SECURITY INFO=FALSE;
' DATA SOURCE=***;INITIAL CATALOG=***
' CurrentProject.Connection.ConnectionString
' Provider=Microsoft.Access.OLEDB.10.0;Data Provider=SQLOLEDB.1;
' Persist Security Info=False;Integrated Security=SSPI;
' Data Source=***;Initial Catalog=***;
Public Function ConnectionInfo _
( _
sServerName As String, _
sDatabaseName As String _
)
Dim tv As New TaggedValues
sServerName = ""
sDatabaseName = ""
ConnectionInfo = True
tv.Text = Access.CurrentProject.BaseConnectionString
If tv.Exists("DATA SOURCE") Then
sServerName = tv.item("DATA SOURCE")
Else
ConnectionInfo = False
End If
If tv.Exists("INITIAL CATALOG") Then
sDatabaseName = tv.item("INITIAL CATALOG")
Else
ConnectionInfo = False
End If
End Function
Public Function OpenConnection _
( _
cnn As ADODB.Connection, _
Optional sServerName As String = "", _
Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800 _
)
On Error Resume Next: Err.Clear
Dim iTryCount As Integer: iTryCount = 0
OpenConnection = False
If cnn Is Nothing Then Set cnn = New ADODB.Connection
If cnn.State = adStateOpen Then cnn.Close
If sServerName = "" Or sDatabaseName = "" Then
Call modSQL.ConnectionInfo(sServerName, sDatabaseName)
End If
On Error GoTo Err_Connect
cnn.CommandTimeout = iCommandTimeout
cnn.CursorLocation = adUseClient
cnn.Open _
"PROVIDER=SQLOLEDB.1;" & _
"INTEGRATED SECURITY=SSPI;" & _
"PERSIST SECURITY INFO=FALSE;" & _
"DATA SOURCE=" & sServerName & ";" & _
"INITIAL CATALOG=" & sDatabaseName & ";"
If cnn.State = adStateOpen Then
OpenConnection = True
Else
modForm.MsgBox _
"Подключение к серверу " & sServerName & " " & _
"и базе данных " & sDatabaseName & " не выполнено.", _
vbExclamation + vbOKOnly, _
"Ошибка подключения к серверу и базе данных"
OpenConnection = False
End If
On Error GoTo 0
Exit Function
Err_Connect:
If iTryCount > 1 Then
OpenConnection = False
GoTo ERR_LABEL
End If
iTryCount = iTryCount + 1
Call ConnectionInfo(sServerName, sDatabaseName)
Resume
ERR_LABEL:
modForm.MsgBox _
"Ощибка " & Err.Number & ": " & Err.Description, _
vbExclamation + vbOKOnly, _
"Ошибка подключения к базе данных"
OpenConnection = False
On Error GoTo 0
Exit Function
End Function
Public Function OpenRecordset _
( _
rs As ADODB.Recordset, _
nRecords As Long, _
sSQL As String, _
Optional cnn = Null, _
Optional sServerName As String = "", _
Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800 _
)
On Error Resume Next: Err.Clear
Dim cnnLocal As ADODB.Connection
nRecords = 0
OpenRecordset = False
If IsNull(cnn) Then
Call modSQL.OpenConnection(cnnLocal, sServerName, sDatabaseName, iCommandTimeout)
Else
Set cnnLocal = cnn
End If
Set rs = New ADODB.Recordset
rs.CursorType = adOpenKeyset
rs.CursorLocation = adUseClient
rs.Open sSQL, cnnLocal
nRecords = rs.RecordCount
If Err.Number <> 0 Then
Call modError.ErrorMessage( _
9101401, _
"Ошибка выполнения запроса к серверу" & vbNewLine & vbNewLine & _
"SQL=" & sSQL)
Err.Clear
' Рекордсет не был открыт по причине ЛЮБОЙ ошибки
OpenRecordset = False
Else
' True возвращается даже если открытый рекордсет не имеет строк
OpenRecordset = True
End If
On Error GoTo 0
End Function
Public Function ReadValue _
( _
sFieldName As String, vFieldValue As Variant, sSQL As String, _
Optional cnn = Null, _
Optional sServerName As String = "", _
Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800 _
)
On Error Resume Next: Err.Clear
Dim cnnLocal As ADODB.Connection, bOpenConnection As Boolean
Dim rs As ADODB.Recordset, n As Long, v As Variant
If IsNull(cnn) Then
bOpenConnection = True
Call modSQL.OpenConnection(cnnLocal, sServerName, sDatabaseName, iCommandTimeout)
Else
bOpenConnection = False
Set cnnLocal = cnn
End If
If modSQL.OpenRecordset(rs, n, sSQL, cnnLocal, sServerName, sDatabaseName) Then
If Err.Number <> 0 Then
Call modError.ErrorMessage(Err.Number, Err.Description)
Err.Clear
vFieldValue = Null
ReadValue = False
ElseIf rs.EOF Or rs.BOF Then
vFieldValue = Null
ReadValue = False
Else
vFieldValue = Null
vFieldValue = rs.Fields(sFieldName)
ReadValue = Not IsNull(vFieldValue)
End If
End If
rs.Close: Set rs = Nothing
If bOpenConnection Then
cnnLocal.Close: Set cnnLocal = Nothing
End If
On Error GoTo 0
End Function
Public Function ExecuteCommand _
( _
nRecords As Long, _
sSQL As String, _
Optional cnn = Null, _
Optional sServerName As String = "", _
Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800, _
Optional bShowError As Boolean = True _
)
On Error Resume Next: Err.Clear
Dim cnnLocal As ADODB.Connection, bOpenConnection As Boolean
If IsNull(cnn) Then
bOpenConnection = True
Call modSQL.OpenConnection(cnnLocal, sServerName, sDatabaseName, iCommandTimeout)
Else
bOpenConnection = False
Set cnnLocal = cnn
End If
nRecords = 0
cnnLocal.Execute sSQL, nRecords
If Err.Number <> 0 Then
If bShowError Then
Call modError.ErrorMessage(Err.Number, Err.Description)
End If
Err.Clear
ExecuteCommand = False
Else
ExecuteCommand = True
End If
If bOpenConnection Then
cnnLocal.Close: Set cnnLocal = Nothing
End If
On Error GoTo 0
End Function
Public Function ExecuteInsert _
( _
vObjectID As Variant, _
sInsertSQL As String, _
sTableName As String, sTableDescription As String, _
Optional cnn = Null, _
Optional sServerName As String = "", _
Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800 _
)
On Error Resume Next: Err.Clear
Dim nInsertRecords As Long, nIdentityRecords As Long
nInsertRecords = 0
nIdentityRecords = 0
vObjectID = -1
ExecuteInsert = False
Dim sTableNameTruncate As String, sIdentitySQL As String
If Left(sTableName, 3) = "dbo" Then
sTableNameTruncate = "dbo." & Replace(sTableName, "dbo.", "")
Else
sTableNameTruncate = sTableName
End If
sIdentitySQL = _
"SELECT IDENT_CURRENT('" & sTableNameTruncate & " '), " & _
"SCOPE_IDENTITY()"
Dim cnnLocal As ADODB.Connection
Dim bOpenConnection As Boolean
If IsNull(cnn) Then
bOpenConnection = True
Call modSQL.OpenConnection(cnnLocal, sServerName, sDatabaseName, iCommandTimeout)
Else
bOpenConnection = False
Set cnnLocal = cnn
End If
Dim rsIdentity As ADODB.Recordset
Call modSQL.ExecuteCommand(nInsertRecords, sInsertSQL, cnnLocal)
Call modSQL.OpenRecordset(rsIdentity, nIdentityRecords, sIdentitySQL, cnnLocal)
If Left(sInsertSQL, 7) = "INSERT " And (Err.Number <> 0 Or nInsertRecords <> 1 Or nIdentityRecords <> 1) Then
modError.ErrorMessage _
9060701, _
"Запись в таблицу " & _
sTableName & " " & sTableDescription & " " & _
"не была добавлена."
Err.Clear: GoTo END_PROCEDURE
ElseIf Left(sInsertSQL, 4) = "EXEC" And (Err.Number <> 0 Or nIdentityRecords <> 1) Then
modError.ErrorMessage _
9060701, _
"Запись в таблицу " & _
sTableName & " " & sTableDescription & " " & _
"не была добавлена."
Err.Clear: GoTo END_PROCEDURE
End If
If rsIdentity.Fields(0) <> rsIdentity.Fields(1) Then
modError.ErrorMessage 9060702, _
"При добавлении в таблицу " & _
sTableName & " " & sTableDescription & " " & _
"неправильно был определен уникальный код записи (счетчик)."
Err.Clear: GoTo END_PROCEDURE
Else
vObjectID = rsIdentity.Fields(0)
ExecuteInsert = True
End If
END_PROCEDURE:
rsIdentity.Close: Set rsIdentity = Nothing
If bOpenConnection Then
cnnLocal.Close: Set cnnLocal = Nothing
End If
On Error GoTo 0
End Function
Public Function ExecuteUpdate _
( _
sUpdateSQL As String, _
Optional sTableName As String = "", Optional sTableDescription As String = "", _
Optional cnn = Null, Optional sServerName As String = "", Optional sDatabaseName As String = "", _
Optional iCommandTimeout As Integer = 800 _
)
On Error Resume Next: Err.Clear
Dim nUpdateRecords As Long
nUpdateRecords = 0
ExecuteUpdate = False
Dim cnnLocal As ADODB.Connection
Dim bOpenConnection As Boolean
If IsNull(cnn) Then
bOpenConnection = True
Call modSQL.OpenConnection(cnnLocal, sServerName, sDatabaseName, iCommandTimeout)
Else
bOpenConnection = False
Set cnnLocal = cnn
End If
Call modSQL.ExecuteCommand(nUpdateRecords, sUpdateSQL, cnn)
If Err.Number <> 0 Then
If sTableName <> "" And sTableDescription <> "" Then
modError.ErrorMessage _
9010703, _
"Ошибка при записи данных (обновлении записи) в таблицу " & _
sTableName & " " & sTableDescription
End If
Err.Clear
Else
ExecuteUpdate = True
End If
If bOpenConnection Then
cnnLocal.Close: Set cnnLocal = Nothing
End If
On Error GoTo 0
End Function
Public Function ToString(v As Variant) As String
Dim VALUE: VALUE = v
Dim i As Integer: i = 0
Begin_Label:
If IsNull(VALUE) Then
ToString = "NULL"
Else
Select Case VarType(VALUE)
Case vbEmpty, vbNull
ToString = "NULL"
Case vbInteger, vbLong
ToString = CStr(v)
Case vbSingle, vbDouble, vbDecimal, vbCurrency
If VALUE = -1E+50 Then
ToString = "NULL"
Else
Dim sDecimalSeparator As String, sThouthandSeparator As String
sDecimalSeparator = Mid(Format(0, "0.0"), 2, 1)
sThouthandSeparator = Mid(Format(1000, "0,000"), 2, 1)
ToString = CStr(v)
ToString = Replace(ToString, sDecimalSeparator, "!")
ToString = Replace(ToString, sThouthandSeparator, "")
ToString = Replace(ToString, "!", ".")
End If
Case vbDate
Date_Label:
If v = modDate.EMPTY_DATE Then
ToString = "NULL"
Else
ToString = "'" & Format(v, "yyyymmdd hh:mm:ss") & "'"
End If
Case vbString
If InStr(VALUE, "-") > 0 _
Or InStr(VALUE, "/") > 0 _
Or InStr(VALUE, ".") > 0 Then
If InStr(InStr(VALUE, "-") + 1, VALUE, "-") > 0 _
Or InStr(InStr(VALUE, "/") + 1, VALUE, "/") > 0 _
Or InStr(InStr(VALUE, ".") + 1, VALUE, ".") > 0 Then
If IsDate(VALUE) Then
VALUE = CDate(VALUE)
GoTo Date_Label
End If
End If
End If
If UCase(VALUE) = "NULL" Then
ToString = "NULL"
Else
ToString = "'" & Replace(VALUE, "'", "''") & "'"
End If
Case vbBoolean
ToString = IIf(v, "-1", "0")
Case vbObject
On Error Resume Next
VALUE = v.VALUE
If Err.Number <> 0 Then
Err.Clear
ToString = "NULL"
Else
i = i + 1
If i < 16 Then
GoTo Begin_Label
Else
ToString = "NULL"
End If
End If
Case Else
ToString = "NULL"
End Select
End If
End Function
Public Function Add(v As Variant, Optional bIsLast As Boolean = False) As String
Add = ToString(v)
If Not bIsLast Then
Add = Add & ", "
Else
Add = Add & " "
End If
End Function
Public Function AddParameter(v As Variant, Optional bIsLast As Boolean = False, _
Optional sDelimiter As String = ",") As String
AddParameter = ToString(v)
If Not bIsLast Then
AddParameter = AddParameter & sDelimiter & " "
Else
AddParameter = AddParameter & " "
End If
End Function
' Ф-ии добавления параметра заданного типа нужны, если в качестве аргумента используется
' свободный контрол, который может принимать значение NULL
' Для bound контролов и непустых значений ф-ия AddParameter сама выясняет нужный тип параметра
Public Function AddString(vString As Variant, Optional bIsLast As Boolean = False) As String
If VarType(vString) = vbEmpty Then vString = Null
If IsNull(vString) Then
AddString = AddParameter(vString, bIsLast)
Else
Dim s As Variant
s = "@" + IIf(IsNull(vString), Null, CStr(Nz(vString, "")))
s = AddParameter(s, bIsLast)
AddString = Mid(s, 1, 1) & Mid(s, 3, Len(s) - 2)
End If
End Function
Public Function AddDate(vDate As Variant, Optional bIsLast As Boolean = False) As String
If VarType(vDate) = vbEmpty Then vDate = Null
If vDate = "" Then vDate = Null
If vDate = 0 Then vDate = Null
AddDate = AddParameter(IIf(IsNull(vDate), Null, CDate(Nz(vDate, #1/1/1900#))), bIsLast)
End Function
Public Function AddDateTime(vDate As Variant, Optional bIsLast As Boolean = False) As String
If VarType(vDate) = vbEmpty Then vDate = Null
If VarType(vDate) = vbNull Then
AddDateTime = AddParameter(Null, bIsLast)
Else
AddDateTime = "'" & Format(CDate(vDate), "yyyymmdd hh:mm:ss") & "'"
End If
If Not bIsLast Then AddDateTime = AddDateTime & ", "
End Function
Public Function AddLong(vLong As Variant, Optional bIsLast As Boolean = False) As String
If VarType(vLong) = vbEmpty Then vLong = Null
AddLong = AddParameter(IIf(IsNull(vLong), Null, CLng(Nz(vLong, 0))), bIsLast)
End Function
Public Function AddDecimal(vDecimal As Variant, Optional bIsLast As Boolean = False) As String
If VarType(vDecimal) = vDecimal Then vDecimal = Null
AddDecimal = AddParameter(IIf(IsNull(vDecimal), Null, CDbl(Nz(vDecimal, 0))), bIsLast)
End Function
Public Function ParseSelectFromWhereOrderBy(sSQL As String, sSelect As String, sFrom As String, sWhere As String, sOrderBy As String)
Dim iSelect As Integer, iFrom As Integer, iWhere As Integer, iOrderBy As Integer
Dim s As String
s = Replace(sSQL, Chr(9), " ")
s = Replace(s, Chr(13), " ")
s = Replace(s, Chr(10), " ")
iSelect = InStr(1, s, "SELECT "): sSelect = ""
iFrom = InStrRev(s, " FROM "): sFrom = ""
iWhere = InStrRev(s, " WHERE "): sWhere = ""
iOrderBy = InStrRev(s, " ORDER BY "): sOrderBy = ""
If iSelect = 0 Or iFrom = 0 _
Or (iFrom <= iSelect) _
Or (iWhere > 0 And iWhere <= iFrom) _
Or (iOrderBy > 0 And iOrderBy <= iWhere) _
Then
ParseSelectFromWhereOrderBy = False
Exit Function
End If
sSelect = Trim(Mid(s, iSelect + Len("SELECT "), iFrom - (iSelect + Len("SELECT "))))
If iWhere > 1 And iOrderBy > 1 Then
sFrom = Trim(Mid(s, iFrom + Len(" FROM "), iWhere - (iFrom + Len(" FROM "))))
sWhere = Trim(Mid(s, iWhere + Len(" WHERE "), iOrderBy - (iWhere + Len(" WHERE "))))
sOrderBy = Mid(s, iOrderBy + Len(" ORDER BY "))
ElseIf iWhere > 1 And iOrderBy = 0 Then
sFrom = Trim(Mid(s, iFrom + Len(" FROM "), iWhere - (iFrom + Len(" FROM "))))
sWhere = Mid(s, iWhere + Len(" WHERE "))
ElseIf iWhere = 0 And iOrderBy > 1 Then
sFrom = Trim(Mid(s, iFrom + Len(" FROM "), iOrderBy - (iFrom + Len(" FROM "))))
sOrderBy = Mid(s, iOrderBy + Len(" ORDER BY "))
Else ' iWhere = 0 And iOrderBy = 0
sFrom = Trim(Mid(s, iFrom + Len(" FROM ")))
End If
End Function
Public Sub Test_ParseSelectFromWhereOrderBy()
Dim sSQL As String, sSelect As String, sFrom As String, sWhere As String, sOrderBy As String
sSQL = "SELECT * FROM TAB WHERE id > 0 ORDER BY sName"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
sSQL = "SELECT * FROM TAB ORDER BY sName"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
sSQL = "SELECT * FROM TAB WHERE id > 0"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
sSQL = "SELECT * FROM TAB"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
sSQL = "select sParusCustomerCode = '*', sParusCustomerAlias = '<Все мнемокоды>', sCondition = '1=1'" & vbNewLine & _
"union all select sParusCustomerCode, sParusCustomerAlias, 'sParusCustomerCode=''{LIST}'''" & vbNewLine & _
"from qrParusCustomerCodeBind1" & vbNewLine & _
"order by sParusCustomerCode"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
End Sub
Public Function JoinSelectFromWhereOrderBy _
( _
sSQL As String, _
sSelect As String, _
sFrom As String, _
Optional sWhere As String = "", _
Optional sOrderBy As String = "", _
Optional bDistinct As Boolean = False _
)
If Len(sSelect) = 0 Or Len(sFrom) = 0 Then
JoinSelectFromWhereOrderBy = False
Exit Function
End If
sSQL = "SELECT "
If bDistinct Then sSQL = sSQL & "DISTINCT "
sSQL = sSQL & sSelect
sSQL = sSQL & " FROM " & sFrom
If Len(sWhere) > 0 Then sSQL = sSQL & " WHERE " & sWhere
If Len(sOrderBy) > 0 Then sSQL = sSQL & " ORDER BY " & sOrderBy
JoinSelectFromWhereOrderBy = True
End Function
Public Function JoinFromWhereOrderBy _
( _
sSQL As String, _
sFrom As String, _
Optional sWhere As String = "", _
Optional sOrderBy As String = "" _
)
JoinFromWhereOrderBy = JoinSelectFromWhereOrderBy(sSQL, "*", sFrom, sWhere, sOrderBy)
End Function
Public Sub Test_JoinSelectFromWhereOrderBy()
Dim sSQL As String, sSelect As String, sFrom As String, sWhere As String, sOrderBy As String
sSQL = "SELECT * FROM TAB WHERE id > 0 ORDER BY sName"
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
JoinSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
JoinSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere, sOrderBy, True
Debug.Print "|" & sSQL & "|" & sSelect & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
JoinFromWhereOrderBy sSQL, sFrom, sWhere, sOrderBy
Debug.Print "|" & sSQL & "|" & sFrom & "|" & sWhere & "|" & sOrderBy & "|"
End Sub
Public Function AddWhereAnd(sWhere1 As String, sWhere2 As String)
AddWhereAnd = sWhere1
If Len(sWhere1) > 0 And Len(sWhere2) > 0 Then
AddWhereAnd = "(" & sWhere1 & ") AND (" & sWhere2 & ")"
ElseIf Len(sWhere1) > 0 And Len(sWhere2) = 0 Then
AddWhereAnd = sWhere1
ElseIf Len(sWhere1) = 0 And Len(sWhere2) > 0 Then
AddWhereAnd = sWhere2
Else
AddWhereAnd = ""
End If
End Function
Public Function AddWhere(sSQL As String, sWhere As String)
Dim sSQL_Local As String, sSelect As String, sFrom As String, sWhere_Local As String, sOrderBy As String
ParseSelectFromWhereOrderBy sSQL, sSelect, sFrom, sWhere_Local, sOrderBy
sWhere = AddWhereAnd(sWhere_Local, sWhere)
JoinSelectFromWhereOrderBy sSQL_Local, sSelect, sFrom, sWhere, sOrderBy
AddWhere = sSQL_Local
End Function
Public Function Test_AddWhere()
Dim sSQL As String, sWhere As String
sSQL = "SELECT a, b FROM tbl WHERE 1=1 AND 1=2"
sWhere = "ID=123"
Debug.Print AddWhere(sSQL, sWhere)
End Function
----
|
