[Resolvido]Função Bloqueia Shift

Tenho esta função que funcionava perfeitament, agora está dando erro: Tipos Incompatíveis

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

Dim dbs As Database, prp As Property
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) = varPropValue
AlterarPropriedade = True

Change_Bye:
Exit Function

Change_Err:
If err = conPropNotFoundError Then ' Propriedade não localizada.

Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
' Erro desconhecido.
AlterarPropriedade = False
Resume Change_Bye
End If
End Function

Alguma idéia do que pode ser?

Cumprimentos.

Tenho esta que funfa na perfeição, Ms Access 2003-2007;

Function ChangeShift(strMDBName As String, fChange As Boolean)
On Error GoTo ChangeShift_Err
Dim db As Database, prp As Property

Set db = DBEngine(0).OpenDatabase(strMDBName)

db.Properties("AllowBypassKey") = fChange

ChangeShift_Done:
        MsgBox "A propriedade 'AllowBypassKey' de" & vbCrLf _
        & strMDBName & " foi alterada com sucesso para '" _
        & fChange & "'", vbInformation, "Soft & Soft"

ChangeShift_End:
Set db = Nothing
Set prp = Nothing
Exit Function

ChangeShift_Err:
If Err = 3270 Then
Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, _
fChange, True)
db.Properties.Append prp
GoTo ChangeShift_Done
Else
MsgBox "Error # " & Err & " @@" & Err.Description, _
vbExclamation, "Error"
End If

Resume ChangeShift_End
End Function

Private Sub BotaoAtiva_Click()
Print ChangeShift(Me!caminho, True)
End Sub


Private Sub BotaoDesativa_Click()
Print ChangeShift(Me!caminho, False)
End Sub

O mesmo erro Mestre...

Tipos Incompatíveis;;;

Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, _
fChange, True)


Cumprimentos.

Veja se lhe falta marcar alguma referencia VBA.

Tem ideia de qual seja?

Aqui tenho estas:

Cumprimentos.

Piloto subistitua essa linha:

Está usando:
Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)


substua por esta:
Set prp = dbs.CreateProperty(strPropName, _
varPropType, varPropValue)


Aqui funcionou!

Uso esta:



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 ' Propriedade não encontrada.
Set prp = dbs.CreateProperty(strPropName, _
varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
' Erro desconhecido.
ChangeProperty = False
Resume Change_Bye
End If
End Function




' Esta é a função para liberar o Shift
Sub LiberaShift()
Const DB_Boolean As Long = 1
ChangeProperty "AllowBypassKey", DB_Boolean, True
End Sub

'Esta para Travar
Sub TravaShift()
Const DB_Boolean As Long = 1
ChangeProperty "AllowBypassKey", DB_Boolean, False
End Sub

Boas Lupercio... a sua função funcionou.


Obrigado a todos.

Cumprimentos.

Que bom que funcionou, amigo!