Solved ShowHideControls (1 Viewer)

james7705

Registered User.
Local time
Today, 20:28
Joined
Aug 2, 2012
Messages
36
Hi all

I found this piece of code on a login form that I am using on my database.

The issue I have is when I compile it, it gives me a compile error: "Expected user-defined type, not object"
How do I fix this?


Code:
Public Function SetProperties(PropName As String, PropType As Variant, PropValue As Variant) As Integer
On Error GoTo Err_SetProperties
Dim db As Database, prop As Property
Set db = CurrentDb
    db.Properties(PropName) = PropValue
    SetProperties = True
Set db = Nothing
Exit_SetProperties:
Exit Function

Err_SetProperties:
If Err = 3270 Then
Set prop = db.CreateProperty(PropName, PropType, PropValue)
    db.Properties.Append prop
Resume Next
Else
Set Properties = False
    MsgBox "runtime Error #" & Err.Number & vbCrLf & vbLf & Err.Description
Resume Exit_SetProperties
End If
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:28
Joined
Sep 21, 2011
Messages
14,046
I believe you have a missing reference?
However I can never find out how you can tell what reference you need for certain functions :(
Might be worth pasting a copy of your references list to confirm.?
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:28
Joined
Sep 21, 2011
Messages
14,046
Having tried your code, my 2007 balks at
Code:
Set Properties = False
but not that error.
Your variable is SetProperties, but also not declared.?

See here https://docs.microsoft.com/en-us/of...access-objects/create-a-user-defined-property

and this is the module in Northwind 2007

HTH
Code:
Option Compare Database
Option Explicit

Private dbs As DAO.Database
Private prp As DAO.Property
Private prps As DAO.Properties

Public Sub SetProperty(strName As String, lngType As Long, _
   varValue As Variant)
'Created by Helen Feddema 31-Mar-2017
'Modified by Helen Feddema 31-Mar-2017
'Called from various procedures


On Error GoTo ErrorHandler
   'Attempt to set the specified property
   Set dbs = CurrentDb
   Set prps = dbs.Properties
   prps(strName) = varValue


ErrorHandlerExit:
   Set dbs = Nothing
   Set prps = Nothing
   Exit Sub
  
ErrorHandler:
    If Err.Number = 3270 Then
      'The property was not found; create it
      Set prp = dbs.CreateProperty(Name:=strName, _
         Type:=lngType, Value:=varValue)
      CurrentDb.Properties.Append prp
      Resume Next
   Else
    MsgBox "Error No: " & Err.Number _
      & " in SetProperty procedure; " _
      & "Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
End Sub
Public Function GetProperty(strName As String, strDefault As String) _
   As Variant
'Created by Helen Feddema 31-Mar-2017
'Modified by Helen Feddema 31-Mar-2017
'Called from various procedures
On Error GoTo ErrorHandler
  
   'Attempt to get the value of the specified property
   Set dbs = CurrentDb
   GetProperty = dbs.Properties(strName).Value
ErrorHandlerExit:
   Exit Function
ErrorHandler:
   If Err.Number = 3270 Then
      'The property was not found; use default value
      GetProperty = strDefault
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & " in GetProperty procedure; " _
         & "Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
    Set dbs = Nothing

End Function
Public Sub SaveDBProperties()
' Based on code supplied by Helen Feddema from the net
Dim db As Database
Dim strSQL As String, strTable As String
Dim rst As Recordset
Dim prp As Property

strTable = "tblDBProperty"

' Delete the table if it exists
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & strTable & "'")) Then
    DoCmd.SetWarnings False
    DoCmd.Close acTable, strTable, acSaveNo
    DoCmd.DeleteObject acTable = acDefault, strTable
    ' Debug.Print "Table" & tableName & "deleted..."
    DoCmd.SetWarnings True
End If

' Now create it again
CurrentDb.Execute _
    "CREATE TABLE " & strTable & "(PropID COUNTER(1, 1) PRIMARY KEY, " & _
    "PropName Text(100), " & _
    "PropType Long, " & _
    "PropValue Text(100), " & _
    "PropCreate BIT)"
CurrentDb.TableDefs.Refresh

' Now populate it

Set db = CurrentDb
'strSQL = "delete * from tblDBproperty"
'db.Execute strSQL, dbFailOnError

Set rst = db.OpenRecordset(strTable)
' Now get standard properties
With rst
    For Each prp In db.Properties
        .AddNew
        !PropName = prp.Name
        !PropType = prp.Type
        ' Can save value if type is 0
        If prp.Type <> 0 Then
            !PropValue = prp.Value
        End If
        !PropCreate = False
        .Update
    Next prp
    ' Now look for any custom properties
'    For Each prp In db.Containers("Databases").Documents("UserDefined").Properties
'        .AddNew
'        !PropName = prp.Name
'        !PropType = prp.Type
'        ' Can save value if type is 0
'        If prp.Type <> 0 Then
'            !PropValue = prp.Value
'        End If
'        .Update
'    Next prp
   
   
End With
rst.Close
Set db = Nothing
Set rst = Nothing
MsgBox strTable & " has been created and populated"
End Sub
Sub RestoreDBProperties()
Dim db As Database
Dim strSQL As String, strTable As String
Dim rst As Recordset
Dim prp As Property

strTable = "tblDBProperty"
strSQL = "SELECT * FROM tblDBProperty WHERE PropCreate = TRUE"
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL)

With rst
    Do Until .EOF
        Call SetProperty(rst!PropName, rst!PropType, rst!PropValue)
        .MoveNext
    Loop
