[Access] attiva disattiva shift con password [RISOLTO]

Question

Ciao a tutti,

anche oggi ho bisogno del vostro cortese aiuto quindi vi sottopongo il mio nuovo problema.

ho un database al quale attivo o disattivo lo shift servendomi di questa maschera che è attivabile dall'interno del DB stesso. Per una maggiore sicurezza, anche in virtù che in passato è capitato che la maschera iniziale di un db si è corrotta  impedendomi di fatto di accedere al db, vorrei implemantare l'utility esterna della possibilità di disattivare il blocco dello shift del mio db protetta da password.

allego i codici che utilizzo per il blocco/sblocco shift interno al db e i codici dell'utility per l'attiva/disattiva shift esterno al db.

Vi ringrazio anticipatamente

Private Sub Pass_AfterUpdate()

If Pass.value = "Paperino" Then

  ChangeProperty "AllowBypassKey", DB_Boolean, True

  MsgBox "Ora chiudi il DB e riaprilo tenendo premuto il tasto Shift", vbInformation, "Password Corretta"

  DoCmd.Close

         Else

        ChangeProperty "AllowBypassKey", DB_Boolean, False

        MsgBox "Password ERRATA", vbCritical, "AVVISO"

      DoCmd.Close

      DoCmd.OpenForm "PasswordStruttura", acNormal

        End If

End Sub

codice modulo:

Option Compare Database

Sub SetBypassProperty()

Const DB_Boolean As Long = 1

    ChangeProperty "AllowBypassKey", DB_Boolean, False

End Sub

Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer

    Dim dbs As Object, prp As Variant

    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb

    On Error GoTo Change_Err

    dbs.Properties(strPropName) = varPropValue

    ChangeProperty = True

Change_Bye:

    Exit Function

Change_Err:

    If err = conPropNotFoundError Then

        Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)

dbs.Properties.Append prp

        Resume Next

    Else

        ChangeProperty = False

        Resume Change_Bye

    End If

End Function

utility esterna al database maschera:

Option Compare Database

Option Explicit

Private Sub cmdSelFile_Click()

    Dim strDatabase As String

    strDatabase = cmdlg_file

    If strDatabase = "" Then Exit Sub

    Me.txtDatabase = strDatabase

End Sub

Private Sub Esegui_Click()

Dim a As String

    If AD = 0 Then

      a = "disabilitato"

    ElseIf AD = -1 Then

      a = "abilitato"

    End If

    If IsNull(txtDatabase) Then

      MsgBox ("Inserire il percorso, il nome e l'estensione del database"), vbExclamation

    Else

      Call BypassKey([AD], [txtDatabase])

        If BypassKey([AD], [txtDatabase]) = True Then

          MsgBox ("Tasto shift " & a), vbOKOnly

        Else

          MsgBox ("Database o percorso non validi!"), vbCritical

        End If

    End If

End Sub

Private Sub Comando10_Click()

On Error GoTo Err_Comando10_Click

    DoCmd.Quit

Exit_Comando10_Click:

    Exit Sub

Err_Comando10_Click:

    MsgBox Err.Description

    Resume Exit_Comando10_Click

End Sub

codice modulo:

Option Compare Database

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _

            Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME

   lStructSize As Long

   hwndOwner As Long

   hInstance As Long

   lpstrFilter As String

   lpstrCustomFilter As String

   nMaxCustFilter As Long

   nFilterIndex As Long

   lpstrFile As String

   nMaxFile As Long

   lpstrFileTitle As String

   nMaxFileTitle As Long

   lpstrInitialDir As String

   lpstrTitle As String

   flags As Long

   nFileOffset As Integer

   nFileExtension As Integer

   lpstrDefExt As String

   lCustData As Long

   lpfnHook As Long

   lpTemplateName As String

End Type

