Attribute VB_Name = "DynamicConnesODBC"
Option Explicit

Public ConnSTAMPA As ADODB.Connection 'punta al database per le stampe

'Dichiarazione Costanti Percorso
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003


Public Const KEY_QUERY_VALUE = &H1
Public Const ERROR_SUCCESS = 0&
Public Const REG_SZ = 1
Public Const REG_DWORD = 4


'Dichiarazione Costanti

Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
    KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
    KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And _
    (Not SYNCHRONIZE))
Public Const ERROR_NO_MORE_ITEMS = 259&

Public Const REG_BINARY = 3
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_DWORD_LITTLE_ENDIAN = 4
Public Const REG_EXPAND_SZ = 2
Public Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Public Const REG_LINK = 6
Public Const REG_MULTI_SZ = 7
Public Const REG_NONE = 0
Public Const REG_RESOURCE_LIST = 8
Public Const REG_RESOURCE_REQUIREMENTS_LIST = 10




Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long

Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

'Declare Function RegCreateKey Lib "advapi32.dll" Alias _
'    "RegCreateKeyA" (ByVal hKey As Long, ByVal lpctstr _
'    As String, phkey As Long) As Long

Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal _
    lpValueName As String, ByVal Reserved As Long, ByVal _
    dwType As Long, lpData As Any, ByVal cbData As Long) _
    As Long

Public Declare Function RegOpenKey Lib "advapi32.dll" Alias _
    "RegOpenKeyA" (ByVal hKey As Long, ByVal lpctstr As _
    String, phkey As Long) As Long

'Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
'    "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
'    ByVal ulOptions As Long, ByVal samDesired As Long, _
'    phkResult As Long) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias _
    "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, _
    ByVal lpName As String, ByVal cbName As Long) As Long

Private Declare Function RegQueryValue Lib "advapi32.dll" Alias _
    "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    ByVal lpValue As String, lpcbValue As Long) As Long

'Private Declare Function RegCloseKey Lib "advapi32.dll" _
'    (ByVal hKey As Long) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
    "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long


Public Function isSZKeyExist(szKeyPath As String, szKeyName As String, ByRef szKeyValue As String) As Boolean
    Dim bRes As Boolean
    Dim lRes As Long
    Dim hKey As Long
    
    lRes = RegOpenKeyEx(HKEY_LOCAL_MACHINE, szKeyPath, 0&, KEY_QUERY_VALUE, hKey)

    If lRes <> ERROR_SUCCESS Then
        isSZKeyExist = False
        Exit Function
    End If
    
    lRes = RegQueryValueEx(hKey, szKeyName, 0&, REG_SZ, ByVal szKeyValue, Len(szKeyValue))
    
    RegCloseKey (hKey)

    If lRes <> ERROR_SUCCESS Then
        isSZKeyExist = False
        Exit Function
    End If
    
    isSZKeyExist = True

End Function


Public Function checkAccessDriver(ByRef szDriverName As String) As Boolean
    Dim szKeyPath As String
    Dim szKeyName As String
    Dim szKeyValue As String
    Dim bRes As Boolean
    
    
    bRes = False
    
    szKeyPath = "SOFTWARE\ODBC\ODBCINST.INI\Microsoft Access Driver (*.mdb)"
    szKeyName = "Driver"
    szKeyValue = String(255, Chr(32))
    

    If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
        szDriverName = szKeyValue
        bRes = True
    Else
        bRes = False
    End If
    
    checkAccessDriver = bRes
End Function



Public Function checkWantedAccessDSN(szWantedDSN As String) As Boolean
    Dim szKeyPath As String
    Dim szKeyName As String
    Dim szKeyValue As String
    Dim bRes As Boolean
    
    szKeyPath = "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources"
    szKeyName = szWantedDSN
    szKeyValue = String(255, Chr(32))
    

    If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
        bRes = True
    Else
        bRes = False
    End If
    
    checkWantedAccessDSN = bRes
    
End Function



