Setelah sekian lama saya mencari apa sih metode yang pas untuk koneksi
ke database, perasaan banyak banget metodenya. akhirnya saya coba
untuk membuat Class Module untuk koneksi, Pengambilan dan manipulasi
database.
Class ini tidak sepenuhnya buatan saya tapi saya ambil dari beberapa
referensi.
Semoga class modul ini bermanfaat buat rekan indoprog-vb.
Option Explicit
Private m_sConnectionString As String
Private m_sLastError As String
Private m_bIsSQL As Boolean
Private m_sql_server As Boolean
Private cn As ADODB.Connection
Public Property Get ConnectionString() As String
ConnectionString = m_sConnectionString
End Property
Public Property Let ConnectionString(ByVal NewValue As String)
m_sConnectionString = NewValue
End Property
Public Property Get isSQL() As Boolean
isSQL = m_bIsSQL
End Property
Public Property Let sqlServer(ByVal NewValue As Boolean)
m_sql_server = NewValue
End Property
Public Property Get sqlServer() As Boolean
sqlServer = m_sql_server
End Property
Public Property Let isSQL(ByVal NewValue As Boolean)
m_bIsSQL = NewValue
End Property
Public Function Clone(ByVal objRecordset As ADODB.Recordset, Optional
ByVal LockType As ADODB.LockTypeEnum = adLockBatchOptimistic) As
ADODB.Recordset
Dim objNewRS As ADODB.Recordset
Dim objField As Object
Dim lngCnt As Long
On Error GoTo LocalError
Set objNewRS = New ADODB.Recordset
objNewRS.CursorLocation = adUseClient
objNewRS.LockType = LockType
For Each objField In objRecordset.Fields
objNewRS.Fields.Append objField.Name, objField.Type,
objField.DefinedSize, objField.Attributes
Next objField
If Not objRecordset.RecordCount = 0 Then
Set objNewRS.ActiveConnection = objRecordset.ActiveConnection
objNewRS.Open
objRecordset.MoveFirst
While Not objRecordset.EOF
objNewRS.AddNew
For lngCnt = 0 To objRecordset.Fields.Count - 1
objNewRS.Fields(lngCnt).Value =
objRecordset.Fields(lngCnt).Value
Next lngCnt
objRecordset.MoveNext
Wend
objNewRS.MoveFirst
End If
Set Clone = objNewRS
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If objNewRS.state = adStateOpen Then
objNewRS.Close
End If
Set objNewRS = Nothing
End Function
Function Datashape(ByVal tblParent As String, _
ByVal tblChild As String, _
ByVal fldParent As String, _
ByVal fldChild As String, _
Optional ordParent As String = "", _
Optional ordChild As String = "", _
Optional WhereParent As String = "", _
Optional WhereChild As String = "", _
Optional ParentFields As String = "*", _
Optional ChildFields As String = "*", _
Optional MaxRecords As Long = 0) As ADODB.Recordset
On Error GoTo ErrHandler
'Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim lSQL As String
Dim pSQL As String
Dim cSQL As String
Dim pWhere As String
Dim cWhere As String
Dim pOrder As String
Dim cOrder As String
lSQL = ""
ParentFields = Replace(ParentFields, "|", ", ")
ChildFields = Replace(ChildFields, "|", ", ")
pWhere = WhereParent
cWhere = WhereChild
pOrder = ordParent
cOrder = ordChild
If WhereParent <> "" Then WhereParent = " WHERE " & WhereParent
If WhereChild <> "" Then WhereChild = " WHERE " & WhereChild
If pOrder <> "" Then pOrder = " ORDER By " & pOrder
If cOrder <> "" Then cOrder = " ORDER By " & cOrder
pSQL = ""
If MaxRecords > 0 Then
If isSQL Then
pSQL = pSQL & "{SET ROWCOUNT " & MaxRecords & " SELECT
@PARENTFIELDS"
Else
pSQL = pSQL & "{SELECT TOP " & MaxRecords & " @PARENTFIELDS"
End If
Else
pSQL = pSQL & "{SELECT " & "@PARENTFIELDS"
End If
pSQL = pSQL & " FROM @PARENT"
pSQL = pSQL & " @WHEREPARENT"
pSQL = pSQL & " @ORDPARENT} "
pSQL = Replace(pSQL, "@PARENTFIELDS", ParentFields)
pSQL = Replace(pSQL, "@PARENT", tblParent)
pSQL = Replace(pSQL, "@WHEREPARENT", pWhere)
pSQL = Replace(pSQL, "@ORDPARENT", pOrder)
pSQL = Trim(pSQL)
cSQL = ""
cSQL = cSQL & "{SELECT " & "@CHILDFIELDS"
cSQL = cSQL & " FROM @CHILD"
cSQL = cSQL & " @WHERECHILD"
cSQL = cSQL & " @ORDCHILD} "
cSQL = Replace(cSQL, "@CHILDFIELDS", ChildFields)
cSQL = Replace(cSQL, "@CHILD", tblChild)
cSQL = Replace(cSQL, "@WHERECHILD", cWhere)
cSQL = Replace(cSQL, "@ORDCHILD", cOrder)
cSQL = Trim(cSQL)
lSQL = "SHAPE " & pSQL & vbCrLf
lSQL = lSQL & "APPEND (" & cSQL & " RELATE " & fldParent & " TO "
& fldChild & ") AS ChildItems"
Set cn = New ADODB.Connection
With cn
.ConnectionString = ConnectionString
.CursorLocation = adUseServer
.Provider = "MSDataShape"
.Open
End With
Set rs = New ADODB.Recordset
With rs
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Source = lSQL
.ActiveConnection = cn
.Open
End With
'Set rs.ActiveConnection = Nothing
cn.Close
Set cn = Nothing
Set Datashape = rs
Set rs = Nothing
Exit Function
ErrHandler:
If Not cn Is Nothing Then
If cn.state = adStateOpen Then cn.Close
Set cn = Nothing
End If
m_sLastError = Err.Number & " - " & Err.Description
End Function
Public Function EmptyRS(ByVal adoRS As ADODB.Recordset) As Boolean
On Error GoTo ErrHandler
EmptyRS = True
If Not adoRS Is Nothing Then
EmptyRS = ((adoRS.BOF = True) And (adoRS.EOF = True))
End If
Exit Function
ErrHandler:
m_sLastError = Err.Number & " - " & Err.Description
EmptyRS = True
End Function
Public Function Execute(sql As String) As Boolean
On Error GoTo LocalError
With cn
.BeginTrans
.Execute sql
.CommitTrans
End With
Execute = True
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
'Debug.Print m_sLastError
cn.RollbackTrans
connect
Execute = False
End Function
Public Function GetRS(sql As String) As ADODB.Recordset
Dim rs As New ADODB.Recordset
On Error GoTo LocalError
With rs
.ActiveConnection = cn 'ConnectionString
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly ' adOpenKeyset
.Source = sql
.Open
Set .ActiveConnection = Nothing
End With
Set GetRS = rs
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
'Debug.Print m_sLastError
Set rs = Nothing
End Function
Public Function GetCount(TableName As String, Optional WhereClause As
String = "") As Single
On Error GoTo LocalError
Dim rs As New ADODB.Recordset
Dim sql As String
GetCount = 0
If WhereClause <> "" Then
sql = "Select COUNT (*) FROM " & TableName & " WHERE " &
WhereClause
Else
sql = "Select COUNT (*) FROM " & TableName
End If
With rs
.ActiveConnection = cn
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Source = sql
.Open
Set .ActiveConnection = Nothing
End With
GetCount = rs.Fields(0).Value
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
Debug.Print m_sLastError
If rs.state = adStateOpen Then
rs.Close
End If
Set rs = Nothing
GetCount = -1
End Function
Public Function GetMax(FieldName As String, TableName As String,
Optional WhereClause As String = "") As Single
On Error GoTo LocalError
Dim rs As New ADODB.Recordset
Dim sql As String
GetMax = 0
If WhereClause <> "" Then
sql = "Select MAX(" & FieldName & ") FROM " & TableName & "
WHERE " & WhereClause
Else
sql = "Select MAX(" & FieldName & ") FROM " & TableName
End If
With rs
.ActiveConnection = cn
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Source = sql
.Open
'Set .ActiveConnection = Nothing
End With
GetMax = rs.Fields(0).Value
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If rs.state = adStateOpen Then
rs.Close
End If
Set rs = Nothing
GetMax = -1
End Function
Public Function GetSum(FieldName As String, TableName As String,
Optional WhereClause As String = "") As Double
On Error GoTo LocalError
Dim rs As New ADODB.Recordset
Dim sql As String
GetSum = 0
If WhereClause <> "" Then
sql = "Select SUM(" & FieldName & ") FROM " & TableName & "
WHERE " & WhereClause
Else
sql = "Select SUM(" & FieldName & ") FROM " & TableName
End If
With rs
.ActiveConnection = cn
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.CursorType = adOpenKeyset
.Source = sql
.Open
Set .ActiveConnection = Nothing
End With
GetSum = rs.Fields(0).Value
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If rs.state = adStateOpen Then
rs.Close
End If
Set rs = Nothing
GetSum = 0
End Function
Public Function PutRS(rs As ADODB.Recordset) As Boolean
On Error GoTo LocalError
PutRS = False
If EmptyRS(rs) Then
Exit Function
ElseIf rs.LockType = adLockReadOnly Then
Exit Function
Else
'Dim cn As New ADODB.Connection
cn.BeginTrans
With rs
.ActiveConnection = cn
.UpdateBatch
cn.CommitTrans
'Set .ActiveConnection = Nothing
End With
'cn.Close
'Set cn = Nothing
End If
PutRS = True
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
cn.RollbackTrans
connect
PutRS = False
End Function
Public Function sqlBoolean(TrueFalse As Boolean) As Integer
sqlBoolean = TrueFalse
If isSQL Then
If TrueFalse = True Then sqlBoolean = TrueFalse * TrueFalse
End If
End Function
Public Function sqlDate(ByVal vDate As Variant) As String
On Error GoTo LocalError
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
sqlDate = ""
If Not IsDate(vDate) Or IsNull(vDate) Then
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
Exit Function
End If
End If
If isSQL Then
'Format MM/DD/??YY
sqlDate = Format(vDate, "mm\/dd\/yyyy")
sqlDate = "#" & sqlDate & "#"
Else
'Format Regional Setting
sqlDate = FormatDateTime(vDate, vbShortDate)
sqlDate = "#" & sqlDate & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlDate = ""
End Function
Public Function sqlDateTime(ByVal vDate As Variant) As String
On Error GoTo LocalError
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
sqlDateTime = ""
If Not IsDate(vDate) Or IsNull(vDate) Then
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
Exit Function
End If
End If
If isSQL Then
'Format MM/DD/??YY HH:MM:SS
sqlDateTime = Format(vDate, "mm\/dd\/yyyy hh\:mm\:ss")
sqlDateTime = "'" & sqlDateTime & "'"
Else
'Format Regional Settings
sqlDateTime = FormatDateTime(vDate, vbShortDate) & " " &
Format(vDate, "hh\:mm\:ss")
sqlDateTime = "#" & sqlDateTime & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlDateTime = ""
End Function
Public Function sqlTime(ByVal vDate As Variant) As String
On Error GoTo LocalError
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
sqlTime = ""
If Not IsDate(vDate) Or IsNull(vDate) Then
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
Exit Function
End If
End If
If isSQL Then
'Format MM/DD/??YY HH:MM:SS
sqlTime = FormatDateTime(vDate, vbLongTime)
sqlTime = "'" & sqlTime & "'"
Else
'Format Regional Settings
sqlTime = FormatDateTime(vDate, vbLongTime)
sqlTime = "#" & sqlTime & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlTime = ""
End Function
Public Function sqlEncode(sqlValue) As String
'Mencagah SQL Injection
sqlEncode = Replace(sqlValue, "'", "''")
End Function
Public Property Get LastError() As String
LastError = m_sLastError
m_sLastError = ""
End Property
Public Function ExecuteID(sql As String) As Single
On Error GoTo LocalError
Dim rs As New ADODB.Recordset
Dim AutoID As Single
With rs
.CursorLocation = adUseServer
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Source = "SELECT @@IDENTITY"
End With
With cn
.BeginTrans
.Execute sql, , adCmdText + adExecuteNoRecords
With rs
.ActiveConnection = cn
.Open , , , , adCmdText
AutoID = rs(0).Value
.Close
End With
.CommitTrans
End With
Set rs = Nothing
ExecuteID = AutoID
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
cn.RollbackTrans
ExecuteID = 0
End Function
