laatzen/Pruef2000/source/Shared/universal/DBAccess.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDBAccess"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
'==============================================================================
'
' File   : DBAccess.cls
' Date   : 22.03.1999
' Version: 1.00
' Author : Andreas Schmidt, lindner&partner
'
'==============================================================================
'
' *shared*
'
' Abstraktion von ADODB.connection
'
' TODO: Server-Connection und eine Client-Connection halten.
'
'==============================================================================
'
' History:
'
' Date   : 22.03.1999
' Version: 1.00
' Author : Andreas Schmidt, lindner&partner
'
' Erste dokumentierte Version nach Übernahme des
' SAP-Konverter-Projekts von Reinhard Lindner.
'
'==============================================================================

Option Explicit

'--- Klassen GUID
Private Const GUID_CLASS_SYSTEM     As String = "{D8CF5675-2151-11D2-9396-CA53FC3C99A4}"
Private Const GUID_CLASS_LANGUAGE   As String = "{D8CF5672-2151-11D2-9396-CA53FC3C99A4}"
Private Const GUID_CLASS_RESOURCE   As String = "{E1715082-1E37-11D2-9396-444553540000}"
Private Const GUID_CLASS_ProductAccessoriesPage  As String = "{E1715081-1E37-11D2-9396-444553540000}"

'--- Definitionen für die Erzeugung von GUIDs als OIDs
Private Type tGUID
    bytes(15) As Byte
End Type

'--- Private Declares
Private Declare Function CoCreateGuid Lib "OLE32.dll" (guid As tGUID) As Long
Private Declare Function StringFromGUID2 Lib "OLE32.dll" (guid As tGUID, ByVal lpszString As String, ByVal lMax As Long) As Long

' Private Member
' --------------
Private m_ADOConnection As ADODB.connection
Private m_bADOConnectionOpen As Boolean
Private m_sUserName As String

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Name       :  Connect
' Purpose    :  Connects to a given database
' Parameters :  Database Name, Database Path
' Return val :  NA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function connect(sUserName As String, sPW As String, sDBName As String, sDBPath As String) As Boolean
    Dim sADOConnectionstring As String
    
    On Error GoTo ConnectionError
    
    sADOConnectionstring = "DRIVER={Microsoft Access Driver (*.mdb)};" & _
                   "DBQ=" & sDBName & ";" & _
                   "DefaultDir=" & sDBPath & ";" & _
                   "UID=" & sUserName & ";PWD=" & sPW & ";"
                   
    Set m_ADOConnection = New ADODB.connection
    m_ADOConnection.ConnectionString = sADOConnectionstring
    m_ADOConnection.ConnectionTimeout = 30
    m_ADOConnection.Provider = "MSDASQL"
    'm_ADOConnection.Provider = "Microsoft.Jet.OLEDB.4.0"
    m_ADOConnection.Open
    
    m_bADOConnectionOpen = True
    m_sUserName = sUserName
    
    connect = True
    Exit Function
    
ConnectionError:
    m_bADOConnectionOpen = False
    m_sUserName = ""
    Exit Function
    
End Function


Public Function ADOConnect(sADOConnectionstring As String) As Boolean
    On Error GoTo ConnectionError
                       
    Set m_ADOConnection = New ADODB.connection
    m_ADOConnection.ConnectionString = sADOConnectionstring
    m_ADOConnection.ConnectionTimeout = 30
    m_ADOConnection.Provider = "MSDASQL"
    'm_ADOConnection.Provider = "Microsoft.Jet.OLEDB.4.0"
    m_ADOConnection.Open
    
    m_bADOConnectionOpen = True
    'm_sUserName = sUserName
    
    ADOConnect = True
    Exit Function
    
ConnectionError:
   MsgBox ("Datenbank Fehler: " & Err.Description)
    m_bADOConnectionOpen = False
    m_sUserName = ""
    Exit Function
End Function


Public Function ADOClose()
    On Error Resume Next
    m_ADOConnection.Close
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Name       :  CloseConnection
' Purpose    :
' Parameters :  NA
' Return val :  NA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub CloseConnection()
    On Error Resume Next
    m_ADOConnection.Close
    Set m_ADOConnection = Nothing
    m_bADOConnectionOpen = False
    On Error GoTo 0
End Sub

' @return true = ADO-Connection vorhanden
'
Public Function isADOConnectionOpen() As Boolean
    isADOConnectionOpen = m_bADOConnectionOpen
End Function

' @return Referenz auf die ADO-Connection
'
Public Function getConnection() As ADODB.connection
    Set getConnection = m_ADOConnection
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Name       :  CreateGUID
' Purpose    :  Erzeugen einer eindeutigen Objekt-Identifikation (OID).
'               Windows GUIDs sind per Definition eindeutig!
' Parameters :  NA
' Return val :  GUID
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function CreateGUID() As String
    Dim guid    As tGUID
    Dim s       As String
    Dim n       As Long
    
    s = Space(100)
    
    CoCreateGuid guid
    n = StringFromGUID2(guid, s, Len(s))
    
    CreateGUID = Left$(StrConv(s, vbFromUnicode), n - 1)
End Function

' Helper für Fehlerausgaben
'
' @param sInfo  optionaler Hinweistext
'
Private Sub showError(sMethod As String, Optional sInfo As String)
    Call modError.showError("CDBAccess." + sMethod, sInfo)
End Sub