Public Function cmdlg_file() As String

     'Restituisce: il percorso completo del file selezionato

   Dim OpenFile As OPENFILENAME

   Dim lReturn As Long

   Dim sFilter As String

   OpenFile.lStructSize = Len(OpenFile)

   sFilter = "Database di Microsoft Access (*.mdb)" & Chr(0) & "*.mdb" & Chr(0)

   OpenFile.lpstrFilter = sFilter

   OpenFile.nFilterIndex = 1

   OpenFile.lpstrFile = String(257, 0)

   OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

   OpenFile.lpstrFileTitle = OpenFile.lpstrFile

   OpenFile.nMaxFileTitle = OpenFile.nMaxFile

   OpenFile.lpstrInitialDir = "C:"

   OpenFile.lpstrTitle = "Seleziona file"

   OpenFile.flags = 0

   lReturn = GetOpenFileName(OpenFile)

   If lReturn = 0 Then

      cmdlg_file = ""

   Else

      cmdlg_file = Left(OpenFile.lpstrFile, InStr(OpenFile.lpstrFile, Chr$(0)) - 1)

   End If

End Function

Public Function BypassKey(bolVal As Boolean, Optional strMdb As String) As Boolean

'Autore: Federico Luciani dal sito comune del newsgroup di it.comp.app.access

'Accetta:

'bolVal = True: abilita; False: disabilita

'strMdb = [Opz.] percorso+nome del database

'Restituisce: True l'operazione e' stata eseguita correttamente

On Error GoTo bypass_Err

    Dim wrk As Workspace

    Dim dbs As Database

    Set wrk = DBEngine.Workspaces(0)

    If strMdb = "" Then

        Set dbs = CurrentDb()

    Else

        Set dbs = wrk.OpenDatabase(strMdb)

    End If

    dbs.Properties("AllowBypassKey") = bolVal

    BypassKey = True

    Set dbs = Nothing

    Set wrk = Nothing

    Exit Function

bypass_Err:

    If Err = 3270 Then

        Dim prp As Property

        Set prp = dbs.CreateProperty("AllowBypassKey", dbBoolean, True)

        dbs.Properties.Append prp

        Resume

    Else

        BypassKey = False

    End If

End Function

Answer 1