Public Function createAccessDSN(szDriverName As String, _
    szWantedDSN As String) As Boolean
    
    Dim hKey As Long
    Dim szKeyPath As String
    Dim szKeyName As String
    Dim szKeyValue As String
    Dim lKeyValue As Long
    Dim lRes As Long
    Dim lSize As Long
    Dim szEmpty As String
    
    szEmpty = Chr(0)
        
    lSize = 4
    lRes = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN, hKey)

    If lRes <> ERROR_SUCCESS Then
        createAccessDSN = False
        Exit Function
    End If
    
    lRes = RegSetValueExString(hKey, "UID", 0&, REG_SZ, szEmpty, Len(szEmpty))
    
    szKeyValue = PathSTAMPE
    lRes = RegSetValueExString(hKey, "DBQ", 0&, REG_SZ, szKeyValue, Len(szKeyValue))
    szKeyValue = szDriverName
    lRes = RegSetValueExString(hKey, "Driver", 0&, REG_SZ, szKeyValue, Len(szKeyValue))
    szKeyValue = "MS Access;"
    lRes = RegSetValueExString(hKey, "FIL", 0&, REG_SZ, szKeyValue, Len(szKeyValue))
    lKeyValue = 25
    lRes = RegSetValueExLong(hKey, "DriverId", 0&, REG_DWORD, lKeyValue, 4)
    
    lKeyValue = 0
    lRes = RegSetValueExLong(hKey, "SafeTransactions", 0&, REG_DWORD, lKeyValue, 4)
    
    lRes = RegCloseKey(hKey)
    szKeyPath = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
    
    lRes = RegCreateKey(HKEY_LOCAL_MACHINE, szKeyPath, hKey)

    If lRes <> ERROR_SUCCESS Then
        createAccessDSN = False
        Exit Function
    End If
    
    lRes = RegSetValueExString(hKey, "ImplicitCommitSync", 0&, REG_SZ, szEmpty, Len(szEmpty))
    szKeyValue = "Yes"
    lRes = RegSetValueExString(hKey, "UserCommitSync", 0&, REG_SZ, szKeyValue, Len(szKeyValue))
    lKeyValue = 2048
    lRes = RegSetValueExLong(hKey, "MaxBufferSize", 0&, REG_DWORD, lKeyValue, 4)
    
    lKeyValue = 5
    lRes = RegSetValueExLong(hKey, "PageTimeout", 0&, REG_DWORD, lKeyValue, 4)
    
    lKeyValue = 3
    lRes = RegSetValueExLong(hKey, "Threads", 0&, REG_DWORD, lKeyValue, 4)
    
    lRes = RegCloseKey(hKey)
    lRes = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKey)

    If lRes <> ERROR_SUCCESS Then
        createAccessDSN = False
        Exit Function
    End If
    
    szKeyValue = "Microsoft Access Driver (*.mdb)"
    lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, szKeyValue, Len(szKeyValue))
    
    lRes = RegCloseKey(hKey)
    createAccessDSN = True
End Function



