Planet Source Code Jumbo …e CD Visual Basic 1 to 7/5_2007-2008.ISO/data/Zips/My_DLL(upd20886610272007.psc/EazyDtAcc+NewMsgBox/DLL/AksesDatabase.cls

Text File | 2007-10-03 | 10KB | 452 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 1  'vbDataSource
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "AksesData"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'%#########################################%'
'%Author   : Tendri S (20)                 %'
'%Date     : October 03, 2007 (Update)     %'
'%Location : Bekasi, Indonesia             %'
'%Email    : [e-mail]          %'
'%Please Do Not Removes Any Copyrights     %'
'%#########################################%'

Private Cn As New ADODB.Connection
Private rs As New ADODB.Recordset
Private Rs2 As New ADODB.Recordset
Private TransOpen As Boolean
Private RsOpen As Boolean
Private RsOpen2 As Boolean
Private ConnectString As String

Private mvarConnectStr As String
Private mvarConnectionType As ConnectType

Public Enum ConnectType
 OnDemand = 0
 Persist = 1
End Enum
Public Property Let TipeKoneksi(ByVal vData As ConnectType)
'mengubah nilai
mvarConnectionType = vData
End Property
Public Property Get TipeKoneksi() As ConnectType
'membaca nilai
TipeKoneksi = mvarConnectionType
End Property
Public Property Let KonekStr(ByVal vData As String)
mvarConnectStr = vData
ConnectString = mvarConnectStr
End Property
Public Property Get KonekStr() As String
KonekStr = mvarConnectStr
End Property
Public Function GetAllData(Tabel As String, OrderBy As String) As Recordset
On Error GoTo ErrorCheck

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

yy = "select * from " & Tabel & " order by " & OrderBy
Set rs = New ADODB.Recordset
rs.Open yy, Cn, adOpenDynamic, adLockOptimistic
RsOpen = True
Set GetAllData = rs

Exit Function

If TipeKoneksi = OnDemand Then
 Set Cn = Nothing
End If

rs.Close
Set rs = Nothing

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
End Function
Public Function DeleteData(Tabel As String, Field As String, Data As String) As Boolean
'UNTUK NGEHAPUS RECORD-RECORD DARI DATABASE
On Error GoTo ErrorCheck

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

yy = "select * from " & Tabel & " where " & Field & "='" & Data & "'"
Set rs = New ADODB.Recordset
rs.Open yy, Cn, adOpenKeyset, adLockOptimistic

If Not rs.EOF Then
 xx = "delete from " & Tabel & " where " & Field & "='" & Data & "'"
 Cn.Execute xx
 DeleteData = True
 'MsgBox "Data is completely removed..", vbInformation, "Data Access"
 rs.Close
 Set rs = Nothing
Else
 'MsgBox "Record not found, Delete Failed..", vbCritical, "Pesan"
 mb.TendriMsg "Record not found, Delete Failed..", vbCritical, "Tendri Data Access"
 DeleteData = False
 rs.Close
 Set rs = Nothing
 Exit Function
End If

If TipeKoneksi = OnDemand Then
 DisconnectDB
End If

Exit Function

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
 DeleteData = False
End Function

Public Function GetData(Tabel As String, NmField As String, PKey As String, Data As String)
On Error GoTo ErrorCheck

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

yy = "select " & NmField & " from " & Tabel & " where " & PKey & "='" & Data & "'"
Set rs = New ADODB.Recordset
rs.Open yy, Cn, adOpenDynamic, adLockOptimistic

If Not rs.EOF Then
 GetData = rs(0)
Else
 GetData = ""
End If

rs.Close
Set rs = Nothing

Exit Function

If TipeKoneksi = OnDemand Then
 Set Cn = Nothing
End If

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
End Function
Public Function CekData(Tabel As String, NmField As String, Data As Variant) As Boolean
On Error GoTo ErrorCheck

Dim xx As String

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

xx = "select * from " & Tabel & " where " & NmField & "='" & Data & "'"
rs.Open xx, Cn, adOpenDynamic, adLockOptimistic

If Not rs.EOF Then
 CekData = True
Else
 CekData = False
End If

rs.Close
Set rs = Nothing

If TipeKoneksi = OnDemand Then
 DisconnectDB
End If

Exit Function

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 CekData = False
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
End Function

Public Function FillListCombo(Field As String, Tabel As String, Combo As Object)
On Error Resume Next

Dim x As String

Combo.Clear

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

Set rs = New ADODB.Recordset
x = "select " & Field & " from " & Tabel & " order by " & Field & ""
rs.Open x, Cn, adOpenDynamic, adLockOptimistic

While Not rs.EOF
 Combo.AddItem rs(0)
 rs.MoveNext
Wend

rs.Close
Set rs = Nothing

If TipeKoneksi = OnDemand Then
 DisconnectDB
End If
End Function
Public Function InsertData(ByVal SqlStr As String, RecordArray() As Variant) As Boolean
'UNTUK TAMBAH DATA BARU
Dim y As Integer
Dim Size As Integer
Dim RsCount As Integer

On Error GoTo ErrorCheck

'jml array
Size = UBound(RecordArray)

'konek ke database
If Not Cn.State = adStateOpen Then
 ConnectDb
End If

Cn.BeginTrans

TransOpen = True
Rs2.Open SqlStr, Cn, adOpenKeyset, adLockOptimistic
RsOpen = True
Rs2.AddNew

For y = 0 To Size
 If Not RecordArray(y) = Empty Then
  Rs2.Fields(y).Value = RecordArray(y)
 End If
Next

Rs2.Update
InsertData = True
'MsgBox "Data is completely saved..", vbInformation, "Data Access"

Rs2.Close
RsOpen = False

Cn.CommitTrans

TransOpen = False
Set Rs2 = Nothing

If TipeKoneksi = OnDemand Then
 DisconnectDB
End If

Exit Function

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 If TransOpen = True Then
  Cn.RollbackTrans
 End If
 InsertData = False
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
End Function
Public Function UpdateData(ByVal SqlStr As String, RecordArray() As Variant, Optional dtField As String) As Boolean
'UNTUK NGEDIT RECORD
Dim y As Integer
Dim Size As Integer
Dim RsCount As Integer

On Error GoTo ErrorCheck

'jml array
Size = UBound(RecordArray)

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

Cn.BeginTrans

TransOpen = True
Rs2.Open SqlStr, Cn, adOpenKeyset, adLockOptimistic
RsOpen = True

If Not Rs2.EOF Then
 'Loop semua record
 y = 0
 RsCount = Rs2.RecordCount

 If RsCount > 1 Then
  'MsgBox "More than one record, Update Failed..", vbCritical, "Data Access"
  mb.TendriMsg "More than one record, Update Failed..", vbCritical, "Tendri Data Access"
  UpdateData = False
  Exit Function
 Else
  For y = 0 To Size
   If Not RecordArray(y) = Empty Then
    Rs2.Fields(y).Value = RecordArray(y)
   End If
  Next

  Rs2.Update
  UpdateData = True
  If dtField = Empty Then mb.TendriMsg "Data has been updated..", vbInformation, "Tendri Data Access"
  'MsgBox "Data is completely updated..", vbInformation, "Data Access"
  If dtField <> Empty Then
   For I = 0 To RsCount
    mb.TendriMsg "Data " & dtField & " " & Rs2.Fields(I) & " has been updated..", vbInformation, "Tendri Data Access"
    Exit For
   Next
  End If
 End If

 Rs2.Close
 RsOpen = False

 Cn.CommitTrans

 TransOpen = False
 Set Rs2 = Nothing
Else
 Cn.RollbackTrans

 Rs2.Close
 RsOpen = False
 Set Rs2 = Nothing
 'MsgBox "No record found, Update Failed..", vbCritical, "Pesan"
 mb.TendriMsg "No record found, Update Failed..", vbCritical, "Tendri Data Access"
 UpdateData = False
 Exit Function
End If

If TipeKoneksi = OnDemand Then
 DisconnectDB
End If

Exit Function

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
 If TransOpen = True Then
  Cn.RollbackTrans
 End If
 UpdateData = False
 If TipeKoneksi = OnDemand Then
  DisconnectDB
 End If
End Function

Private Sub ConnectDb()
'UNTUK MEMBUAT KONEKSI ADO KE DB
On Error GoTo ErrorCheck

Cn.ConnectionTimeout = 0
Cn.CommandTimeout = 0
Cn.CursorLocation = adUseClient
Cn.Open ConnectString

Exit Sub

ErrorCheck:
 MsgBox Err.Description, , "Data Access"
End Sub
Public Function SearchData(ByVal SqlStr As String) As Recordset
On Error Resume Next

If Not Cn.State = adStateOpen Then
 ConnectDb
End If

Rs2.Open SqlStr, Cn, adOpenDynamic, adLockOptimistic
If Not Rs2.EOF Then
 RsOpen = True
 Set SearchData = Rs2
Else
 Rs2.Close
 Set Rs2 = Nothing
 RsOpen = False
End If

Exit Function

If ConnectionType = OnDemand Then
 Set Cn = Nothing
End If
End Function

Private Sub DisconnectDB()
On Error Resume Next
'UNTUK MENUTUP RECORDSET DAN KONEKSI KE DATABASE

If RsOpen = True Then
 Set rs = Nothing
 RsOpen = False
End If

If RsOpen2 = True Then
 Set Rs2 = Nothing
 RsOpen2 = False
End If

Cn.Close
Set Cn = Nothing

Exit Sub
End Sub


'Private Sub DisplayError()
'ConcatString = ""
'Dim ec As Integer
'
'If Cn.Errors.Count > 0 Then
' For ec = 0 To Cn.Errors.Count - 1
'  ConcatString = ConcatString & "DB Error Number: " & Cn.Errors(ec).Number & vbNewLine
'  ConcatString = ConcatString & "     Source: " & Cn.Errors(ec).Source & vbNewLine
'  ConcatString = ConcatString & "             " & Cn.Errors(ec).Description & vbNewLine
'  ConcatString = ConcatString & vbNewLine
' Next
'
' If TransOpen = True Then
'  ConcatString = ConcatString & "ADO.RollBack" & vbNewLine
'  ConcatString = ConcatString & "          Proses penyimpanan data diroll back telah terjadi error. Data tidak tersimpan."
'  ConcatString = ConcatString & vbNewLine
'  RollBackOccured = False
' End If
'Else
' ConcatString = ConcatString & "In Code Error Number: " & Err.Number & vbNewLine
' ConcatString = ConcatString & "          " & Err.Description & vbNewLine
' ConcatString = ConcatString & vbNewLine
'End If
'End Sub
Private Sub Class_Terminate()
 DisconnectDB
End Sub