ciao giorgio, vorrei applicarla a questa utility esterna ma va oltre le mie competenze :-(

Ciao Luca,

in quel codice ci sono diversi punti oscuri, ad esempio la variabile AD non vedo dove è dichiarata e dove viene valorizzata.

Come già detto in precedenza io creerei un db di utility.

Facciamo così:

se non sei in grado di costruirne uno in modo autonomo, usa e prendi spunto da questo esempio che ho preparato al volo.

---

AbilitaDisabilitaShift.mdb

http://cid-ac66fd4806f55617.skydrive.live.com/self.aspx/Pubblica/msaccess/Db/AbilitaDisabilitaShift.mdb

---

Ciao

Giorgio Rancati

Answer 2

Buongiorno Giorgio,

grazie questo va alla perfezione

quello che utilizzavo io funzionava in tutti tranne che nel mio db

Sicuramente i punti oscuri che hai indivduato, in alcuni casi, ne limitavano l'efficienza.

Ti auguro una buona giornata

Answer 3

ciao giorgio, vorrei applicarla a questa utility esterna ma va oltre le mie conoscenze e capacità:-(

Option Compare Database

Option Explicit

Private Sub cmdSelFile_Click()

    Dim strDatabase As String

    strDatabase = cmdlg_file

    If strDatabase = "" Then Exit Sub

    Me.txtDatabase = strDatabase

End Sub

Private Sub Esegui_Click()

Dim a As String

    If AD = 0 Then

      a = "disabilitato"

    ElseIf AD = -1 Then

      a = "abilitato"

    End If

    If IsNull(txtDatabase) Then

      MsgBox ("Inserire il percorso, il nome e l'estensione del database"), vbExclamation

    Else

      Call BypassKey([AD], [txtDatabase])

        If BypassKey([AD], [txtDatabase]) = True Then

          MsgBox ("Tasto shift " & a), vbOKOnly

        Else

          MsgBox ("Database o percorso non validi!"), vbCritical

        End If

    End If

End Sub

Private Sub Comando10_Click()

On Error GoTo Err_Comando10_Click

    DoCmd.Quit

Exit_Comando10_Click:

    Exit Sub

Err_Comando10_Click:

    MsgBox Err.Description

    Resume Exit_Comando10_Click

End Sub

codice modulo:

Option Compare Database

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _

            Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME

   lStructSize As Long

   hwndOwner As Long

   hInstance As Long

   lpstrFilter As String

   lpstrCustomFilter As String

   nMaxCustFilter As Long

   nFilterIndex As Long

   lpstrFile As String

   nMaxFile As Long

   lpstrFileTitle As String

   nMaxFileTitle As Long

   lpstrInitialDir As String

   lpstrTitle As String

   flags As Long

   nFileOffset As Integer

   nFileExtension As Integer

   lpstrDefExt As String

   lCustData As Long

   lpfnHook As Long

   lpTemplateName As String

End Type

Public Function cmdlg_file() As String

     'Restituisce: il percorso completo del file selezionato

   Dim OpenFile As OPENFILENAME

   Dim lReturn As Long

   Dim sFilter As String

   OpenFile.lStructSize = Len(OpenFile)

   sFilter = "Database di Microsoft Access (*.mdb)" & Chr(0) & "*.mdb" & Chr(0)

   OpenFile.lpstrFilter = sFilter

   OpenFile.nFilterIndex = 1

   OpenFile.lpstrFile = String(257, 0)

   OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

   OpenFile.lpstrFileTitle = OpenFile.lpstrFile

   OpenFile.nMaxFileTitle = OpenFile.nMaxFile

   OpenFile.lpstrInitialDir = "C:"

   OpenFile.lpstrTitle = "Seleziona file"

   OpenFile.flags = 0

   lReturn = GetOpenFileName(OpenFile)

   If lReturn = 0 Then

      cmdlg_file = ""

   Else

      cmdlg_file = Left(OpenFile.lpstrFile, InStr(OpenFile.lpstrFile, Chr$(0)) - 1)

   End If

End Function

Public Function BypassKey(bolVal As Boolean, Optional strMdb As String) As Boolean

'Autore: Federico Luciani dal sito comune del newsgroup di it.comp.app.access

'Accetta:

'bolVal = True: abilita; False: disabilita

'strMdb = [Opz.] percorso+nome del database

'Restituisce: True l'operazione e' stata eseguita correttamente

On Error GoTo bypass_Err

    Dim wrk As Workspace

    Dim dbs As Database

    Set wrk = DBEngine.Workspaces(0)

    If strMdb = "" Then

        Set dbs = CurrentDb()

    Else

        Set dbs = wrk.OpenDatabase(strMdb)

    End If

    dbs.Properties("AllowBypassKey") = bolVal

    BypassKey = True

    Set dbs = Nothing

    Set wrk = Nothing

    Exit Function

bypass_Err:

    If Err = 3270 Then

        Dim prp As Property

        Set prp = dbs.CreateProperty("AllowBypassKey", dbBoolean, True)

        dbs.Properties.Append prp

        Resume

    Else

        BypassKey = False

    End If

End Function

Answer 4

ciao giorgio non ho capito bene, ma questo codice riescea disattivare questo blocco shift?

Ciao Luca,

sì, se  Pass.value = "Paperino" allora disattiva il blocco altrimenti lo attiva.

probabilmente il tuo dubbio deriva dal fatto che erroneamente ho messo nel mio codice

Db.Properties("AllowBypassKey") = False

al posto di

Db.Properties("AllowBypassKey") = True

Ciao

Giorgio Rancati