'--------------------------------------------------------------------------
'Cancella tutte le sottochiavi di una chiave.
'Ritorna True se la funzione ha avuto esito positivo.
'--------------------------------------------------------------------------
'RootKey        Chiave principale;
'KeyToDelete    Percorso della chiave da eliminare;
'--------------------------------------------------------------------------
Private Function prvDeleteSubKeys( _
    ByVal RootKey As Long, _
    ByVal KeyToDelete As String) _
    As Boolean
    
    'Imposto il ritorno alla funzione in caso di errore
    prvDeleteSubKeys = False
    
    'Dichiarazione variabili
    Dim hKey As Long                'Chiave principale
    Dim SubKeys As Collection       'Sotto chiavi
    Dim SubKeyNum As Long           'Indice sotto chiavi
    Dim KeyLength As Long           'Lunghezza chiave
    Dim SubKeyToDelete As String    'Sotto chiave da cancellare
    
    'Apro la chiave
    If RegOpenKeyEx(RootKey, KeyToDelete, _
        0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then
        
        'In caso di errore visualizzo un messaggio ed esco
        MsgBox "Errore durante l'apertura della chiave '" & _
            KeyToDelete & "'", vbCritical
        Exit Function
    End If
    
    'Imposto la Collection
    Set SubKeys = New Collection
    
    'Inizio l'enumerazione delle sotto chiavi
    SubKeyNum = 0
    
    'Inizio il ciclo
    Do
        
        'Lascio liberta' al sistema
        DoEvents
        
        'Imposto la lunghezza della chiave
        KeyLength = 256
        SubKeyToDelete = Space$(KeyLength)
        
        'Continuo fino a che non ricevo un'errore
        If RegEnumKey(hKey, SubKeyNum, SubKeyToDelete, KeyLength) _
            <> ERROR_SUCCESS Then Exit Do
        
        SubKeyNum = SubKeyNum + 1
        
        'Pulisco il nome della chiave da cancellare
        SubKeyToDelete = Left$(SubKeyToDelete, _
            InStr(SubKeyToDelete, Chr$(0)) - 1)
        
        'Aggiorno la Collection
        SubKeys.Add SubKeyToDelete
    Loop
    
    'Cancello tutte le SubKeys e le relative SubKeys
    For SubKeyNum = 1 To SubKeys.Count
        
        'Procedo con l'eliminazione
        prvDeleteSubKeys RootKey, KeyToDelete & "\" & SubKeys(SubKeyNum)
        
        'Elimino la SubKey
        RegDeleteKey hKey, SubKeys(SubKeyNum)
    
    Next SubKeyNum
    
    'Chiudo la chiave
    RegCloseKey hKey
    
    'Restituisco il valore alla funzione
    prvDeleteSubKeys = True
End Function

'--------------------------------------------------------------------------
'Elimina una chiave
'Ritorna True se la funzione ha avuto esito positivo.
'--------------------------------------------------------------------------
'RootKey        Chiave principale;
'KeyToDelete    Chiave da cancellare;
'--------------------------------------------------------------------------
Function pubDeleteKey( _
    ByVal RootKey As Long, _
    ByVal KeyToDelete As String) _
    As Boolean
    
    'Imposto un valore da restituire in caso di errore
    pubDeleteKey = False
    
    'Dichiarazione variabili
    Dim KeyNameStart As Integer         'Inizio nome chiave
    Dim KeyToDeletePath As String       'Percorso chiave da cancellare
    Dim hKey As Long                    'Chiave
    
    'Controllo la formattazione delle chiave da eliminare
    If Right$(KeyToDelete, 1) = "\" Then _
        KeyToDelete = Left$(KeyToDelete, Len(KeyToDelete) - 1)

    'Elimino le sotto chiavi della chiave passata
    prvDeleteSubKeys RootKey, KeyToDelete
    
    'Ottengo il nome della chiave da cancellare
    KeyNameStart = InStrRev(KeyToDelete, "\")
    
    'Controllo la posizione della chiave
    If KeyNameStart = 0 Then
        
        'Se la chiave e' una chiave principale
        'la cancello dalla root
        RegDeleteKey RootKey, KeyToDelete
        
    Else
        
        'Se non si tratta della chiave principale
        'ne trovo il percorso
        KeyToDeletePath = Left$(KeyToDelete, KeyNameStart - 1)
        
        'Ricavo il nome della chiave
        KeyToDelete = Mid$(KeyToDelete, KeyNameStart + 1)

        'Apro la chiave
        If RegOpenKeyEx(RootKey, KeyToDeletePath, _
            0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then
            
            'Se riscontro errori visualizzo un messaggio
            MsgBox "Errore durante l'apertura della chiave '" & _
                KeyToDeletePath, vbCritical
            
        Else
            
            'Elimino la chiave
            RegDeleteKey hKey, KeyToDelete
            
            'Chiudo la chiave
            RegCloseKey hKey
        End If
    End If
    
    'Resituisco il valore alla funzione
    pubDeleteKey = True
End Function



'****** MIE SUB PER APRIRE E CHIUDERE LA CONNESSIONE ******* (Gianpiero)

Public Sub ApriAmbienteStampe()
'''   '***********************************************
'''    '****** controllo sull'esistenza della connessione ODBC
'''    '***********************************************
'''
'''    Dim szDriverName As String
'''    Dim szWantedDSN As String
'''
'''    szDriverName = String(255, Chr(32))
'''    szWantedDSN = App.EXEName & "Stampe"
'''
'''    'controllo se sono installati i driver per Access
'''
'''    If Not checkAccessDriver(szDriverName) Then
'''        MsgBox "Installare i Drivers ODBC Access prima di usare questo programma.", vbOK + vbCritical, "Avviso"
'''    End If
'''
'''    'controllo se esiste il DSN individuato nel file INI
'''
'''    If Not createAccessDSN(szDriverName, szWantedDSN) Then
'''        MsgBox "Can't create database ODBC.", vbOK + vbCritical
'''    End If
'''
'''    Set ConnSTAMPA = New ADODB.Connection
'''    ConnSTAMPA.Open "Data Source=" & App.EXEName & "Stampe"


'Apro l'ambiente di lavoro del Database
   Set ConnSTAMPA = New ADODB.Connection
   'ConnessioneAzienda.ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source =" & PathDBGest & "\" & Azienda & ";Extended Properties=DBASE IV;"
   ConnSTAMPA.ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source =" & PathSTAMPE & ";Jet OLEDB:Database Password=;"
   ConnSTAMPA.Open
   
End Sub

Public Sub ChiudiAmbienteStampe()
   ConnSTAMPA.Close
End Sub