End With
rst.Close
Set db = Nothing
Set rst = Nothing
MsgBox "Properties have been created"

End Sub
Public Function DeleteProp(strName As String)
'Created from code by Helen Feddema 31-Mar-2017
'Modified by Paul Steel 21/11/18
'Can be called from various procedures, mainly used for testing
    On Error GoTo ErrorHandler

    'Attempt to get the specified property
    Set dbs = CurrentDb
    dbs.Properties.Delete (strName)
   
ErrorHandlerExit:
    Set dbs = Nothing
    Exit Function
   
ErrorHandler:
    If Err.Number <> 3265 Then    'The property was not found
        MsgBox "Error No: " & Err.Number _
             & " in GetProperty procedure; " _
             & "Description: " & Err.Description
        Resume ErrorHandlerExit
    End If

End Function
Public Function ListAllProps()
'Created by Helen Feddema 31-Mar-2017
'Modified by Helen Feddema 31-Mar-2017
'Lists all database properties
Dim iProp As Integer
On Error Resume Next
  
   Set dbs = CurrentDb
   Debug.Print "All database properties:"
  
   For Each prp In dbs.Properties
      Debug.Print vbTab & iProp & ". " & prp.Name & ": " & prp.Type & ": " & prp.Value
        iProp = iProp + 1

   Next prp
End Function
Public Function ListCustomProps()
'Created by Helen Feddema 31-Mar-2017
'Modified by Helen Feddema 31-Mar-2017
'Lists custom database properties
On Error Resume Next
  
   Set dbs = CurrentDb
   Debug.Print "Custom database properties:"
  
   For Each prp In _
      dbs.Containers("Databases").Documents("UserDefined").Properties
      Debug.Print vbTab & prp.Name & ": " & prp.Type & ": " & prp.Value
   Next prp
    Set dbs = Nothing

End Function
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 18:28
Joined
Sep 21, 2011
Messages
14,046
I also have to ask, what does it have to do with 'ShowHideControls'
 

james7705

Registered User.
Local time
Today, 20:28
Joined
Aug 2, 2012
Messages
36
I believe you have a missing reference?
However I can never find out how you can tell what reference you need for certain functions :(
Might be worth pasting a copy of your references list to confirm.?
Hi Gasman

Here is the complete module that I am using. The idea is for it to lock the database from unauthorised tampering? The error seems to highlight on row 24 "Dim db As Database, prop As Property" giving me a compile error.


Code:
Option Compare Database
Option Explicit

#If VBA7 Then
Public Declare PtrSafe Function ShowWindowAsync Lib "user32" _
    (ByVal Hwnd As Long, _
    ByVal nCmdShow As Long) As Boolean

#ElseIf Win64 Then
Public Declare PtrSafe Function ShowWindowAsync Lib "user32" _
    (ByVal Hwnd As LongPtr, _
    ByVal nCmdShow As Long) As Boolean

#Else
Public Declare PtrSafe Function ShowWindowAsync Lib "user32" _
    (ByVal Hwnd As Long, _
    ByVal nCmdShow As Long) As Boolean
#End If

Private Const SW_HIDE = 0
Private Const WS_SHOW = 5

Public Function SetProperties(PropName As String, PropType As Variant, PropValue As Variant) As Integer
On Error GoTo Err_SetProperties
Dim db As Database, prop As Property
Set db = CurrentDb
    db.Properties(PropName) = PropValue
    SetProperties = True
Set db = Nothing
Exit_SetProperties:
Exit Function

Err_SetProperties:
If Err = 3270 Then
Set prop = db.CreateProperty(PropName, PropType, PropValue)
    db.Properties.Append prop
Resume Next
Else
Set Properties = False
    MsgBox "runtime Error #" & Err.Number & vbCrLf & vbLf & Err.Description
Resume Exit_SetProperties
End If

End Function

Public Function DisableProperties()
On Error GoTo TheError
DoCmd.ShowToolbar "Ribbon", acToolbarNo
SetProperties "StartUpShowDBWindow", dbBoolean, False
SetProperties "StartUpShowStatusBar", dbBoolean, False
SetProperties "AllowFullMenus", dbBoolean, False
SetProperties "AllowSpecialKeys", dbBoolean, False
SetProperties "AllowBypassKey", dbBoolean, False
SetProperties "AllowShortcutMenus", dbBoolean, False
SetProperties "AllowToolbarChanges", dbBoolean, False
SetProperties "AllowBreakIntoCode", dbBoolean, False
Exit Function
TheError:
MsgBox Err.Description
Exit Function

End Function

Public Function EnableProperties()
On Error GoTo ErrorHandler:
DoCmd.ShowToolbar "Ribbon", acToolbarYes
SetProperties "StartUpShowDBWindow", dbBoolean, True
SetProperties "StartUpShowStatusBar", dbBoolean, True
SetProperties "AllowFullMenus", dbBoolean, True
SetProperties "AllowSpecialKeys", dbBoolean, True
SetProperties "AllowBypassKey", dbBoolean, True
SetProperties "AllowShortcutMenus", dbBoolean, True
SetProperties "AllowToolbarChanges", dbBoolean, True
SetProperties "AllowBreakIntoCode", dbBoolean, True
Exit Function
ErrorHandler:
MsgBox Err.Description
Exit Function

End Function
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:28
Joined
Sep 21, 2011
Messages
14,046
Try prefixing with DAO as in the Northwind example?

Not something I have played with TBH.
 

Users who are viewing this thread

Top Bottom